-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- 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
+ -- 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 an address that the debug pool has under
- -- its control.
+ -- 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);
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
function Is_Valid (Storage : System.Address) return Boolean is
Int_Storage : constant Integer_Address := To_Integer (Storage);
- 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
+ -- 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 datastructures
+ -- map validity bits for such aligned addresses only.
+
+ if Int_Storage mod Default_Alignment /= 0 then
return False;
- else
- return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0;
end if;
+
+ 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;
---------------
end;
Storage_Address :=
- System.Null_Address + Default_Alignment
- * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
- / Default_Alignment)
- + Header_Offset;
+ 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);
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 :=
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);
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 (" Memory was allocated at ");
- Put_Line (0, Header.Alloc_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
+ -- 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).
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 (" Initial allocation at ");
- Put_Line (0, Header.Alloc_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;
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);
end Print_Info_Stdout;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- The goal of this debug pool is to detect incorrect uses of memory
-- (multiple deallocations, access to invalid memory,...). Errors are reported
-- in one of two ways: either by immediately raising an exception, or by
--- printing a message on standard output.
+-- printing a message on standard output or standard error.
-- You need to instrument your code to use this package: for each access type
-- you want to monitor, you need to add a clause similar to:
Default_Raise_Exceptions : constant Boolean := True;
Default_Advanced_Scanning : constant Boolean := False;
Default_Min_Freed : constant SSC := 0;
+ Default_Errors_To_Stdout : constant Boolean := True;
+ Default_Low_Level_Traces : constant Boolean := False;
-- The above values are constants used for the parameters to Configure
-- if not overridden in the call. See description of Configure for full
-- details on these parameters. If these defaults are not satisfactory,
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);
-- Subprogram used to configure the debug pool.
--
-- Stack_Trace_Depth. This parameter controls the maximum depth of stack
--
-- Raise_Exceptions: If true, the exceptions below will be raised every
-- time an error is detected. If you set this to False, then the action
- -- is to generate output on standard error, noting the errors, but to
+ -- is to generate output on standard error or standard output, depending
+ -- on Errors_To_Stdout, noting the errors, but to
-- keep running if possible (of course if storage is badly damaged, this
-- attempt may fail. This helps to detect more than one error in a run.
--
-- Note that this algorithm is approximate, and it is recommended
-- that you set Minimum_To_Free to a non-zero value to save time.
--
+ -- Errors_To_Stdout: Errors messages will be displayed on stdout if
+ -- this parameter is True, or to stderr otherwise.
+ --
+ -- Low_Level_Traces: Traces all allocation and deallocations on the
+ -- stream specified by Errors_To_Stdout. This can be used for
+ -- post-processing by your own application, or to debug the
+ -- debug_pool itself. The output indicates the size of the allocated
+ -- block both as requested by the application and as physically
+ -- allocated to fit the additional information needed by the debug
+ -- pool.
+ --
-- All instantiations of this pool use the same internal tables. However,
-- they do not store the same amount of information for the tracebacks,
-- and they have different counters for maximum logically freed memory.
Raise_Exceptions : Boolean := Default_Raise_Exceptions;
Minimum_To_Free : SSC := Default_Min_Freed;
Advanced_Scanning : Boolean := Default_Advanced_Scanning;
+ Errors_To_Stdout : Boolean := Default_Errors_To_Stdout;
+ Low_Level_Traces : Boolean := Default_Low_Level_Traces;
Allocated : Byte_Count := 0;
-- Total number of bytes allocated in this pool
-- Total number of bytes logically deallocated in this pool. This is the
-- memory that the application has released, but that the pool has not
-- yet physically released through a call to free(), to detect later
- -- accesed to deallocated memory.
+ -- accessed to deallocated memory.
Physically_Deallocated : Byte_Count := 0;
-- Total number of bytes that were free()-ed
OSDN Git Service
