-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
package body GNAT.Debug_Pools is
- Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment;
+ Default_Alignment : constant := 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
-- 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.
- -----------------------
- -- Tracebacks_Htable --
- -----------------------
+ ---------------------------
+ -- Back Trace Hash Table --
+ ---------------------------
-- This package needs to store one set of tracebacks for each allocation
-- point (when was it allocated or deallocated). This would use too much
Next : Traceback_Htable_Elem_Ptr;
end record;
+ -- Subprograms used for the Backtrace_Htable instantiation
+
procedure Set_Next
(E : Traceback_Htable_Elem_Ptr;
Next : Traceback_Htable_Elem_Ptr);
+ pragma Inline (Set_Next);
+
function Next
- (E : Traceback_Htable_Elem_Ptr)
- return Traceback_Htable_Elem_Ptr;
+ (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr;
+ pragma Inline (Next);
+
function Get_Key
- (E : Traceback_Htable_Elem_Ptr)
- return Tracebacks_Array_Access;
+ (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access;
+ pragma Inline (Get_Key);
+
function Hash (T : Tracebacks_Array_Access) return Header;
+ pragma Inline (Hash);
+
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.
+ -- Why is this not inlined???
+
+ -- The hash table for back traces
package Backtrace_Htable is new GNAT.HTable.Static_HTable
(Header_Num => Header,
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.
+ -- The following record stores extra information that needs to be
+ -- memorized for each block allocated with the special debug pool.
+
type Allocation_Header is record
Allocation_Address : System.Address;
- -- Address of the block returned by malloc, possibly unaligned.
+ -- Address of the block returned by malloc, possibly unaligned
- Block_Size : Storage_Offset;
+ 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;
+ Alloc_Traceback : Traceback_Htable_Elem_Ptr;
+ -- ??? comment required
+
Dealloc_Traceback : Traceback_Ptr_Or_Address;
-- Pointer to the traceback for the allocation (if the memory chunk is
-- still valid), or to the first deallocation otherwise. Make sure this
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);
- Header_Offset : constant Storage_Count
- := Default_Alignment *
- ((Allocation_Header'Size / System.Storage_Unit + Default_Alignment - 1)
- / Default_Alignment);
- -- Offset of user data after allocation header.
+ Header_Offset : constant Storage_Count :=
+ Default_Alignment *
+ ((Allocation_Header'Size / System.Storage_Unit
+ + Default_Alignment - 1) / Default_Alignment);
+ -- Offset of user data after allocation header
Minimum_Allocation : constant Storage_Count :=
- Default_Alignment - 1
- + Header_Offset;
+ Default_Alignment - 1 + Header_Offset;
-- Minimal allocation: size of allocation_header rounded up to next
-- multiple of default alignment + worst-case padding.
-- Allocations table --
-----------------------
- -- This table is indexed on addresses modulo Default_Alignment, 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 indexed on addresses modulo Default_Alignment, 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.
+ -- This table is the reason why all alignments have to be forced to common
+ -- value (Default_Alignment), so that this table can be kept to a
+ -- reasonnable size.
type Byte is mod 2 ** System.Storage_Unit;
-- 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).
+ -- 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;
+ 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.
+ -- possible address returned by malloc. Unfortunately, this symbol doesn't
+ -- exist on windows, so we cannot use it instead of this variable.
-----------------------
-- Local subprograms --
Kind : Traceback_Kind;
Size : Storage_Count;
Ignored_Frame_Start : System.Address;
- Ignored_Frame_End : System.Address)
- return Traceback_Htable_Elem_Ptr;
+ 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.
+ -- 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;
----------
function Next
- (E : Traceback_Htable_Elem_Ptr)
- return Traceback_Htable_Elem_Ptr
- is
+ (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is
begin
return E.Next;
end Next;
-------------
function Get_Key
- (E : Traceback_Htable_Elem_Ptr)
- return Tracebacks_Array_Access
+ (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access
is
begin
return E.Traceback;
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;
Kind : Traceback_Kind;
Size : Storage_Count;
Ignored_Frame_Start : System.Address;
- Ignored_Frame_End : System.Address)
- return Traceback_Htable_Elem_Ptr
+ Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr
is
begin
if Pool.Stack_Trace_Depth = 0 then
Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
Ignored_Frame_Start, Ignored_Frame_End);
- -- Check if the traceback is already in the table.
+ -- Check if the traceback is already in the table
Elem :=
Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
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
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
+ -- Valid_Blocks, so we have to grow the table as appropriate.
- Offset := (Storage - Edata) / Default_Alignment;
+ -- Note: it might seem more natural for the following statement to
+ -- be written:
+
+ -- Offset := (Storage - Edata) / Default_Alignment;
+
+ -- but that won't work since Storage_Offset is signed, and it is
+ -- possible to subtract a small address from a large address and
+ -- get a negative value. This may seem strange, but it is quite
+ -- specifically allowed in the RM, and is what most implementations
+ -- including GNAT actually do. Hence the conversion to Integer_Address
+ -- which is a full range modular type, not subject to this glitch.
+
+ Offset := Storage_Offset ((To_Integer (Storage) - To_Integer (Edata)) /
+ Default_Alignment);
if Offset >= Valid_Blocks_Size * System.Storage_Unit then
Bytes := Valid_Blocks_Size;
P := new Local_Storage_Array;
end;
- Storage_Address := System.Null_Address + Default_Alignment
- * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
- / Default_Alignment)
+ Storage_Address :=
+ System.Null_Address + Default_Alignment
+ * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
+ / Default_Alignment)
+ Header_Offset;
+
pragma Assert ((Storage_Address - System.Null_Address)
mod Default_Alignment = 0);
pragma Assert (Storage_Address + Size_In_Storage_Elements
System.Memory.Free (Header.Allocation_Address);
Set_Valid (Tmp, False);
- -- Remove this block from the list.
+ -- Remove this block from the list
if Previous = System.Null_Address then
Pool.First_Free_Block := Next;
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);
end if;
else
- -- Remove this block from the list of used blocks.
+ -- Remove this block from the list of used blocks
Previous :=
To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
pragma Unreferenced (Pool);
-
begin
return Storage_Count'Last;
end Storage_Size;
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;
Tracebk := Header.Alloc_Traceback.Traceback;
Num_Calls := Tracebk'Length;
- -- Code taken from memtrack.adb in GNAT's sources
- -- Logs allocation call
- -- format is:
+ -- (Code taken from memtrack.adb in GNAT's sources)
+
+ -- Logs allocation call using the format:
+
-- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
fputc (Character'Pos ('A'), File);
OSDN Git Service
