From be7e4a402a2c350e685e3af144ae10fcc03c08ac Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 12:07:09 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Philippe Gil * g-debpoo.ads (Dump): NEW print Debug_Pool statistics & main contributors. (Dump_Stdout): NEW print to stdout Debug_Pool statistics & main contributors. (Reset): NEW reset counters to 0. (Get_Size): NEW return size allocated at parameter. (High_Water_Mark): NEW. (Current_Water_Mark): NEW. (System_Memory_Debug_Pool): NEW tell Debug_Pools that System.Memory uses it. * g-debpoo.adb (Traceback_Htable_Elem): add Frees, Total_Frees components. (Find_Or_Create_Traceback): don't manage in System.Memory Debug_Pool Deallocate Traceback's. (Validity): add optional Handled table when System.Memory asked for Allow_Unhandled_Memory. (Allocate): handle Allocate reentrancy occuring when System.Memory uses Debug_Pools. (Deallocate): handle when Allow_Unhandled_Memory is set deallocation of unhandled memory. Dont't check Size_In_Storage_Elements if equal to Storage_Count'Last. update Frees, Total_Frees new components. 2015-10-20 Eric Botcazou * fe.h: Minor tweak. From-SVN: r229036 --- gcc/ada/ChangeLog | 29 +++ gcc/ada/fe.h | 10 +- gcc/ada/g-debpoo.adb | 584 ++++++++++++++++++++++++++++++++++++++----- gcc/ada/g-debpoo.ads | 78 +++++- 4 files changed, 624 insertions(+), 77 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5196fa7f0a3..d8bb5cb6512 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2015-10-20 Philippe Gil + + * g-debpoo.ads (Dump): NEW print Debug_Pool statistics & main + contributors. + (Dump_Stdout): NEW print to stdout Debug_Pool statistics & + main contributors. + (Reset): NEW reset counters to 0. + (Get_Size): NEW return size allocated at parameter. + (High_Water_Mark): NEW. + (Current_Water_Mark): NEW. + (System_Memory_Debug_Pool): NEW tell Debug_Pools that + System.Memory uses it. + * g-debpoo.adb (Traceback_Htable_Elem): add Frees, Total_Frees + components. + (Find_Or_Create_Traceback): don't manage in System.Memory + Debug_Pool Deallocate Traceback's. + (Validity): add optional Handled table when System.Memory asked + for Allow_Unhandled_Memory. + (Allocate): handle Allocate reentrancy occuring when System.Memory + uses Debug_Pools. + (Deallocate): handle when Allow_Unhandled_Memory + is set deallocation of unhandled memory. Dont't check + Size_In_Storage_Elements if equal to Storage_Count'Last. update + Frees, Total_Frees new components. + +2015-10-20 Eric Botcazou + + * fe.h: Minor tweak. + 2015-10-20 Vincent Celier * sem_cat.adb (Check_Categorization_Dependencies): Do nothing diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 88686e8c449..1df23b5bb08 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2014, Free Software Foundation, Inc. * + * Copyright (C) 1992-2015, 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- * @@ -39,6 +39,10 @@ extern "C" { #endif +/* atree: */ + +#define Serious_Errors_Detected atree__serious_errors_detected + /* comperr: */ #define Compiler_Abort comperr__compiler_abort @@ -77,10 +81,6 @@ extern Boolean Is_Entity_Name (Node_Id); #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); -/* atree: */ - -#define Serious_Errors_Detected atree__serious_errors_detected - /* errout: */ #define Error_Msg_N errout__error_msg_n diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 8d4372f6deb..94171c468c6 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -32,6 +32,7 @@ with GNAT.IO; use GNAT.IO; with System.Address_Image; +with System.CRTL; with System.Memory; use System.Memory; with System.Soft_Links; use System.Soft_Links; @@ -88,6 +89,18 @@ package body GNAT.Debug_Pools is -- 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. + Disable : Boolean := False; + -- This variable is used to avoid infinite loops, where this package would + -- itself allocate memory and then calls itself recursively, forever. + -- Useful when System_Memory_Debug_Pool_Enabled is True. + + System_Memory_Debug_Pool_Enabled : Boolean := False; + -- If True System.Memory allocation are using Debug_Pool + + Allow_Unhandled_Memory : Boolean := False; + -- If True protects Deallocate against releasing memory allocated before + -- System_Memory_Debug_Pool_Enabled was set. + --------------------------- -- Back Trace Hash Table -- --------------------------- @@ -115,11 +128,25 @@ package body GNAT.Debug_Pools is 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; + Traceback : Tracebacks_Array_Access; + Kind : Traceback_Kind; + Count : Natural; + -- size of the memory allocated/freed at Traceback since last Reset + -- call. + + Total : Byte_Count; + -- number of chunk of memory allocated/freed at Traceback since last + -- Reset call. + + Frees : Natural; + -- number of chunk of memory allocated at Traceback, currently freed + -- since last Reset call. (only for Alloc & Indirect_Alloc elements) + + Total_Frees : Byte_Count; + -- size of the memory allocated at Traceback, currently freed since last + -- Reset call. (only for Alloc & Indirect_Alloc elements) + + Next : Traceback_Htable_Elem_Ptr; end record; -- Subprograms used for the Backtrace_Htable instantiation @@ -268,7 +295,21 @@ package body GNAT.Debug_Pools is -- up to the first one in the range: -- Ignored_Frame_Start .. Ignored_Frame_End + procedure Stdout_Put (S : String); + -- Wrapper for Put that ensure we always write to stdout + -- instead of the current output file defined in GNAT.IO. + + procedure Stdout_Put_Line (S : String); + -- Wrapper for Put_Line that ensure we always write to stdout + -- instead of the current output file defined in GNAT.IO. + package Validity is + function Is_Handled (Storage : System.Address) return Boolean; + pragma Inline (Is_Handled); + -- Return True if Storage is the address of a block that the debug pool + -- had already under its control. + -- Used to allow System.Memory to use Debug_Pools + 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 @@ -519,12 +560,14 @@ package body GNAT.Debug_Pools is end if; declare + Disable_Exit_Value : constant Boolean := Disable; Trace : aliased Tracebacks_Array (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels); Len, Start : Natural; Elem : Traceback_Htable_Elem_Ptr; begin + Disable := True; Call_Chain (Trace, Len); Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, Ignored_Frame_Start, Ignored_Frame_End); @@ -539,10 +582,12 @@ package body GNAT.Debug_Pools is 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); + Count => 1, + Kind => Kind, + Total => Byte_Count (Size), + Frees => 0, + Total_Frees => 0, + Next => null); Backtrace_Htable.Set (Elem); else @@ -550,7 +595,12 @@ package body GNAT.Debug_Pools is Elem.Total := Elem.Total + Byte_Count (Size); end if; + Disable := Disable_Exit_Value; return Elem; + exception + when others => + Disable := Disable_Exit_Value; + raise; end; end Find_Or_Create_Traceback; @@ -579,7 +629,21 @@ package body GNAT.Debug_Pools is type Byte is mod 2 ** System.Storage_Unit; - type Validity_Bits is array (Validity_Byte_Index) of Byte; + type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; + type Validity_Bits_Part_Ref is access all Validity_Bits_Part; + No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; + + type Validity_Bits is record + Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address currently allocated. + + Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address was allocated once after + -- Allow_Unhandled_Memory was set to True. + -- Used to know on Deallocate if chunk of memory should be handled + -- as a block allocated by this package. + + end record; type Validity_Bits_Ref is access all Validity_Bits; No_Validity_Bits : constant Validity_Bits_Ref := null; @@ -590,6 +654,13 @@ package body GNAT.Debug_Pools is function Hash (F : Integer_Address) return Header_Num; + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean; + pragma Inline (Is_Valid_Or_Handled); + -- internal implementation of Is_Valid and Is_Handled. + -- Valid is used to select Valid or Handled arrays. + package Validy_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Validity_Bits_Ref, @@ -597,10 +668,11 @@ package body GNAT.Debug_Pools is Key => Integer_Address, Hash => Hash, Equal => "="); - -- Table to keep the validity bit blocks for the allocated data + -- Table to keep the validity and handled bit blocks for the allocated + -- data function To_Pointer is new Ada.Unchecked_Conversion - (System.Address, Validity_Bits_Ref); + (System.Address, Validity_Bits_Part_Ref); procedure Memset (A : Address; C : Integer; N : size_t); pragma Import (C, Memset, "memset"); @@ -614,11 +686,13 @@ package body GNAT.Debug_Pools is return Header_Num (F mod Max_Header_Num); end Hash; - -------------- - -- Is_Valid -- - -------------- + ------------------------- + -- Is_Valid_Or_Handled -- + ------------------------- - function Is_Valid (Storage : System.Address) return Boolean is + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean is Int_Storage : constant Integer_Address := To_Integer (Storage); begin @@ -646,11 +720,39 @@ package body GNAT.Debug_Pools is if Ptr = No_Validity_Bits then return False; else - return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0; + if Valid then + return (Ptr.Valid (Offset / System.Storage_Unit) + and Bit) /= 0; + else + if Ptr.Handled = No_Validity_Bits_Part then + return False; + else + return (Ptr.Handled (Offset / System.Storage_Unit) + and Bit) /= 0; + end if; + end if; end if; end; + end Is_Valid_Or_Handled; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => True); end Is_Valid; + ----------------- + -- Is_Handled -- + ----------------- + + function Is_Handled (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => False); + end Is_Handled; + --------------- -- Set_Valid -- --------------- @@ -666,6 +768,28 @@ package body GNAT.Debug_Pools is Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); + procedure Set_Handled; + pragma Inline (Set_Handled); + -- if Allow_Unhandled_Memory set Handled bit in table. + + ----------------- + -- Set_Handled -- + ----------------- + + procedure Set_Handled is + begin + if Allow_Unhandled_Memory then + if Ptr.Handled = No_Validity_Bits_Part then + Ptr.Handled := + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Memset (Ptr.Handled.all'Address, 0, + size_t (Max_Validity_Byte_Index)); + end if; + Ptr.Handled (Offset / System.Storage_Unit) := + Ptr.Handled (Offset / System.Storage_Unit) or Bit; + end if; + end Set_Handled; + begin if Ptr = No_Validity_Bits then @@ -673,20 +797,24 @@ package body GNAT.Debug_Pools is -- it in the table. if Value then - Ptr := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Ptr := new Validity_Bits; + Ptr.Valid := + 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; + Memset (Ptr.Valid.all'Address, 0, + size_t (Max_Validity_Byte_Index)); + Ptr.Valid (Offset / System.Storage_Unit) := Bit; + Set_Handled; end if; else if Value then - Ptr (Offset / System.Storage_Unit) := - Ptr (Offset / System.Storage_Unit) or Bit; - + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) or Bit; + Set_Handled; else - Ptr (Offset / System.Storage_Unit) := - Ptr (Offset / System.Storage_Unit) and (not Bit); + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); end if; end if; end Set_Valid; @@ -720,10 +848,23 @@ package body GNAT.Debug_Pools is P : Ptr; Trace : Traceback_Htable_Elem_Ptr; + Disable_Exit_Value : constant Boolean := Disable; + begin <> Lock_Task.all; + if Disable then + Storage_Address := + System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); + Unlock_Task.all; + return; + end if; + + Disable := True; + + Pool.Alloc_Count := Pool.Alloc_Count + 1; + -- 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 loop @@ -840,18 +981,19 @@ package body GNAT.Debug_Pools is Pool.Allocated := Pool.Allocated + Byte_Count (Size_In_Storage_Elements); - Current := Pool.Allocated - - Pool.Logically_Deallocated - - Pool.Physically_Deallocated; + Current := Pool.Current_Water_Mark; if Current > Pool.High_Water then Pool.High_Water := Current; end if; + Disable := Disable_Exit_Value; + Unlock_Task.all; exception when others => + Disable := Disable_Exit_Value; Unlock_Task.all; raise; end Allocate; @@ -1019,7 +1161,12 @@ package body GNAT.Debug_Pools is & Address_Image (Header.Allocation_Address)); end if; - System.Memory.Free (Header.Allocation_Address); + if System_Memory_Debug_Pool_Enabled then + System.CRTL.free (Header.Allocation_Address); + else + System.Memory.Free (Header.Allocation_Address); + end if; + Set_Valid (Tmp, False); -- Remove this block from the list @@ -1159,6 +1306,44 @@ package body GNAT.Debug_Pools is raise; end Free_Physically; + -------------- + -- Get_Size -- + -------------- + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean) is + begin + Lock_Task.all; + + Valid := Is_Valid (Storage_Address); + + if Is_Valid (Storage_Address) then + declare + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + begin + if Header.Block_Size >= 0 then + Valid := True; + Size_In_Storage_Elements := Header.Block_Size; + else + Valid := False; + end if; + end; + else + Valid := False; + end if; + + Unlock_Task.all; + + exception + when others => + Unlock_Task.all; + raise; + + end Get_Size; + ---------------- -- Deallocate -- ---------------- @@ -1183,7 +1368,31 @@ package body GNAT.Debug_Pools is if not Valid then Unlock_Task.all; - if Pool.Raise_Exceptions then + + if Storage_Address = System.Null_Address then + if Pool.Raise_Exceptions and then + Size_In_Storage_Elements /= Storage_Count'Last + then + raise Freeing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing Null_Address, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + return; + end if; + end if; + + if Allow_Unhandled_Memory and then not Is_Handled (Storage_Address) + then + System.CRTL.free (Storage_Address); + return; + end if; + + if Pool.Raise_Exceptions and then + Size_In_Storage_Elements /= Storage_Count'Last + then raise Freeing_Not_Allocated_Storage; else Put (Output_File (Pool), @@ -1217,7 +1426,9 @@ package body GNAT.Debug_Pools is -- 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 + if Header.Block_Size /= Size_In_Storage_Elements and then + Size_In_Storage_Elements /= Storage_Count'Last + then Put_Line (Output_File (Pool), "error: Deallocate size " & Storage_Count'Image (Size_In_Storage_Elements) @@ -1228,7 +1439,7 @@ package body GNAT.Debug_Pools is if Pool.Low_Level_Traces then Put (Output_File (Pool), "info: Deallocated" - & Storage_Count'Image (Size_In_Storage_Elements) + & Storage_Count'Image (Header.Block_Size) & " bytes at 0x" & Address_Image (Storage_Address) & " (physically" & Storage_Count'Image (Header.Block_Size + Extra_Allocation) @@ -1263,6 +1474,17 @@ package body GNAT.Debug_Pools is end if; end if; + -- Update the Alloc_Traceback Frees/Total_Frees members (if present) + + if Header.Alloc_Traceback /= null then + Header.Alloc_Traceback.Frees := Header.Alloc_Traceback.Frees + 1; + Header.Alloc_Traceback.Total_Frees := + Header.Alloc_Traceback.Total_Frees + + Byte_Count (Header.Block_Size); + end if; + + Pool.Free_Count := Pool.Free_Count + 1; + -- Update the header Header.all := @@ -1271,7 +1493,7 @@ package body GNAT.Debug_Pools is Dealloc_Traceback => To_Traceback (Find_Or_Create_Traceback (Pool, Dealloc, - Size_In_Storage_Elements, + Header.Block_Size, Deallocate_Label'Address, Code_Address_For_Deallocate_End)), Next => System.Null_Address, @@ -1453,9 +1675,7 @@ package body GNAT.Debug_Pools is Put_Line ("Current Water Mark: " & - Byte_Count'Image - (Pool.Allocated - Pool.Logically_Deallocated - - Pool.Physically_Deallocated)); + Byte_Count'Image (Pool.Current_Water_Mark)); Put_Line ("High Water Mark: " & @@ -1470,10 +1690,12 @@ package body GNAT.Debug_Pools is Elem := new Traceback_Htable_Elem' (Traceback => new Tracebacks_Array'(Data.Traceback.all), - Count => Data.Count, - Kind => Data.Kind, - Total => Data.Total, - Next => null); + Count => Data.Count, + Kind => Data.Kind, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); if Cumulate then @@ -1493,10 +1715,12 @@ package body GNAT.Debug_Pools is 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); + Count => Data.Count, + Kind => K, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); -- Properly take into account that the subprograms @@ -1575,6 +1799,204 @@ package body GNAT.Debug_Pools is end if; end Print_Info; + ---------- + -- Dump -- + ---------- + + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) is + + Total_Freed : constant Byte_Count := + Pool.Logically_Deallocated + Pool.Physically_Deallocated; + + procedure Do_Report (Sort : Report_Type); + -- Do a specific type of report + + procedure Do_Report (Sort : Report_Type) is + Elem : Traceback_Htable_Elem_Ptr; + Bigger : Boolean; + Grand_Total : Float; + + Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := + (others => null); + -- Sorted array for the biggest memory users + + begin + New_Line; + case Sort is + when Memory_Usage | All_Reports => + Put_Line (Size'Img & " biggest memory users at this time:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + when Allocations_Count => + Put_Line (Size'Img & " biggest number of live allocations:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + when Sort_Total_Allocs => + Put_Line (Size'Img & " biggest number of allocations:"); + Put_Line ("Results include total bytes and chunks allocated,"); + Put_Line ("even if no longer allocated - Deallocations are" + & " ignored"); + Grand_Total := Float (Pool.Allocated); + when Marked_Blocks => + Put_Line ("Special blocks marked by Mark_Traceback"); + Grand_Total := 0.0; + end case; + + Elem := Backtrace_Htable.Get_First; + while Elem /= null loop + -- Handle only alloc elememts + if Elem.Kind = Alloc then + -- Ignore small blocks (depending on the sorting criteria) to + -- gain speed + + if (Sort = Memory_Usage + and then Elem.Total - Elem.Total_Frees >= 1_000) + or else (Sort = Allocations_Count + and then Elem.Count - Elem.Frees >= 1) + or else (Sort = Sort_Total_Allocs and then Elem.Count > 1) + or else (Sort = Marked_Blocks + and then Elem.Total = 0) + then + if Sort = Marked_Blocks then + Grand_Total := Grand_Total + Float (Elem.Count); + end if; + + for M in Max'Range loop + Bigger := Max (M) = null; + if not Bigger then + case Sort is + when Memory_Usage | All_Reports => + Bigger := + Max (M).Total - Max (M).Total_Frees < + Elem.Total - Elem.Total_Frees; + when Allocations_Count => + Bigger := + Max (M).Count - Max (M).Frees + < Elem.Count - Elem.Frees; + when Sort_Total_Allocs | Marked_Blocks => + Bigger := Max (M).Count < Elem.Count; + end case; + end if; + + if Bigger then + Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); + Max (M) := Elem; + exit; + end if; + end loop; + end if; + end if; + + Elem := Backtrace_Htable.Get_Next; + end loop; + + if Grand_Total = 0.0 then + Grand_Total := 1.0; + end if; + + for M in Max'Range loop + exit when Max (M) = null; + declare + type Percent is delta 0.1 range 0.0 .. 100.0; + Total : Byte_Count; + P : Percent; + begin + case Sort is + when Memory_Usage | Allocations_Count | All_Reports => + Total := Max (M).Total - Max (M).Total_Frees; + when Sort_Total_Allocs => + Total := Max (M).Total; + when Marked_Blocks => + Total := Byte_Count (Max (M).Count); + end case; + + P := Percent (100.0 * Float (Total) / Grand_Total); + + if Sort = Marked_Blocks then + Put (P'Img & "%:" + & Max (M).Count'Img & " chunks /" + & Integer (Grand_Total)'Img & " at"); + else + Put (P'Img & "%:" & Total'Img & " bytes in" + & Max (M).Count'Img & " chunks at"); + end if; + end; + + for J in Max (M).Traceback'Range loop + Put (" 0x" & Address_Image (PC_For (Max (M).Traceback (J)))); + end loop; + + New_Line; + end loop; + end Do_Report; + + begin + + Put_Line ("Ada Allocs:" & Pool.Allocated'Img + & " bytes in" & Pool.Alloc_Count'Img & " chunks"); + Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & + Pool.Free_Count'Img + & " chunks"); + Put_Line ("Ada Current watermark: " + & Byte_Count'Image (Pool.Current_Water_Mark) + & " in" & Byte_Count'Image (Pool.Alloc_Count - + Pool.Free_Count) & " chunks"); + Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); + + case Report is + when All_Reports => + for Sort in Report_Type loop + if Sort /= All_Reports then + Do_Report (Sort); + end if; + end loop; + + when others => + Do_Report (Report); + end case; + + end Dump; + + ----------------- + -- Dump_Stdout -- + ----------------- + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) + is + + procedure Internal is new Dump + (Put_Line => Stdout_Put_Line, + Put => Stdout_Put); + + -- Start of processing for Dump_Stdout + + begin + Internal (Pool, Size, Report); + end Dump_Stdout; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + Elem : Traceback_Htable_Elem_Ptr; + begin + Elem := Backtrace_Htable.Get_First; + while Elem /= null loop + Elem.Count := 0; + Elem.Frees := 0; + Elem.Total := 0; + Elem.Total_Frees := 0; + Elem := Backtrace_Htable.Get_Next; + end loop; + end Reset; + ------------------ -- Storage_Size -- ------------------ @@ -1585,6 +2007,38 @@ package body GNAT.Debug_Pools is return Storage_Count'Last; end Storage_Size; + --------------------- + -- High_Water_Mark -- + --------------------- + + function High_Water_Mark + (Pool : Debug_Pool) return Byte_Count is + begin + return Pool.High_Water; + end High_Water_Mark; + + ------------------------ + -- Current_Water_Mark -- + ------------------------ + + function Current_Water_Mark + (Pool : Debug_Pool) return Byte_Count is + begin + return Pool.Allocated - Pool.Logically_Deallocated - + Pool.Physically_Deallocated; + end Current_Water_Mark; + + ------------------------------ + -- System_Memory_Debug_Pool -- + ------------------------------ + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True) is + begin + System_Memory_Debug_Pool_Enabled := True; + Allow_Unhandled_Memory := Has_Unhandled_Memory; + end System_Memory_Debug_Pool; + --------------- -- Configure -- --------------- @@ -1661,33 +2115,11 @@ 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 => 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 @@ -1780,6 +2212,24 @@ package body GNAT.Debug_Pools is fclose (File); end Dump_Gnatmem; + ---------------- + -- Stdout_Put -- + ---------------- + + procedure Stdout_Put (S : String) is + begin + Put (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; + -- Package initialization begin diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index e87c0e4b18d..049c206a96a 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -254,6 +254,71 @@ package GNAT.Debug_Pools is -- deallocation of that memory chunk, its current status (allocated or -- logically freed), etc. + type Report_Type is + (All_Reports, + Memory_Usage, + Allocations_Count, + Sort_Total_Allocs, + Marked_Blocks); + for Report_Type use + (All_Reports => 0, + Memory_Usage => 1, + Allocations_Count => 2, + Sort_Total_Allocs => 3, + Marked_Blocks => 4); + + generic + with procedure Put_Line (S : String) is <>; + with procedure Put (S : String) is <>; + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Dump information about memory usage. + -- Size is the number of the biggest memory users we want to show. Report + -- indicates which sorting order is used in the report + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Standard instantiation of Dump to print on standard_output. More + -- convenient to use where this is the intended location, and in particular + -- easier to use from the debugger. + + procedure Reset; + -- Reset all internal data. This is in general not needed, unless you want + -- to know what memory is used by specific parts of your application + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean); + -- set Valid if Storage_Address is the address of a chunk of memory + -- currently allocated by any pool. + -- If Valid is True, Size_In_Storage_Elements is set to the size of this + -- chunk of memory. + + type Byte_Count is mod System.Max_Binary_Modulus; + -- Type used for maintaining byte counts, needs to be large enough + -- to accommodate counts allowing for repeated use of the same memory. + + function High_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- return the highest size of the memory allocated by the pool. + -- memory used internally by the pool is not taken into account. + + function Current_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- return the size of the memory currently allocated by the pool. + -- memory used internally by the pool is not taken into account. + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True); + -- let the package know the System.Memory is using it. + -- If Has_Unhandled_Memory is true, some deallocate can be done for + -- memory not allocated with Allocate. + private -- The following are the standard primitive subprograms for a pool @@ -292,10 +357,6 @@ private -- on the setup of the storage pool. -- The parameters have the same semantics as defined in the ARM95. - type Byte_Count is mod System.Max_Binary_Modulus; - -- Type used for maintaining byte counts, needs to be large enough - -- to accommodate counts allowing for repeated use of the same memory. - type Debug_Pool is new System.Checked_Pools.Checked_Pool with record Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; @@ -306,6 +367,12 @@ private Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; Low_Level_Traces : Boolean := Default_Low_Level_Traces; + Alloc_Count : Byte_Count := 0; + -- Total number of allocation + + Free_Count : Byte_Count := 0; + -- Total number of deallocation + Allocated : Byte_Count := 0; -- Total number of bytes allocated in this pool @@ -337,5 +404,6 @@ private -- for the advanced freeing algorithms that needs to traverse all these -- blocks to find possible references to the block being physically -- freed. + end record; end GNAT.Debug_Pools; -- 2.30.2