-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . D E B U G _ P O O L S --
+-- G N A T . D E B U G _ P O O L S --
-- --
--- B o d y --
+-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Unchecked_Conversion;
+with Ada.Exceptions.Traceback;
+with GNAT.IO; use GNAT.IO;
+
+with System.Address_Image;
+with System.Memory; use System.Memory;
+with System.Soft_Links; use System.Soft_Links;
+
+with System.Traceback_Entries; use System.Traceback_Entries;
+
with GNAT.HTable;
-with System.Memory;
+with GNAT.Traceback; use GNAT.Traceback;
-pragma Elaborate_All (GNAT.HTable);
+with Ada.Unchecked_Conversion;
package body GNAT.Debug_Pools is
use System;
- use System.Memory;
use System.Storage_Elements;
- -- Definition of a H-table storing the status of each storage chunck
- -- used by this pool
+ Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment;
+ -- Alignment used for the memory chunks returned by Allocate. Using this
+ -- value garantees that this alignment will be compatible with all types
+ -- and at the same time makes it easy to find the location of the extra
+ -- header allocated for each chunk.
+
+ Initial_Memory_Size : constant Storage_Offset := 2 ** 26; -- 64 Mb
+ -- Initial size of memory that the debug pool can handle. This is used to
+ -- compute the size of the htable used to monitor the blocks, but this is
+ -- dynamic and will grow as needed. Having a bigger size here means a
+ -- longer setup time, but less time spent later on to grow the array.
+
+ Max_Ignored_Levels : constant Natural := 10;
+ -- Maximum number of levels that will be ignored in backtraces. This is so
+ -- that we still have enough significant levels in the tracebacks returned
+ -- to the user.
+ -- The value 10 is chosen as being greater than the maximum callgraph
+ -- in this package. Its actual value is not really relevant, as long as it
+ -- is high enough to make sure we still have enough frames to return to
+ -- the user after we have hidden the frames internal to this package.
- type State is (Not_Allocated, Deallocated, Allocated);
+ -----------------------
+ -- Tracebacks_Htable --
+ -----------------------
+
+ -- This package needs to store one set of tracebacks for each allocation
+ -- point (when was it allocated or deallocated). This would use too much
+ -- memory, so the tracebacks are actually stored in a hash table, and
+ -- we reference elements in this hash table instead.
+
+ -- This hash-table will remain empty if the discriminant Stack_Trace_Depth
+ -- for the pools is set to 0.
+
+ -- This table is a global table, that can be shared among all debug pools
+ -- with no problems.
type Header is range 1 .. 1023;
- function H (F : Address) return Header;
+ -- Number of elements in the hash-table
+
+ type Tracebacks_Array_Access
+ is access GNAT.Traceback.Tracebacks_Array;
+
+ type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);
+
+ type Traceback_Htable_Elem;
+ type Traceback_Htable_Elem_Ptr
+ is access Traceback_Htable_Elem;
+
+ type Traceback_Htable_Elem is record
+ Traceback : Tracebacks_Array_Access;
+ Kind : Traceback_Kind;
+ Count : Natural;
+ Total : Byte_Count;
+ Next : Traceback_Htable_Elem_Ptr;
+ end record;
+
+ procedure Set_Next
+ (E : Traceback_Htable_Elem_Ptr;
+ Next : Traceback_Htable_Elem_Ptr);
+ function Next
+ (E : Traceback_Htable_Elem_Ptr)
+ return Traceback_Htable_Elem_Ptr;
+ function Get_Key
+ (E : Traceback_Htable_Elem_Ptr)
+ return Tracebacks_Array_Access;
+ function Hash (T : Tracebacks_Array_Access) return Header;
+ function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
+ pragma Inline (Set_Next, Next, Get_Key, Hash);
+ -- Subprograms required for instantiation of the htable. See GNAT.HTable.
+
+ package Backtrace_Htable is new GNAT.HTable.Static_HTable
+ (Header_Num => Header,
+ Element => Traceback_Htable_Elem,
+ Elmt_Ptr => Traceback_Htable_Elem_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Tracebacks_Array_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ -----------------------
+ -- Allocations table --
+ -----------------------
+
+ type Allocation_Header;
+ type Allocation_Header_Access is access Allocation_Header;
+
+ -- The following record stores extra information that needs to be
+ -- memorized for each block allocated with the special debug pool.
+
+ type Traceback_Ptr_Or_Address is new System.Address;
+ -- A type that acts as a C union, and is either a System.Address or a
+ -- Traceback_Htable_Elem_Ptr.
+
+ type Allocation_Header is record
+ Block_Size : Storage_Offset;
+ -- Needed only for advanced freeing algorithms (traverse all allocated
+ -- blocks for potential references). This value is negated when the
+ -- chunk of memory has been logically freed by the application. This
+ -- chunk has not been physically released yet.
+
+ Alloc_Traceback : Traceback_Htable_Elem_Ptr;
+ Dealloc_Traceback : Traceback_Ptr_Or_Address;
+ -- Pointer to the traceback for the allocation (if the memory chunck is
+ -- still valid), or to the first deallocation otherwise. Make sure this
+ -- is a thin pointer to save space.
+ --
+ -- Dealloc_Traceback is also for blocks that are still allocated to
+ -- point to the previous block in the list. This saves space in this
+ -- header, and make manipulation of the lists of allocated pointers
+ -- faster.
+
+ Next : System.Address;
+ -- Point to the next block of the same type (either allocated or
+ -- logically freed) in memory. This points to the beginning of the user
+ -- data, and does not include the header of that block.
+ end record;
+
+ function Header_Of (Address : System.Address)
+ return Allocation_Header_Access;
+ pragma Inline (Header_Of);
+ -- Return the header corresponding to a previously allocated address
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Traceback_Ptr_Or_Address, System.Address);
+ function To_Address is new Ada.Unchecked_Conversion
+ (System.Address, Traceback_Ptr_Or_Address);
+ function To_Traceback is new Ada.Unchecked_Conversion
+ (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);
+ function To_Traceback is new Ada.Unchecked_Conversion
+ (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
+
+ Minimum_Allocation : constant Storage_Count :=
+ Default_Alignment *
+ (Allocation_Header'Size /
+ System.Storage_Unit /
+ Default_Alignment) +
+ Default_Alignment;
+ -- Extra bytes to allocate to store the header. The header needs to be
+ -- correctly aligned as well, so we have to allocate multiples of the
+ -- alignment.
+
+ -----------------------
+ -- Allocations table --
+ -----------------------
+
+ -- This table is indexed on addresses modulo Minimum_Allocation, and
+ -- for each index it indicates whether that memory block is valid.
+ -- Its behavior is similar to GNAT.Table, except that we need to pack
+ -- the table to save space, so we cannot reuse GNAT.Table as is.
+
+ -- This table is the reason why all alignments have to be forced to a
+ -- common value (Default_Alignment), so that this table can be
+ -- kept to a reasonnable size.
+
+ type Byte is mod 2 ** System.Storage_Unit;
+
+ Big_Table_Size : constant Storage_Offset :=
+ (Storage_Offset'Last - 1) / Default_Alignment;
+ type Big_Table is array (0 .. Big_Table_Size) of Byte;
+ -- A simple, flat-array type used to access memory bytes (see the comment
+ -- for Valid_Blocks below).
+ --
+ -- It would be cleaner to represent this as a packed array of Boolean.
+ -- However, we cannot specify pragma Pack for such an array, since the
+ -- total size on a 64 bit machine would be too big (> Integer'Last).
+ --
+ -- Given an address, we know if it is under control of the debug pool if
+ -- the byte at index:
+ -- ((Address - Edata'Address) / Default_Alignment)
+ -- / Storage_unit
+ -- has the bit
+ -- ((Address - Edata'Address) / Default_Alignment)
+ -- mod Storage_Unit
+ -- set to 1.
+ --
+ -- See the subprograms Is_Valid and Set_Valid for proper manipulation of
+ -- this array.
+
+ type Table_Ptr is access Big_Table;
+ function To_Pointer is new Ada.Unchecked_Conversion
+ (System.Address, Table_Ptr);
+
+ Valid_Blocks : Table_Ptr := null;
+ Valid_Blocks_Size : Storage_Offset := 0;
+ -- These two variables represents a mapping of the currently allocated
+ -- memory. Every time the pool works on an address, we first check that the
+ -- index Address / Default_Alignment is True. If not, this means that this
+ -- address is not under control of the debug pool, and thus this is
+ -- probably an invalid memory access (it could also be a general access
+ -- type).
+ --
+ -- Note that in fact we never allocate the full size of Big_Table, only a
+ -- slice big enough to manage the currently allocated memory.
+
+ Edata : System.Address := System.Null_Address;
+ -- Address in memory that matches the index 0 in Valid_Blocks. It is named
+ -- after the symbol _edata, which, on most systems, indicate the lowest
+ -- possible address returned by malloc (). Unfortunately, this symbol
+ -- doesn't exist on windows, so we cannot use it instead of this variable.
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Find_Or_Create_Traceback
+ (Pool : Debug_Pool;
+ Kind : Traceback_Kind;
+ Size : Storage_Count;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ return Traceback_Htable_Elem_Ptr;
+ -- Return an element matching the current traceback (omitting the frames
+ -- that are in the current package). If this traceback already existed in
+ -- the htable, a pointer to this is returned to spare memory. Null is
+ -- returned if the pool is set not to store tracebacks. If the traceback
+ -- already existed in the table, the count is incremented so that
+ -- Dump_Tracebacks returns useful results.
+ -- All addresses up to, and including, an address between
+ -- Ignored_Frame_Start .. Ignored_Frame_End are ignored.
+
+ procedure Put_Line
+ (Depth : Natural;
+ Traceback : Tracebacks_Array_Access;
+ Ignored_Frame_Start : System.Address := System.Null_Address;
+ Ignored_Frame_End : System.Address := System.Null_Address);
+ -- Print Traceback to Standard_Output. If Traceback is null, print the
+ -- call_chain at the current location, up to Depth levels, ignoring all
+ -- addresses up to the first one in the range
+ -- Ignored_Frame_Start .. Ignored_Frame_End
+
+ function Is_Valid (Storage : System.Address) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Return True if Storage is an address that the debug pool has under its
+ -- control.
+
+ procedure Set_Valid (Storage : System.Address; Value : Boolean);
+ pragma Inline (Set_Valid);
+ -- Mark the address Storage as being under control of the memory pool (if
+ -- Value is True), or not (if Value is False). This procedure will
+ -- reallocate the table Valid_Blocks as needed.
+
+ procedure Set_Dead_Beef
+ (Storage_Address : System.Address;
+ Size_In_Storage_Elements : Storage_Count);
+ -- Set the contents of the memory block pointed to by Storage_Address to
+ -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
+ -- of the length of this pattern, the last instance may be partial.
+
+ procedure Free_Physically (Pool : in out Debug_Pool);
+ -- Start to physically release some memory to the system, until the amount
+ -- of logically (but not physically) freed memory is lower than the
+ -- expected amount in Pool.
+
+ procedure Allocate_End;
+ procedure Deallocate_End;
+ procedure Dereference_End;
+ -- These procedures are used as markers when computing the stacktraces,
+ -- so that addresses in the debug pool itself are not reported to the user.
+
+ Code_Address_For_Allocate_End : System.Address;
+ Code_Address_For_Deallocate_End : System.Address;
+ Code_Address_For_Dereference_End : System.Address;
+ -- Taking the address of the above procedures will not work on some
+ -- architectures (HPUX and VMS for instance). Thus we do the same thing
+ -- that is done in a-except.adb, and get the address of labels instead
+
+ procedure Skip_Levels
+ (Depth : Natural;
+ Trace : Tracebacks_Array;
+ Start : out Natural;
+ Len : in out Natural;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address);
+ -- Set Start .. Len to the range of values from Trace that should be output
+ -- to the user. This range of values exludes any address prior to the first
+ -- one in Ignored_Frame_Start .. Ignored_Frame_End (basically addresses
+ -- internal to this package). Depth is the number of levels that the user
+ -- is interested in.
+
+ ---------------
+ -- Header_Of --
+ ---------------
+
+ function Header_Of (Address : System.Address)
+ return Allocation_Header_Access
+ is
+ function Convert is new Ada.Unchecked_Conversion
+ (System.Address, Allocation_Header_Access);
+ begin
+ return Convert (Address - Minimum_Allocation);
+ end Header_Of;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next
+ (E : Traceback_Htable_Elem_Ptr;
+ Next : Traceback_Htable_Elem_Ptr)
+ is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next
+ (E : Traceback_Htable_Elem_Ptr)
+ return Traceback_Htable_Elem_Ptr
+ is
+ begin
+ return E.Next;
+ end Next;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
+ use Ada.Exceptions.Traceback;
+ begin
+ return K1.all = K2.all;
+ end Equal;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key
+ (E : Traceback_Htable_Elem_Ptr)
+ return Tracebacks_Array_Access
+ is
+ begin
+ return E.Traceback;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (T : Tracebacks_Array_Access) return Header is
+ Result : Integer_Address := 0;
+ begin
+ for X in T'Range loop
+ Result := Result + To_Integer (PC_For (T (X)));
+ end loop;
+ return Header (1 + Result mod Integer_Address (Header'Last));
+ end Hash;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line
+ (Depth : Natural;
+ Traceback : Tracebacks_Array_Access;
+ Ignored_Frame_Start : System.Address := System.Null_Address;
+ Ignored_Frame_End : System.Address := System.Null_Address)
+ is
+ procedure Print (Tr : Tracebacks_Array);
+ -- Print the traceback to standard_output
+
+ -----------
+ -- Print --
+ -----------
+
+ procedure Print (Tr : Tracebacks_Array) is
+ begin
+ for J in Tr'Range loop
+ Put ("0x" & Address_Image (PC_For (Tr (J))) & ' ');
+ end loop;
+ Put (ASCII.LF);
+ end Print;
+
+ -- Start of processing for Put_Line
+
+ begin
+ if Traceback = null then
+ declare
+ Tr : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
+ Start, Len : Natural;
+
+ begin
+ Call_Chain (Tr, Len);
+ Skip_Levels (Depth, Tr, Start, Len,
+ Ignored_Frame_Start, Ignored_Frame_End);
+ Print (Tr (Start .. Len));
+ end;
+
+ else
+ Print (Traceback.all);
+ end if;
+ end Put_Line;
+
+ -----------------
+ -- Skip_Levels --
+ -----------------
+
+ procedure Skip_Levels
+ (Depth : Natural;
+ Trace : Tracebacks_Array;
+ Start : out Natural;
+ Len : in out Natural;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ is
+ begin
+ Start := Trace'First;
+
+ while Start <= Len
+ and then (PC_For (Trace (Start)) < Ignored_Frame_Start
+ or else PC_For (Trace (Start)) > Ignored_Frame_End)
+ loop
+ Start := Start + 1;
+ end loop;
+
+ Start := Start + 1;
+
+ -- Just in case: make sure we have a traceback even if Ignore_Till
+ -- wasn't found.
- package Table is new GNAT.HTable.Simple_HTable (
- Header_Num => Header,
- Element => State,
- No_Element => Not_Allocated,
- Key => Address,
- Hash => H,
- Equal => "=");
+ if Start > Len then
+ Start := 1;
+ end if;
+
+ if Len - Start + 1 > Depth then
+ Len := Depth + Start - 1;
+ end if;
+ end Skip_Levels;
+
+ ------------------------------
+ -- Find_Or_Create_Traceback --
+ ------------------------------
+
+ function Find_Or_Create_Traceback
+ (Pool : Debug_Pool;
+ Kind : Traceback_Kind;
+ Size : Storage_Count;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ return Traceback_Htable_Elem_Ptr
+ is
+ begin
+ if Pool.Stack_Trace_Depth = 0 then
+ return null;
+ end if;
+
+ declare
+ Trace : aliased Tracebacks_Array
+ (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
+ Len, Start : Natural;
+ Elem : Traceback_Htable_Elem_Ptr;
+
+ begin
+ Call_Chain (Trace, Len);
+ Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
+ Ignored_Frame_Start, Ignored_Frame_End);
+
+ -- Check if the traceback is already in the table.
+
+ Elem :=
+ Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
+
+ -- If not, insert it
+
+ if Elem = null then
+ Elem := new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'(Trace (Start .. Len)),
+ Count => 1,
+ Kind => Kind,
+ Total => Byte_Count (Size),
+ Next => null);
+ Backtrace_Htable.Set (Elem);
+
+ else
+ Elem.Count := Elem.Count + 1;
+ Elem.Total := Elem.Total + Byte_Count (Size);
+ end if;
+
+ return Elem;
+ end;
+ end Find_Or_Create_Traceback;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Storage : System.Address) return Boolean is
+ Offset : constant Storage_Offset :=
+ (Storage - Edata) / Default_Alignment;
+
+ Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit);
+
+ begin
+ return (Storage mod Default_Alignment) = 0
+ and then Offset >= 0
+ and then Offset < Valid_Blocks_Size * Storage_Unit
+ and then (Valid_Blocks (Offset / Storage_Unit) and Bit) /= 0;
+ end Is_Valid;
+
+ ---------------
+ -- Set_Valid --
+ ---------------
+
+ procedure Set_Valid (Storage : System.Address; Value : Boolean) is
+ Offset : Storage_Offset;
+ Bit : Byte;
+ Bytes : Storage_Offset;
+ Tmp : constant Table_Ptr := Valid_Blocks;
+
+ Edata_Align : constant Storage_Offset :=
+ Default_Alignment * Storage_Unit;
+
+ procedure Memset (A : Address; C : Integer; N : size_t);
+ pragma Import (C, Memset, "memset");
+
+ procedure Memmove (Dest, Src : Address; N : size_t);
+ pragma Import (C, Memmove, "memmove");
+
+ begin
+ -- Allocate, or reallocate, the valid blocks table as needed. We start
+ -- with a size big enough to handle Initial_Memory_Size bytes of memory,
+ -- to avoid too many reallocations. The table will typically be around
+ -- 16Mb in that case, which is still small enough.
+
+ if Valid_Blocks_Size = 0 then
+ Valid_Blocks_Size := (Initial_Memory_Size / Default_Alignment)
+ / Storage_Unit;
+ Valid_Blocks := To_Pointer (Alloc (size_t (Valid_Blocks_Size)));
+ Edata := Storage;
+
+ -- Reset the memory using memset, which is much faster than the
+ -- standard Ada code with "when others"
+
+ Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size));
+ end if;
+
+ -- First case : the new address is outside of the current scope of
+ -- Valid_Blocks, before the current start address. We need to reallocate
+ -- the table accordingly. This should be a rare occurence, since in most
+ -- cases, the first allocation will also have the lowest address. But
+ -- there is no garantee...
+
+ if Storage < Edata then
+
+ -- The difference between the new Edata and the current one must be
+ -- a multiple of Default_Alignment * Storage_Unit, so that the bit
+ -- representing an address in Valid_Blocks are kept the same.
+
+ Offset := ((Edata - Storage) / Edata_Align + 1) * Edata_Align;
+ Offset := Offset / Default_Alignment;
+ Bytes := Offset / Storage_Unit;
+ Valid_Blocks :=
+ To_Pointer (Alloc (Size => size_t (Valid_Blocks_Size + Bytes)));
+ Memmove (Dest => Valid_Blocks.all'Address + Bytes,
+ Src => Tmp.all'Address,
+ N => size_t (Valid_Blocks_Size));
+ Memset (A => Valid_Blocks.all'Address,
+ C => 0,
+ N => size_t (Bytes));
+ Free (Tmp.all'Address);
+ Valid_Blocks_Size := Valid_Blocks_Size + Bytes;
+
+ -- Take into the account the new start address
+ Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align;
+ end if;
+
+ -- Second case : the new address is outside of the current scope of
+ -- Valid_Blocks, so we have to grow the table as appropriate
+
+ Offset := (Storage - Edata) / Default_Alignment;
+
+ if Offset >= Valid_Blocks_Size * System.Storage_Unit then
+ Bytes := Valid_Blocks_Size;
+ loop
+ Bytes := 2 * Bytes;
+ exit when Offset <= Bytes * System.Storage_Unit;
+ end loop;
+
+ Valid_Blocks := To_Pointer
+ (Realloc (Ptr => Valid_Blocks.all'Address,
+ Size => size_t (Bytes)));
+ Memset
+ (Valid_Blocks.all'Address + Valid_Blocks_Size,
+ 0,
+ size_t (Bytes - Valid_Blocks_Size));
+ Valid_Blocks_Size := Bytes;
+ end if;
+
+ Bit := 2 ** Natural (Offset mod System.Storage_Unit);
+ Bytes := Offset / Storage_Unit;
+
+ -- Then set the value as valid
+
+ if Value then
+ Valid_Blocks (Bytes) := Valid_Blocks (Bytes) or Bit;
+ else
+ Valid_Blocks (Bytes) := Valid_Blocks (Bytes) and (not Bit);
+ end if;
+ end Set_Valid;
--------------
-- Allocate --
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment);
+ -- Ignored, we always force 'Default_Alignment
+
+ type Local_Storage_Array is new Storage_Array
+ (1 .. Size_In_Storage_Elements + Minimum_Allocation);
+ for Local_Storage_Array'Alignment use Standard'Maximum_Alignment;
+ -- For performance reasons, make sure the alignment is maximized.
+
+ type Ptr is access Local_Storage_Array;
+ -- On some systems, we might want to physically protect pages
+ -- against writing when they have been freed (of course, this is
+ -- expensive in terms of wasted memory). To do that, all we should
+ -- have to do it to set the size of this array to the page size.
+ -- See mprotect().
+
+ P : Ptr;
+
+ Current : Byte_Count;
+ Trace : Traceback_Htable_Elem_Ptr;
begin
- Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
+ <<Allocate_Label>>
+ Lock_Task.all;
- if Storage_Address = Null_Address then
- raise Storage_Error;
- else
- Table.Set (Storage_Address, Allocated);
- Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
+ -- If necessary, start physically releasing memory. The reason this is
+ -- done here, although Pool.Logically_Deallocated has not changed above,
+ -- is so that we do this only after a series of deallocations (e.g a
+ -- loop that deallocates a big array). If we were doing that in
+ -- Deallocate, we might be physically freeing memory several times
+ -- during the loop, which is expensive.
- if Pool.Allocated - Pool.Deallocated > Pool.High_Water then
- Pool.High_Water := Pool.Allocated - Pool.Deallocated;
- end if;
+ if Pool.Logically_Deallocated >
+ Byte_Count (Pool.Maximum_Logically_Freed_Memory)
+ then
+ Free_Physically (Pool);
end if;
+
+ -- Use standard (ie through malloc) allocations. This automatically
+ -- raises Storage_Error if needed. We also try once more to physically
+ -- release memory, so that even marked blocks, in the advanced scanning,
+ -- are freed.
+
+ begin
+ P := new Local_Storage_Array;
+
+ exception
+ when Storage_Error =>
+ Free_Physically (Pool);
+ P := new Local_Storage_Array;
+ end;
+
+ Storage_Address := P.all'Address + Minimum_Allocation;
+
+ Trace := Find_Or_Create_Traceback
+ (Pool, Alloc, Size_In_Storage_Elements,
+ Allocate_Label'Address, Code_Address_For_Allocate_End);
+
+ pragma Warnings (Off);
+ -- Turn warning on alignment for convert call off. We know that in
+ -- fact this conversion is safe since P itself is always aligned on
+ -- Default_Alignment.
+
+ Header_Of (Storage_Address).all :=
+ (Alloc_Traceback => Trace,
+ Dealloc_Traceback => To_Traceback (null),
+ Next => Pool.First_Used_Block,
+ Block_Size => Size_In_Storage_Elements);
+
+ pragma Warnings (On);
+
+ -- Link this block in the list of used blocks. This will be used to list
+ -- memory leaks in Print_Info, and for the advanced schemes of
+ -- Physical_Free, where we want to traverse all allocated blocks and
+ -- search for possible references.
+
+ -- We insert in front, since most likely we'll be freeing the most
+ -- recently allocated blocks first (the older one might stay allocated
+ -- for the whole life of the application).
+
+ if Pool.First_Used_Block /= System.Null_Address then
+ Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+ To_Address (Storage_Address);
+ end if;
+
+ Pool.First_Used_Block := Storage_Address;
+
+ -- Mark the new address as valid
+
+ Set_Valid (Storage_Address, True);
+
+ -- Update internal data
+
+ Pool.Allocated :=
+ Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
+
+ Current := Pool.Allocated -
+ Pool.Logically_Deallocated -
+ Pool.Physically_Deallocated;
+
+ if Current > Pool.High_Water then
+ Pool.High_Water := Current;
+ end if;
+
+ Unlock_Task.all;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
end Allocate;
+ ------------------
+ -- Allocate_End --
+ ------------------
+
+ -- DO NOT MOVE, this must be right after Allocate. This is similar to
+ -- what is done in a-except, so that we can hide the traceback frames
+ -- internal to this package
+
+ procedure Allocate_End is
+ begin
+ <<Allocate_End_Label>>
+ Code_Address_For_Allocate_End := Allocate_End_Label'Address;
+ end Allocate_End;
+
+ -------------------
+ -- Set_Dead_Beef --
+ -------------------
+
+ procedure Set_Dead_Beef
+ (Storage_Address : System.Address;
+ Size_In_Storage_Elements : Storage_Count)
+ is
+ Dead_Bytes : constant := 4;
+
+ type Data is mod 2 ** (Dead_Bytes * 8);
+ for Data'Size use Dead_Bytes * 8;
+
+ Dead : constant Data := 16#DEAD_BEEF#;
+
+ type Dead_Memory is array
+ (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
+ type Mem_Ptr is access Dead_Memory;
+
+ type Byte is mod 2 ** 8;
+ for Byte'Size use 8;
+
+ type Dead_Memory_Bytes is array (0 .. 2) of Byte;
+ type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
+
+ function From_Ptr is new Ada.Unchecked_Conversion
+ (System.Address, Mem_Ptr);
+
+ function From_Ptr is new Ada.Unchecked_Conversion
+ (System.Address, Dead_Memory_Bytes_Ptr);
+
+ M : constant Mem_Ptr := From_Ptr (Storage_Address);
+ M2 : Dead_Memory_Bytes_Ptr;
+ Modulo : constant Storage_Count :=
+ Size_In_Storage_Elements mod Dead_Bytes;
+ begin
+ M.all := (others => Dead);
+
+ -- Any bytes left (up to three of them)
+
+ if Modulo /= 0 then
+ M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
+
+ M2 (0) := 16#DE#;
+ if Modulo >= 2 then
+ M2 (1) := 16#AD#;
+
+ if Modulo >= 3 then
+ M2 (2) := 16#BE#;
+ end if;
+ end if;
+ end if;
+ end Set_Dead_Beef;
+
+ ---------------------
+ -- Free_Physically --
+ ---------------------
+
+ procedure Free_Physically (Pool : in out Debug_Pool) is
+ type Byte is mod 256;
+ type Byte_Access is access Byte;
+
+ function To_Byte is new Ada.Unchecked_Conversion
+ (System.Address, Byte_Access);
+
+ type Address_Access is access System.Address;
+
+ function To_Address_Access is new Ada.Unchecked_Conversion
+ (System.Address, Address_Access);
+
+ In_Use_Mark : constant Byte := 16#D#;
+ Free_Mark : constant Byte := 16#F#;
+
+ Total_Freed : Storage_Count := 0;
+
+ procedure Reset_Marks;
+ -- Unmark all the logically freed blocks, so that they are considered
+ -- for physical deallocation
+
+ procedure Mark
+ (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
+ -- Mark the user data block starting at A. For a block of size zero,
+ -- nothing is done. For a block with a different size, the first byte
+ -- is set to either "D" (in use) or "F" (free).
+
+ function Marked (A : System.Address) return Boolean;
+ -- Return true if the user data block starting at A might be in use
+ -- somewhere else
+
+ procedure Mark_Blocks;
+ -- Traverse all allocated blocks, and search for possible references
+ -- to logically freed blocks. Mark them appropriately
+
+ procedure Free_Blocks (Ignore_Marks : Boolean);
+ -- Physically release blocks. Only the blocks that haven't been marked
+ -- will be released, unless Ignore_Marks is true.
+
+ -----------------
+ -- Free_Blocks --
+ -----------------
+
+ procedure Free_Blocks (Ignore_Marks : Boolean) is
+ Header : Allocation_Header_Access;
+ Tmp : System.Address := Pool.First_Free_Block;
+ Next : System.Address;
+ Previous : System.Address := System.Null_Address;
+
+ begin
+ while Tmp /= System.Null_Address
+ and then Total_Freed < Pool.Minimum_To_Free
+ loop
+ Header := Header_Of (Tmp);
+
+ -- If we know, or at least assume, the block is no longer
+ -- reference anywhere, we can free it physically.
+
+ if Ignore_Marks or else not Marked (Tmp) then
+
+ declare
+ pragma Suppress (All_Checks);
+ -- Suppress the checks on this section. If they are overflow
+ -- errors, it isn't critical, and we'd rather avoid a
+ -- Constraint_Error in that case.
+ begin
+ -- Note that block_size < zero for freed blocks
+
+ Pool.Physically_Deallocated :=
+ Pool.Physically_Deallocated -
+ Byte_Count (Header.Block_Size);
+
+ Pool.Logically_Deallocated :=
+ Pool.Logically_Deallocated +
+ Byte_Count (Header.Block_Size);
+
+ Total_Freed := Total_Freed - Header.Block_Size;
+ end;
+
+ Next := Header.Next;
+ System.Memory.Free (Header.all'Address);
+ Set_Valid (Tmp, False);
+
+ -- Remove this block from the list.
+
+ if Previous = System.Null_Address then
+ Pool.First_Free_Block := Next;
+ else
+ Header_Of (Previous).Next := Next;
+ end if;
+
+ Tmp := Next;
+
+ else
+ Previous := Tmp;
+ Tmp := Header.Next;
+ end if;
+ end loop;
+ end Free_Blocks;
+
+ ----------
+ -- Mark --
+ ----------
+
+ procedure Mark
+ (H : Allocation_Header_Access;
+ A : System.Address;
+ In_Use : Boolean)
+ is
+ begin
+ if H.Block_Size /= 0 then
+ if In_Use then
+ To_Byte (A).all := In_Use_Mark;
+ else
+ To_Byte (A).all := Free_Mark;
+ end if;
+ end if;
+ end Mark;
+
+ -----------------
+ -- Mark_Blocks --
+ -----------------
+
+ procedure Mark_Blocks is
+ Tmp : System.Address := Pool.First_Used_Block;
+ Previous : System.Address;
+ Last : System.Address;
+ Pointed : System.Address;
+ Header : Allocation_Header_Access;
+
+ begin
+ -- For each allocated block, check its contents. Things that look
+ -- like a possible address are used to mark the blocks so that we try
+ -- and keep them, for better detection in case of invalid access.
+ -- This mechanism is far from being fool-proof: it doesn't check the
+ -- stacks of the threads, doesn't check possible memory allocated not
+ -- under control of this debug pool. But it should allow us to catch
+ -- more cases.
+
+ while Tmp /= System.Null_Address loop
+ Previous := Tmp;
+ Last := Tmp + Header_Of (Tmp).Block_Size;
+ while Previous < Last loop
+ -- ??? Should we move byte-per-byte, or consider that addresses
+ -- are always aligned on 4-bytes boundaries ? Let's use the
+ -- fastest for now.
+
+ Pointed := To_Address_Access (Previous).all;
+ if Is_Valid (Pointed) then
+ Header := Header_Of (Pointed);
+
+ -- Do not even attempt to mark blocks in use. That would
+ -- screw up the whole application, of course.
+ if Header.Block_Size < 0 then
+ Mark (Header, Pointed, In_Use => True);
+ end if;
+ end if;
+
+ Previous := Previous + System.Address'Size;
+ end loop;
+
+ Tmp := Header_Of (Tmp).Next;
+ end loop;
+ end Mark_Blocks;
+
+ ------------
+ -- Marked --
+ ------------
+
+ function Marked (A : System.Address) return Boolean is
+ begin
+ return To_Byte (A).all = In_Use_Mark;
+ end Marked;
+
+ -----------------
+ -- Reset_Marks --
+ -----------------
+
+ procedure Reset_Marks is
+ Current : System.Address := Pool.First_Free_Block;
+ Header : Allocation_Header_Access;
+
+ begin
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+ Mark (Header, Current, False);
+ Current := Header.Next;
+ end loop;
+ end Reset_Marks;
+
+ -- Start of processing for Free_Physically
+
+ begin
+ Lock_Task.all;
+
+ if Pool.Advanced_Scanning then
+ Reset_Marks; -- Reset the mark for each freed block
+ Mark_Blocks;
+ end if;
+
+ Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
+
+ -- The contract is that we need to free at least Minimum_To_Free bytes,
+ -- even if this means freeing marked blocks in the advanced scheme
+
+ if Total_Freed < Pool.Minimum_To_Free
+ and then Pool.Advanced_Scanning
+ then
+ Pool.Marked_Blocks_Deallocated := True;
+ Free_Blocks (Ignore_Marks => True);
+ end if;
+
+ Unlock_Task.all;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
+ end Free_Physically;
+
----------------
-- Deallocate --
----------------
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment);
+
+ Header : constant Allocation_Header_Access :=
+ Header_Of (Storage_Address);
+ Valid : Boolean;
+ Previous : System.Address;
+
+ begin
+ <<Deallocate_Label>>
+ Lock_Task.all;
+ Valid := Is_Valid (Storage_Address);
+
+ if not Valid then
+ Unlock_Task.all;
+ if Pool.Raise_Exceptions then
+ raise Freeing_Not_Allocated_Storage;
+ else
+ Put ("Freeing not allocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ end if;
- procedure Free (Address : System.Address; Siz : Storage_Count);
- -- Fake free, that resets all the deallocated storage to "DEADBEEF"
+ elsif Header.Block_Size < 0 then
+ Unlock_Task.all;
+ if Pool.Raise_Exceptions then
+ raise Freeing_Deallocated_Storage;
+ else
+ Put ("Freeing already deallocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ Put (" Memory already deallocated at ");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
- procedure Free (Address : System.Address; Siz : Storage_Count) is
- DB1 : constant Integer := 16#DEAD#;
- DB2 : constant Integer := 16#BEEF#;
+ else
+ -- Remove this block from the list of used blocks.
- type Dead_Memory is array (1 .. Siz / 4) of Integer;
- type Mem_Ptr is access all Dead_Memory;
+ Previous :=
+ To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
- function From_Ptr is
- new Unchecked_Conversion (System.Address, Mem_Ptr);
+ if Previous = System.Null_Address then
+ Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
- J : Storage_Offset;
+ if Pool.First_Used_Block /= System.Null_Address then
+ Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+ To_Traceback (null);
+ end if;
- begin
- J := Dead_Memory'First;
- while J < Dead_Memory'Last loop
- From_Ptr (Address) (J) := DB1;
- From_Ptr (Address) (J + 1) := DB2;
- J := J + 2;
- end loop;
+ else
+ Header_Of (Previous).Next := Header_Of (Storage_Address).Next;
- if J = Dead_Memory'Last then
- From_Ptr (Address) (J) := DB1;
+ if Header_Of (Storage_Address).Next /= System.Null_Address then
+ Header_Of
+ (Header_Of (Storage_Address).Next).Dealloc_Traceback :=
+ To_Address (Previous);
+ end if;
end if;
- end Free;
- S : State := Table.Get (Storage_Address);
+ -- Update the header
- -- Start of processing for Deallocate
+ Header.all :=
+ (Alloc_Traceback => Header.Alloc_Traceback,
+ Dealloc_Traceback => To_Traceback
+ (Find_Or_Create_Traceback
+ (Pool, Dealloc,
+ Size_In_Storage_Elements,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End)),
+ Next => System.Null_Address,
+ Block_Size => -Size_In_Storage_Elements);
- begin
- case S is
- when Not_Allocated =>
- raise Freeing_Not_Allocated_Storage;
+ if Pool.Reset_Content_On_Free then
+ Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
+ end if;
- when Deallocated =>
- raise Freeing_Deallocated_Storage;
+ Pool.Logically_Deallocated :=
+ Pool.Logically_Deallocated +
+ Byte_Count (Size_In_Storage_Elements);
- when Allocated =>
- Free (Storage_Address, Size_In_Storage_Elements);
- Table.Set (Storage_Address, Deallocated);
- Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
- end case;
+ -- Link this free block with the others (at the end of the list, so
+ -- that we can start releasing the older blocks first later on).
+
+ if Pool.First_Free_Block = System.Null_Address then
+ Pool.First_Free_Block := Storage_Address;
+ Pool.Last_Free_Block := Storage_Address;
+
+ else
+ Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
+ Pool.Last_Free_Block := Storage_Address;
+ end if;
+
+ -- Do not physically release the memory here, but in Alloc.
+ -- See comment there for details.
+
+ Unlock_Task.all;
+ end if;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
end Deallocate;
+ --------------------
+ -- Deallocate_End --
+ --------------------
+
+ -- DO NOT MOVE, this must be right after Deallocate
+ -- See Allocate_End
+
+ procedure Deallocate_End is
+ begin
+ <<Deallocate_End_Label>>
+ Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
+ end Deallocate_End;
+
-----------------
-- Dereference --
-----------------
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Pool);
- pragma Warnings (Off, Size_In_Storage_Elements);
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment, Size_In_Storage_Elements);
- S : State := Table.Get (Storage_Address);
- Max_Dim : constant := 3;
- Dim : Integer := 1;
+ Valid : constant Boolean := Is_Valid (Storage_Address);
+ Header : Allocation_Header_Access;
begin
+ -- Locking policy: we do not do any locking in this procedure. The
+ -- tables are only read, not written to, and although a problem might
+ -- appear if someone else is modifying the tables at the same time, this
+ -- race condition is not intended to be detected by this storage_pool (a
+ -- now invalid pointer would appear as valid). Instead, we prefer
+ -- optimum performance for dereferences.
- -- If this is not a known address, maybe it is because is is an
- -- unconstained array. In which case, the bounds have used the
- -- 2 first words (per dimension) of the allocated spot.
+ <<Dereference_Label>>
- while S = Not_Allocated and then Dim <= Max_Dim loop
- S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
- Dim := Dim + 1;
- end loop;
-
- case S is
- when Not_Allocated =>
+ if not Valid then
+ if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
+ else
+ Put ("Accessing not allocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Dereference_Label'Address,
+ Code_Address_For_Dereference_End);
+ end if;
- when Deallocated =>
- raise Accessing_Deallocated_Storage;
+ else
+ Header := Header_Of (Storage_Address);
- when Allocated =>
- null;
- end case;
+ if Header.Block_Size < 0 then
+ if Pool.Raise_Exceptions then
+ raise Accessing_Deallocated_Storage;
+ else
+ Put ("Accessing deallocated storage, at ");
+ Put_Line
+ (Pool.Stack_Trace_Depth, null,
+ Dereference_Label'Address,
+ Code_Address_For_Dereference_End);
+ Put (" First deallocation at ");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
+ end if;
+ end if;
end Dereference;
- -------
- -- H --
- -------
+ ---------------------
+ -- Dereference_End --
+ ---------------------
- function H (F : Address) return Header is
+ -- DO NOT MOVE: this must be right after Dereference
+ -- See Allocate_End
+
+ procedure Dereference_End is
begin
- return
- Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
- end H;
+ <<Dereference_End_Label>>
+ Code_Address_For_Dereference_End := Dereference_End_Label'Address;
+ end Dereference_End;
----------------
-- Print_Info --
----------------
- procedure Print_Info (Pool : Debug_Pool) is
+ procedure Print_Info
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False)
+ is
use System.Storage_Elements;
+ package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
+ (Header_Num => Header,
+ Element => Traceback_Htable_Elem,
+ Elmt_Ptr => Traceback_Htable_Elem_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Tracebacks_Array_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- This needs a comment ??? probably some of the ones below do too???
+
+ Data : Traceback_Htable_Elem_Ptr;
+ Elem : Traceback_Htable_Elem_Ptr;
+ Current : System.Address;
+ Header : Allocation_Header_Access;
+ K : Traceback_Kind;
+
begin
- Put_Line ("Debug Pool info:");
- Put_Line (" Total allocated bytes : "
- & Storage_Offset'Image (Pool.Allocated));
+ Put_Line
+ ("Total allocated bytes : " &
+ Byte_Count'Image (Pool.Allocated));
+
+ Put_Line
+ ("Total logically deallocated bytes : " &
+ Byte_Count'Image (Pool.Logically_Deallocated));
+
+ Put_Line
+ ("Total physically deallocated bytes : " &
+ Byte_Count'Image (Pool.Physically_Deallocated));
- Put_Line (" Total deallocated bytes : "
- & Storage_Offset'Image (Pool.Deallocated));
+ if Pool.Marked_Blocks_Deallocated then
+ Put_Line ("Marked blocks were physically deallocated. This is");
+ Put_Line ("potentially dangereous, and you might want to run");
+ Put_Line ("again with a lower value of Minimum_To_Free");
+ end if;
+
+ Put_Line
+ ("Current Water Mark: " &
+ Byte_Count'Image
+ (Pool.Allocated - Pool.Logically_Deallocated
+ - Pool.Physically_Deallocated));
- Put_Line (" Current Water Mark: "
- & Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
+ Put_Line
+ ("High Water Mark: " &
+ Byte_Count'Image (Pool.High_Water));
- Put_Line (" High Water Mark: "
- & Storage_Offset'Image (Pool.High_Water));
Put_Line ("");
+
+ if Display_Slots then
+ Data := Backtrace_Htable.Get_First;
+ while Data /= null loop
+ if Data.Kind in Alloc .. Dealloc then
+ Elem :=
+ new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'(Data.Traceback.all),
+ Count => Data.Count,
+ Kind => Data.Kind,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
+
+ if Cumulate then
+ if Data.Kind = Alloc then
+ K := Indirect_Alloc;
+ else
+ K := Indirect_Dealloc;
+ end if;
+
+ -- Propagate the direct call to all its parents
+
+ for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
+ Elem := Backtrace_Htable_Cumulate.Get
+ (Data.Traceback
+ (T .. Data.Traceback'Last)'Unrestricted_Access);
+
+ -- If not, insert it
+
+ if Elem = null then
+ Elem := new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'
+ (Data.Traceback (T .. Data.Traceback'Last)),
+ Count => Data.Count,
+ Kind => K,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
+
+ -- Properly take into account that the subprograms
+ -- indirectly called might be doing either allocations
+ -- or deallocations. This needs to be reflected in the
+ -- counts.
+
+ else
+ Elem.Count := Elem.Count + Data.Count;
+
+ if K = Elem.Kind then
+ Elem.Total := Elem.Total + Data.Total;
+
+ elsif Elem.Total > Data.Total then
+ Elem.Total := Elem.Total - Data.Total;
+
+ else
+ Elem.Kind := K;
+ Elem.Total := Data.Total - Elem.Total;
+ end if;
+ end if;
+ end loop;
+ end if;
+
+ Data := Backtrace_Htable.Get_Next;
+ end if;
+ end loop;
+
+ Put_Line ("List of allocations/deallocations: ");
+
+ Data := Backtrace_Htable_Cumulate.Get_First;
+ while Data /= null loop
+ case Data.Kind is
+ when Alloc => Put ("alloc (count:");
+ when Indirect_Alloc => Put ("indirect alloc (count:");
+ when Dealloc => Put ("free (count:");
+ when Indirect_Dealloc => Put ("indirect free (count:");
+ end case;
+
+ Put (Natural'Image (Data.Count) & ", total:" &
+ Byte_Count'Image (Data.Total) & ") ");
+
+ for T in Data.Traceback'Range loop
+ Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
+ end loop;
+
+ Put_Line ("");
+
+ Data := Backtrace_Htable_Cumulate.Get_Next;
+ end loop;
+
+ Backtrace_Htable_Cumulate.Reset;
+ end if;
+
+ if Display_Leaks then
+ Put_Line ("");
+ Put_Line ("List of not deallocated blocks:");
+
+ -- Do not try to group the blocks with the same stack traces
+ -- together. This is done by the gnatmem output.
+
+ Current := Pool.First_Used_Block;
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+
+ Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
+
+ for T in Header.Alloc_Traceback.Traceback'Range loop
+ Put ("0x" & Address_Image
+ (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
+ end loop;
+
+ Put_Line ("");
+ Current := Header.Next;
+ end loop;
+ end if;
end Print_Info;
------------------
------------------
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
- pragma Warnings (Off, Pool);
+ pragma Unreferenced (Pool);
begin
return Storage_Count'Last;
end Storage_Size;
+ ---------------
+ -- Configure --
+ ---------------
+
+ procedure Configure
+ (Pool : in out Debug_Pool;
+ Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
+ Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
+ Minimum_To_Free : SSC := Default_Min_Freed;
+ Reset_Content_On_Free : Boolean := Default_Reset_Content;
+ Raise_Exceptions : Boolean := Default_Raise_Exceptions;
+ Advanced_Scanning : Boolean := Default_Advanced_Scanning)
+ is
+ begin
+ Pool.Stack_Trace_Depth := Stack_Trace_Depth;
+ Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
+ Pool.Reset_Content_On_Free := Reset_Content_On_Free;
+ Pool.Raise_Exceptions := Raise_Exceptions;
+ Pool.Minimum_To_Free := Minimum_To_Free;
+ Pool.Advanced_Scanning := Advanced_Scanning;
+ end Configure;
+
+ ----------------
+ -- Print_Pool --
+ ----------------
+
+ procedure Print_Pool (A : System.Address) is
+ Storage : constant Address := A;
+ Valid : constant Boolean := Is_Valid (Storage);
+ Header : Allocation_Header_Access;
+
+ begin
+ -- We might get Null_Address if the call from gdb was done
+ -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
+ -- instead of passing the value of my_var
+
+ if A = System.Null_Address then
+ Put_Line ("Memory not under control of the storage pool");
+ return;
+ end if;
+
+ if not Valid then
+ Put_Line ("Memory not under control of the storage pool");
+
+ else
+ Header := Header_Of (Storage);
+ Put_Line ("0x" & Address_Image (A)
+ & " allocated at:");
+ Put_Line (0, Header.Alloc_Traceback.Traceback);
+
+ if To_Traceback (Header.Dealloc_Traceback) /= null then
+ Put_Line ("0x" & Address_Image (A)
+ & " logically freed memory, deallocated at:");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
+ end if;
+ end Print_Pool;
+
+ -----------------------
+ -- Print_Info_Stdout --
+ -----------------------
+
+ procedure Print_Info_Stdout
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False)
+ is
+ procedure Internal is new Print_Info
+ (Put_Line => GNAT.IO.Put_Line,
+ Put => GNAT.IO.Put);
+
+ begin
+ Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
+ end Print_Info_Stdout;
+
+ ------------------
+ -- Dump_Gnatmem --
+ ------------------
+
+ procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
+ type File_Ptr is new System.Address;
+
+ function fopen (Path : String; Mode : String) return File_Ptr;
+ pragma Import (C, fopen);
+
+ procedure fwrite
+ (Ptr : System.Address;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+
+ procedure fwrite
+ (Str : String;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+ pragma Import (C, fwrite);
+
+ procedure fputc (C : Integer; Stream : File_Ptr);
+ pragma Import (C, fputc);
+
+ procedure fclose (Stream : File_Ptr);
+ pragma Import (C, fclose);
+
+ Address_Size : constant size_t :=
+ System.Address'Max_Size_In_Storage_Elements;
+ -- Size in bytes of a pointer
+
+ File : File_Ptr;
+ Current : System.Address;
+ Header : Allocation_Header_Access;
+ Actual_Size : size_t;
+ Num_Calls : Integer;
+ Tracebk : Tracebacks_Array_Access;
+
+ begin
+ File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
+ fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
+
+ -- List of not deallocated blocks (see Print_Info)
+
+ Current := Pool.First_Used_Block;
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+
+ Actual_Size := size_t (Header.Block_Size);
+ Tracebk := Header.Alloc_Traceback.Traceback;
+ Num_Calls := Tracebk'Length;
+
+ -- Code taken from memtrack.adb in GNAT's sources
+ -- Logs allocation call
+ -- format is:
+ -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+
+ fputc (Character'Pos ('A'), File);
+ fwrite (Current'Address, Address_Size, 1, File);
+ fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
+ File);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ File);
+
+ for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+ declare
+ Ptr : System.Address := PC_For (Tracebk (J));
+ begin
+ fwrite (Ptr'Address, Address_Size, 1, File);
+ end;
+ end loop;
+
+ Current := Header.Next;
+ end loop;
+
+ fclose (File);
+ end Dump_Gnatmem;
+
+begin
+ Allocate_End;
+ Deallocate_End;
+ Dereference_End;
end GNAT.Debug_Pools;
OSDN Git Service
