-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Ada.Unchecked_Conversion;
package body GNAT.Debug_Pools is
- use System;
- use System.Storage_Elements;
- 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
+ -- value guarantees 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.
- -----------------------
- -- 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 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 --
-----------------------
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.
+
+ function Output_File (Pool : Debug_Pool) return File_Type;
+ pragma Inline (Output_File);
+ -- Returns file_type on which error messages have to be generated for Pool
procedure Put_Line
- (Depth : Natural;
+ (File : File_Type;
+ 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.
+ -- Print Traceback to File. 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
+
+ package Validity is
+ function Is_Valid (Storage : System.Address) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Return True if Storage is the address of a block that the debug pool
+ -- has under its control, in which case Header_Of may be used to access
+ -- the associated allocation header.
+
+ 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).
+ end Validity;
+
+ use Validity;
procedure Set_Dead_Beef
(Storage_Address : System.Address;
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.
+ -- to the user. This range of values excludes 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 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;
+ -----------------
+ -- Output_File --
+ -----------------
+
+ function Output_File (Pool : Debug_Pool) return File_Type is
+ begin
+ if Pool.Errors_To_Stdout then
+ return Standard_Output;
+ else
+ return Standard_Error;
+ end if;
+ end Output_File;
+
--------------
-- Put_Line --
--------------
procedure Put_Line
- (Depth : Natural;
+ (File : File_Type;
+ Depth : Natural;
Traceback : Tracebacks_Array_Access;
Ignored_Frame_Start : System.Address := System.Null_Address;
Ignored_Frame_End : System.Address := System.Null_Address)
procedure Print (Tr : Tracebacks_Array) is
begin
for J in Tr'Range loop
- Put ("0x" & Address_Image (PC_For (Tr (J))) & ' ');
+ Put (File, "0x" & Address_Image (PC_For (Tr (J))) & ' ');
end loop;
- Put (ASCII.LF);
+ Put (File, ASCII.LF);
end Print;
-- Start of processing for Put_Line
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);
end Find_Or_Create_Traceback;
--------------
- -- Is_Valid --
+ -- Validity --
--------------
- function Is_Valid (Storage : System.Address) return Boolean is
- Offset : constant Storage_Offset :=
- (Storage - Edata) / Default_Alignment;
+ package body Validity is
- Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit);
+ -- The validity bits of the allocated blocks are kept in a has table.
+ -- Each component of the hash table contains the validity bits for a
+ -- 16 Mbyte memory chunk.
- 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;
+ -- The reason the validity bits are kept for chunks of memory rather
+ -- than in a big array is that on some 64 bit platforms, it may happen
+ -- that two chunk of allocated data are very far from each other.
- ---------------
- -- Set_Valid --
- ---------------
+ Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB
+ Validity_Divisor : constant := Default_Alignment * System.Storage_Unit;
+
+ Max_Validity_Byte_Index : constant :=
+ Memory_Chunk_Size / Validity_Divisor;
+
+ subtype Validity_Byte_Index is Integer_Address
+ range 0 .. Max_Validity_Byte_Index - 1;
+
+ type Byte is mod 2 ** System.Storage_Unit;
+
+ type Validity_Bits is array (Validity_Byte_Index) of Byte;
+
+ type Validity_Bits_Ref is access all Validity_Bits;
+ No_Validity_Bits : constant Validity_Bits_Ref := null;
+
+ Max_Header_Num : constant := 1023;
+
+ type Header_Num is range 0 .. Max_Header_Num - 1;
+
+ function Hash (F : Integer_Address) return Header_Num;
- procedure Set_Valid (Storage : System.Address; Value : Boolean) is
- Offset : Storage_Offset;
- Bit : Byte;
- Bytes : Storage_Offset;
- Tmp : constant Table_Ptr := Valid_Blocks;
+ package Validy_Htable is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Validity_Bits_Ref,
+ No_Element => No_Validity_Bits,
+ Key => Integer_Address,
+ Hash => Hash,
+ Equal => "=");
+ -- Table to keep the validity bit blocks for the allocated data
- Edata_Align : constant Storage_Offset :=
- Default_Alignment * Storage_Unit;
+ function To_Pointer is new Ada.Unchecked_Conversion
+ (System.Address, Validity_Bits_Ref);
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");
+ ----------
+ -- Hash --
+ ----------
- 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.
+ function Hash (F : Integer_Address) return Header_Num is
+ begin
+ return Header_Num (F mod Max_Header_Num);
+ end Hash;
- 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;
+ --------------
+ -- Is_Valid --
+ --------------
- -- Reset the memory using memset, which is much faster than the
- -- standard Ada code with "when others"
+ function Is_Valid (Storage : System.Address) return Boolean is
+ Int_Storage : constant Integer_Address := To_Integer (Storage);
- Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size));
- end if;
+ begin
+ -- The pool only returns addresses aligned on Default_Alignment so
+ -- anything off cannot be a valid block address and we can return
+ -- early in this case. We actually have to since our data structures
+ -- map validity bits for such aligned addresses only.
- -- 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;
+ if Int_Storage mod Default_Alignment /= 0 then
+ return False;
+ 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
+ declare
+ Block_Number : constant Integer_Address :=
+ Int_Storage / Memory_Chunk_Size;
+ Ptr : constant Validity_Bits_Ref :=
+ Validy_Htable.Get (Block_Number);
+ Offset : constant Integer_Address :=
+ (Int_Storage -
+ (Block_Number * Memory_Chunk_Size)) /
+ Default_Alignment;
+ Bit : constant Byte :=
+ 2 ** Natural (Offset mod System.Storage_Unit);
+ begin
+ if Ptr = No_Validity_Bits then
+ return False;
+ else
+ return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0;
+ end if;
+ end;
+ end Is_Valid;
+
+ ---------------
+ -- Set_Valid --
+ ---------------
+
+ procedure Set_Valid (Storage : System.Address; Value : Boolean) is
+ Int_Storage : constant Integer_Address := To_Integer (Storage);
+ Block_Number : constant Integer_Address :=
+ Int_Storage / Memory_Chunk_Size;
+ Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number);
+ Offset : constant Integer_Address :=
+ (Int_Storage - (Block_Number * Memory_Chunk_Size)) /
+ Default_Alignment;
+ Bit : constant Byte :=
+ 2 ** Natural (Offset mod System.Storage_Unit);
- Offset := (Storage - Edata) / Default_Alignment;
+ begin
+ if Ptr = No_Validity_Bits then
- 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;
+ -- First time in this memory area: allocate a new block and put
+ -- it in the table.
- 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;
+ if Value then
+ Ptr := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
+ Validy_Htable.Set (Block_Number, Ptr);
+ Memset (Ptr.all'Address, 0, size_t (Max_Validity_Byte_Index));
+ Ptr (Offset / System.Storage_Unit) := Bit;
+ end if;
- Bit := 2 ** Natural (Offset mod System.Storage_Unit);
- Bytes := Offset / Storage_Unit;
+ else
+ if Value then
+ Ptr (Offset / System.Storage_Unit) :=
+ Ptr (Offset / System.Storage_Unit) or Bit;
- -- Then set the value as valid
+ else
+ Ptr (Offset / System.Storage_Unit) :=
+ Ptr (Offset / System.Storage_Unit) and (not Bit);
+ end if;
+ end if;
+ end Set_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;
+ end Validity;
--------------
-- Allocate --
(1 .. Size_In_Storage_Elements + Minimum_Allocation);
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().
+ -- 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;
-- 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.
+ -- is so that we do this only after a series of deallocations (e.g 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.Logically_Deallocated >
Byte_Count (Pool.Maximum_Logically_Freed_Memory)
Free_Physically (Pool);
end if;
- -- Use standard (ie through malloc) allocations. This automatically
+ -- Use standard (i.e. 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.
P := new Local_Storage_Array;
end;
- Storage_Address := System.Null_Address + Default_Alignment
- * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
- / Default_Alignment)
- + Header_Offset;
+ Storage_Address :=
+ To_Address
+ (Default_Alignment *
+ ((To_Integer (P.all'Address) + Default_Alignment - 1)
+ / Default_Alignment)
+ + Integer_Address (Header_Offset));
+ -- Computation is done in Integer_Address, not Storage_Offset, because
+ -- the range of Storage_Offset may not be large enough.
+
pragma Assert ((Storage_Address - System.Null_Address)
mod Default_Alignment = 0);
pragma Assert (Storage_Address + 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
+ -- 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 :=
Set_Valid (Storage_Address, True);
+ if Pool.Low_Level_Traces then
+ Put (Output_File (Pool),
+ "info: Allocated"
+ & Storage_Count'Image (Size_In_Storage_Elements)
+ & " bytes at 0x" & Address_Image (Storage_Address)
+ & " (physically:"
+ & Storage_Count'Image (Local_Storage_Array'Length)
+ & " bytes at 0x" & Address_Image (P.all'Address)
+ & "), at ");
+ Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
+ Allocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ end if;
+
-- Update internal data
Pool.Allocated :=
-- 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
+ -- 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
Header := Header_Of (Tmp);
-- If we know, or at least assume, the block is no longer
- -- reference anywhere, we can free it physically.
+ -- referenced anywhere, we can free it physically.
if Ignore_Marks or else not Marked (Tmp) then
end;
Next := Header.Next;
+
+ if Pool.Low_Level_Traces then
+ Put_Line
+ (Output_File (Pool),
+ "info: Freeing physical memory "
+ & Storage_Count'Image
+ ((abs Header.Block_Size) + Minimum_Allocation)
+ & " bytes at 0x"
+ & Address_Image (Header.Allocation_Address));
+ end if;
+
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;
-- 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;
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);
Lock_Task.all;
if Pool.Advanced_Scanning then
- Reset_Marks; -- Reset the mark for each freed block
+
+ -- Reset the mark for each freed block
+
+ Reset_Marks;
+
Mark_Blocks;
end if;
if Pool.Raise_Exceptions then
raise Freeing_Not_Allocated_Storage;
else
- Put ("error: Freeing not allocated storage, at ");
- Put_Line (Pool.Stack_Trace_Depth, null,
+ Put (Output_File (Pool),
+ "error: Freeing not allocated storage, at ");
+ Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
end if;
if Pool.Raise_Exceptions then
raise Freeing_Deallocated_Storage;
else
- Put ("error: Freeing already deallocated storage, at ");
- Put_Line (Pool.Stack_Trace_Depth, null,
+ Put (Output_File (Pool),
+ "error: Freeing already deallocated storage, at ");
+ Put_Line (Output_File (Pool), 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);
+ Put (Output_File (Pool), " Memory already deallocated at ");
+ Put_Line
+ (Output_File (Pool), 0,
+ To_Traceback (Header.Dealloc_Traceback).Traceback);
+ Put (Output_File (Pool), " Memory was allocated at ");
+ Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
end if;
else
- -- Remove this block from the list of used blocks.
+ -- Some sort of codegen problem or heap corruption caused the
+ -- Size_In_Storage_Elements to be wrongly computed.
+ -- The code below is all based on the assumption that Header.all
+ -- is not corrupted, such that the error is non-fatal.
+
+ if Header.Block_Size /= Size_In_Storage_Elements then
+ Put_Line (Output_File (Pool),
+ "error: Deallocate size "
+ & Storage_Count'Image (Size_In_Storage_Elements)
+ & " does not match allocate size "
+ & Storage_Count'Image (Header.Block_Size));
+ end if;
+
+ if Pool.Low_Level_Traces then
+ Put (Output_File (Pool),
+ "info: Deallocated"
+ & Storage_Count'Image (Size_In_Storage_Elements)
+ & " bytes at 0x" & Address_Image (Storage_Address)
+ & " (physically"
+ & Storage_Count'Image (Header.Block_Size + Minimum_Allocation)
+ & " bytes at 0x" & Address_Image (Header.Allocation_Address)
+ & "), at ");
+ Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ Put (Output_File (Pool), " Memory was allocated at ");
+ Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
+ end if;
+
+ -- Remove this block from the list of used blocks
Previous :=
- To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
+ To_Address (Header.Dealloc_Traceback);
if Previous = System.Null_Address then
Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
end if;
else
- Header_Of (Previous).Next := Header_Of (Storage_Address).Next;
+ Header_Of (Previous).Next := Header.Next;
- if Header_Of (Storage_Address).Next /= System.Null_Address then
+ if Header.Next /= System.Null_Address then
Header_Of
- (Header_Of (Storage_Address).Next).Dealloc_Traceback :=
- To_Address (Previous);
+ (Header.Next).Dealloc_Traceback := To_Address (Previous);
end if;
end if;
Deallocate_Label'Address,
Code_Address_For_Deallocate_End)),
Next => System.Null_Address,
- Block_Size => -Size_In_Storage_Elements);
+ Block_Size => -Header.Block_Size);
if Pool.Reset_Content_On_Free then
- Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
+ Set_Dead_Beef (Storage_Address, -Header.Block_Size);
end if;
Pool.Logically_Deallocated :=
- Pool.Logically_Deallocated +
- Byte_Count (Size_In_Storage_Elements);
+ Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size);
-- 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).
--------------------
-- DO NOT MOVE, this must be right after Deallocate
+
-- See Allocate_End
+ -- This is making assumptions about code order that may be invalid ???
+
procedure Deallocate_End is
begin
<<Deallocate_End_Label>>
if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
else
- Put ("error: Accessing not allocated storage, at ");
- Put_Line (Pool.Stack_Trace_Depth, null,
+ Put (Output_File (Pool),
+ "error: Accessing not allocated storage, at ");
+ Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Code_Address_For_Dereference_End);
end if;
if Pool.Raise_Exceptions then
raise Accessing_Deallocated_Storage;
else
- Put ("error: Accessing deallocated storage, at ");
+ Put (Output_File (Pool),
+ "error: Accessing deallocated storage, at ");
Put_Line
- (Pool.Stack_Trace_Depth, null,
+ (Output_File (Pool), 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);
+ Put (Output_File (Pool), " First deallocation at ");
+ Put_Line
+ (Output_File (Pool),
+ 0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ Put (Output_File (Pool), " Initial allocation at ");
+ Put_Line
+ (Output_File (Pool),
+ 0, Header.Alloc_Traceback.Traceback);
end if;
end if;
end if;
---------------------
-- DO NOT MOVE: this must be right after Dereference
+
-- See Allocate_End
+ -- This is making assumptions about code order that may be invalid ???
+
procedure Dereference_End is
begin
<<Dereference_End_Label>>
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,
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 ("potentially dangerous, and you might want to run");
Put_Line ("again with a lower value of Minimum_To_Free");
end if;
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
pragma Unreferenced (Pool);
-
begin
return Storage_Count'Last;
end Storage_Size;
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)
+ Advanced_Scanning : Boolean := Default_Advanced_Scanning;
+ Errors_To_Stdout : Boolean := Default_Errors_To_Stdout;
+ Low_Level_Traces : Boolean := Default_Low_Level_Traces)
is
begin
Pool.Stack_Trace_Depth := Stack_Trace_Depth;
Pool.Raise_Exceptions := Raise_Exceptions;
Pool.Minimum_To_Free := Minimum_To_Free;
Pool.Advanced_Scanning := Advanced_Scanning;
+ Pool.Errors_To_Stdout := Errors_To_Stdout;
+ Pool.Low_Level_Traces := Low_Level_Traces;
end Configure;
----------------
-- instead of passing the value of my_var
if A = System.Null_Address then
- Put_Line ("Memory not under control of the storage pool");
+ Put_Line
+ (Standard_Output, "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");
+ Put_Line
+ (Standard_Output, "Memory not under control of the storage pool");
else
Header := Header_Of (Storage);
- Put_Line ("0x" & Address_Image (A)
+ Put_Line (Standard_Output, "0x" & Address_Image (A)
& " allocated at:");
- Put_Line (0, Header.Alloc_Traceback.Traceback);
+ Put_Line (Standard_Output, 0, Header.Alloc_Traceback.Traceback);
if To_Traceback (Header.Dealloc_Traceback) /= null then
- Put_Line ("0x" & Address_Image (A)
+ Put_Line (Standard_Output, "0x" & Address_Image (A)
& " logically freed memory, deallocated at:");
- Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ Put_Line
+ (Standard_Output, 0,
+ To_Traceback (Header.Dealloc_Traceback).Traceback);
end if;
end if;
end Print_Pool;
Display_Slots : Boolean := False;
Display_Leaks : Boolean := False)
is
+ procedure Stdout_Put (S : String);
+ procedure Stdout_Put_Line (S : String);
+ -- Wrappers for Put and Put_Line that ensure we always write to stdout
+ -- instead of the current output file defined in GNAT.IO.
+
procedure Internal is new Print_Info
- (Put_Line => GNAT.IO.Put_Line,
- Put => GNAT.IO.Put);
+ (Put_Line => Stdout_Put_Line,
+ Put => Stdout_Put);
+
+ ----------------
+ -- Stdout_Put --
+ ----------------
+
+ procedure Stdout_Put (S : String) is
+ begin
+ Put_Line (Standard_Output, S);
+ end Stdout_Put;
+
+ ---------------------
+ -- Stdout_Put_Line --
+ ---------------------
+
+ procedure Stdout_Put_Line (S : String) is
+ begin
+ Put_Line (Standard_Output, S);
+ end Stdout_Put_Line;
+
+ -- Start of processing for Print_Info_Stdout
begin
Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
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);
fclose (File);
end Dump_Gnatmem;
+-- Package initialization
+
begin
Allocate_End;
Deallocate_End;
OSDN Git Service
