From: Vincent Celier Date: Wed, 6 Jun 2007 10:29:21 +0000 (+0200) Subject: g-debpoo.ads, [...] (Free_Physically.Free_Blocks): Use the absolute value of Header... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f38df0e11608009b95e0332b9fbab26eb593095c;p=gcc.git g-debpoo.ads, [...] (Free_Physically.Free_Blocks): Use the absolute value of Header.Block_Size when... 2007-04-20 Vincent Celier Emmanuel Briot Olivier Hainque * g-debpoo.ads, g-debpoo.adb (Free_Physically.Free_Blocks): Use the absolute value of Header.Block_Size when displaying the freed physical memory in traces. (Allocate): Compute Storage_Address using Integer_Address, not Storage_Offset, because the range of Storage_Offset may not be large enough. (Configure): New parameter Low_Level_Traces (Allocate, Deallocation, Free_Physically): Added low-level traces (Configure): new parameter Errors_To_Stdout. (Output_File): new subprogram (Deallocate, Dereference): Send error messages to the proper stream (Print_Pool, Print_Info_Stdout): Make sure the output goes to stdout, as documented. Previous code would send it to the current output file defined in GNAT.IO, which might not be stdout (Is_Valid): Adjust comment to mention that a positive reply means that Header_Of may be used to retrieve the allocation header associated with the subprogram Storage address argument. Return False early if this address argument is misaligned. From-SVN: r125415 --- diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 030a235e30f..fa127470712 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -223,21 +223,27 @@ package body GNAT.Debug_Pools is -- 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); @@ -356,12 +362,26 @@ package body GNAT.Debug_Pools is 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) @@ -376,9 +396,9 @@ package body GNAT.Debug_Pools is 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 @@ -555,21 +575,35 @@ package body GNAT.Debug_Pools is 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; --------------- @@ -673,10 +707,13 @@ package body GNAT.Debug_Pools is 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); @@ -721,6 +758,20 @@ package body GNAT.Debug_Pools is 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 := @@ -894,6 +945,17 @@ package body GNAT.Debug_Pools is 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); @@ -1065,8 +1127,9 @@ package body GNAT.Debug_Pools is 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; @@ -1076,21 +1139,53 @@ package body GNAT.Debug_Pools is 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; @@ -1101,12 +1196,11 @@ package body GNAT.Debug_Pools is 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; @@ -1122,15 +1216,14 @@ package body GNAT.Debug_Pools is 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). @@ -1201,8 +1294,9 @@ package body GNAT.Debug_Pools is 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; @@ -1214,15 +1308,20 @@ package body GNAT.Debug_Pools is 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; @@ -1441,7 +1540,9 @@ package body GNAT.Debug_Pools is 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; @@ -1450,6 +1551,8 @@ package body GNAT.Debug_Pools is 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; ---------------- @@ -1467,23 +1570,27 @@ package body GNAT.Debug_Pools is -- 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; @@ -1498,9 +1605,35 @@ package body GNAT.Debug_Pools is 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; diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index 3d558a8f269..d3072c3d2f6 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -36,7 +36,7 @@ -- 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: @@ -102,6 +102,8 @@ package GNAT.Debug_Pools is 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, @@ -114,7 +116,9 @@ package GNAT.Debug_Pools is 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 @@ -143,7 +147,8 @@ package GNAT.Debug_Pools is -- -- 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. -- @@ -153,6 +158,17 @@ package GNAT.Debug_Pools is -- 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. @@ -289,6 +305,8 @@ private 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 @@ -297,7 +315,7 @@ private -- 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