Skip to content

R
riscv-gcc-1
Commit be7e4a40 by Arnaud Charlet
Options

[multiple changes] 

2015-10-20  Philippe Gil  <gil@adacore.com>

	* 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  <ebotcazou@adacore.com>

	* fe.h: Minor tweak.

From-SVN: r229036
parent 46ee0270
Showing with 606 additions and 59 deletions
gcc/ada/ChangeLog
2015-10-20 Philippe Gil <gil@adacore.com>
* 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 <ebotcazou@adacore.com>
* fe.h: Minor tweak.
2015-10-20 Vincent Celier <celier@adacore.com> 2015-10-20 Vincent Celier <celier@adacore.com>
* sem_cat.adb (Check_Categorization_Dependencies): Do nothing * sem_cat.adb (Check_Categorization_Dependencies): Do nothing
......
gcc/ada/fe.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -39,6 +39,10 @@ ...@@ -39,6 +39,10 @@
extern "C" { extern "C" {
#endif #endif
/* atree: */
#define Serious_Errors_Detected atree__serious_errors_detected
/* comperr: */ /* comperr: */
#define Compiler_Abort comperr__compiler_abort #define Compiler_Abort comperr__compiler_abort
...@@ -77,10 +81,6 @@ extern Boolean Is_Entity_Name (Node_Id); ...@@ -77,10 +81,6 @@ extern Boolean Is_Entity_Name (Node_Id);
#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause
extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char);
/* atree: */
#define Serious_Errors_Detected atree__serious_errors_detected
/* errout: */ /* errout: */
#define Error_Msg_N errout__error_msg_n #define Error_Msg_N errout__error_msg_n
......
gcc/ada/g-debpoo.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,6 +32,7 @@ ...@@ -32,6 +32,7 @@
with GNAT.IO; use GNAT.IO; with GNAT.IO; use GNAT.IO;
with System.Address_Image; with System.Address_Image;
with System.CRTL;
with System.Memory; use System.Memory; with System.Memory; use System.Memory;
with System.Soft_Links; use System.Soft_Links; with System.Soft_Links; use System.Soft_Links;
...@@ -88,6 +89,18 @@ package body GNAT.Debug_Pools is ...@@ -88,6 +89,18 @@ package body GNAT.Debug_Pools is
-- is high enough to make sure we still have enough frames to return to -- 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. -- 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 -- -- Back Trace Hash Table --
--------------------------- ---------------------------
...@@ -118,7 +131,21 @@ package body GNAT.Debug_Pools is ...@@ -118,7 +131,21 @@ package body GNAT.Debug_Pools is
Traceback : Tracebacks_Array_Access; Traceback : Tracebacks_Array_Access;
Kind : Traceback_Kind; Kind : Traceback_Kind;
Count : Natural; Count : Natural;
-- size of the memory allocated/freed at Traceback since last Reset
-- call.
Total : Byte_Count; 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; Next : Traceback_Htable_Elem_Ptr;
end record; end record;
...@@ -268,7 +295,21 @@ package body GNAT.Debug_Pools is ...@@ -268,7 +295,21 @@ package body GNAT.Debug_Pools is
-- up to the first one in the range: -- up to the first one in the range:
-- Ignored_Frame_Start .. Ignored_Frame_End -- 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 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; function Is_Valid (Storage : System.Address) return Boolean;
pragma Inline (Is_Valid); pragma Inline (Is_Valid);
-- Return True if Storage is the address of a block that the debug pool -- Return True if Storage is the address of a block that the debug pool
...@@ -519,12 +560,14 @@ package body GNAT.Debug_Pools is ...@@ -519,12 +560,14 @@ package body GNAT.Debug_Pools is
end if; end if;
declare declare
Disable_Exit_Value : constant Boolean := Disable;
Trace : aliased Tracebacks_Array Trace : aliased Tracebacks_Array
(1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels); (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
Len, Start : Natural; Len, Start : Natural;
Elem : Traceback_Htable_Elem_Ptr; Elem : Traceback_Htable_Elem_Ptr;
begin begin
Disable := True;
Call_Chain (Trace, Len); Call_Chain (Trace, Len);
Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
Ignored_Frame_Start, Ignored_Frame_End); Ignored_Frame_Start, Ignored_Frame_End);
...@@ -542,6 +585,8 @@ package body GNAT.Debug_Pools is ...@@ -542,6 +585,8 @@ package body GNAT.Debug_Pools is
Count => 1, Count => 1,
Kind => Kind, Kind => Kind,
Total => Byte_Count (Size), Total => Byte_Count (Size),
Frees => 0,
Total_Frees => 0,
Next => null); Next => null);
Backtrace_Htable.Set (Elem); Backtrace_Htable.Set (Elem);
...@@ -550,7 +595,12 @@ package body GNAT.Debug_Pools is ...@@ -550,7 +595,12 @@ package body GNAT.Debug_Pools is
Elem.Total := Elem.Total + Byte_Count (Size); Elem.Total := Elem.Total + Byte_Count (Size);
end if; end if;
Disable := Disable_Exit_Value;
return Elem; return Elem;
exception
when others =>
Disable := Disable_Exit_Value;
raise;
end; end;
end Find_Or_Create_Traceback; end Find_Or_Create_Traceback;
...@@ -579,7 +629,21 @@ package body GNAT.Debug_Pools is ...@@ -579,7 +629,21 @@ package body GNAT.Debug_Pools is
type Byte is mod 2 ** System.Storage_Unit; 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; type Validity_Bits_Ref is access all Validity_Bits;
No_Validity_Bits : constant Validity_Bits_Ref := null; No_Validity_Bits : constant Validity_Bits_Ref := null;
...@@ -590,6 +654,13 @@ package body GNAT.Debug_Pools is ...@@ -590,6 +654,13 @@ package body GNAT.Debug_Pools is
function Hash (F : Integer_Address) return Header_Num; 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 package Validy_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num, (Header_Num => Header_Num,
Element => Validity_Bits_Ref, Element => Validity_Bits_Ref,
...@@ -597,10 +668,11 @@ package body GNAT.Debug_Pools is ...@@ -597,10 +668,11 @@ package body GNAT.Debug_Pools is
Key => Integer_Address, Key => Integer_Address,
Hash => Hash, Hash => Hash,
Equal => "="); 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 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); procedure Memset (A : Address; C : Integer; N : size_t);
pragma Import (C, Memset, "memset"); pragma Import (C, Memset, "memset");
...@@ -614,11 +686,13 @@ package body GNAT.Debug_Pools is ...@@ -614,11 +686,13 @@ package body GNAT.Debug_Pools is
return Header_Num (F mod Max_Header_Num); return Header_Num (F mod Max_Header_Num);
end Hash; 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); Int_Storage : constant Integer_Address := To_Integer (Storage);
begin begin
...@@ -646,11 +720,39 @@ package body GNAT.Debug_Pools is ...@@ -646,11 +720,39 @@ package body GNAT.Debug_Pools is
if Ptr = No_Validity_Bits then if Ptr = No_Validity_Bits then
return False; return False;
else 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 if;
end; 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; 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 -- -- Set_Valid --
--------------- ---------------
...@@ -666,6 +768,28 @@ package body GNAT.Debug_Pools is ...@@ -666,6 +768,28 @@ package body GNAT.Debug_Pools is
Bit : constant Byte := Bit : constant Byte :=
2 ** Natural (Offset mod System.Storage_Unit); 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 begin
if Ptr = No_Validity_Bits then if Ptr = No_Validity_Bits then
...@@ -673,20 +797,24 @@ package body GNAT.Debug_Pools is ...@@ -673,20 +797,24 @@ package body GNAT.Debug_Pools is
-- it in the table. -- it in the table.
if Value then 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); Validy_Htable.Set (Block_Number, Ptr);
Memset (Ptr.all'Address, 0, size_t (Max_Validity_Byte_Index)); Memset (Ptr.Valid.all'Address, 0,
Ptr (Offset / System.Storage_Unit) := Bit; size_t (Max_Validity_Byte_Index));
Ptr.Valid (Offset / System.Storage_Unit) := Bit;
Set_Handled;
end if; end if;
else else
if Value then if Value then
Ptr (Offset / System.Storage_Unit) := Ptr.Valid (Offset / System.Storage_Unit) :=
Ptr (Offset / System.Storage_Unit) or Bit; Ptr.Valid (Offset / System.Storage_Unit) or Bit;
Set_Handled;
else else
Ptr (Offset / System.Storage_Unit) := Ptr.Valid (Offset / System.Storage_Unit) :=
Ptr (Offset / System.Storage_Unit) and (not Bit); Ptr.Valid (Offset / System.Storage_Unit) and (not Bit);
end if; end if;
end if; end if;
end Set_Valid; end Set_Valid;
...@@ -720,10 +848,23 @@ package body GNAT.Debug_Pools is ...@@ -720,10 +848,23 @@ package body GNAT.Debug_Pools is
P : Ptr; P : Ptr;
Trace : Traceback_Htable_Elem_Ptr; Trace : Traceback_Htable_Elem_Ptr;
Disable_Exit_Value : constant Boolean := Disable;
begin begin
<<Allocate_Label>> <<Allocate_Label>>
Lock_Task.all; 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 -- If necessary, start physically releasing memory. The reason this is
-- done here, although Pool.Logically_Deallocated has not changed above, -- 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 -- 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 ...@@ -840,18 +981,19 @@ package body GNAT.Debug_Pools is
Pool.Allocated := Pool.Allocated :=
Pool.Allocated + Byte_Count (Size_In_Storage_Elements); Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
Current := Pool.Allocated - Current := Pool.Current_Water_Mark;
Pool.Logically_Deallocated -
Pool.Physically_Deallocated;
if Current > Pool.High_Water then if Current > Pool.High_Water then
Pool.High_Water := Current; Pool.High_Water := Current;
end if; end if;
Disable := Disable_Exit_Value;
Unlock_Task.all; Unlock_Task.all;
exception exception
when others => when others =>
Disable := Disable_Exit_Value;
Unlock_Task.all; Unlock_Task.all;
raise; raise;
end Allocate; end Allocate;
...@@ -1019,7 +1161,12 @@ package body GNAT.Debug_Pools is ...@@ -1019,7 +1161,12 @@ package body GNAT.Debug_Pools is
& Address_Image (Header.Allocation_Address)); & Address_Image (Header.Allocation_Address));
end if; end if;
if System_Memory_Debug_Pool_Enabled then
System.CRTL.free (Header.Allocation_Address);
else
System.Memory.Free (Header.Allocation_Address); System.Memory.Free (Header.Allocation_Address);
end if;
Set_Valid (Tmp, False); Set_Valid (Tmp, False);
-- Remove this block from the list -- Remove this block from the list
...@@ -1159,6 +1306,44 @@ package body GNAT.Debug_Pools is ...@@ -1159,6 +1306,44 @@ package body GNAT.Debug_Pools is
raise; raise;
end Free_Physically; 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 -- -- Deallocate --
---------------- ----------------
...@@ -1183,7 +1368,31 @@ package body GNAT.Debug_Pools is ...@@ -1183,7 +1368,31 @@ package body GNAT.Debug_Pools is
if not Valid then if not Valid then
Unlock_Task.all; 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; raise Freeing_Not_Allocated_Storage;
else else
Put (Output_File (Pool), Put (Output_File (Pool),
...@@ -1217,7 +1426,9 @@ package body GNAT.Debug_Pools is ...@@ -1217,7 +1426,9 @@ package body GNAT.Debug_Pools is
-- The code below is all based on the assumption that Header.all -- The code below is all based on the assumption that Header.all
-- is not corrupted, such that the error is non-fatal. -- 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), Put_Line (Output_File (Pool),
"error: Deallocate size " "error: Deallocate size "
& Storage_Count'Image (Size_In_Storage_Elements) & Storage_Count'Image (Size_In_Storage_Elements)
...@@ -1228,7 +1439,7 @@ package body GNAT.Debug_Pools is ...@@ -1228,7 +1439,7 @@ package body GNAT.Debug_Pools is
if Pool.Low_Level_Traces then if Pool.Low_Level_Traces then
Put (Output_File (Pool), Put (Output_File (Pool),
"info: Deallocated" "info: Deallocated"
& Storage_Count'Image (Size_In_Storage_Elements) & Storage_Count'Image (Header.Block_Size)
& " bytes at 0x" & Address_Image (Storage_Address) & " bytes at 0x" & Address_Image (Storage_Address)
& " (physically" & " (physically"
& Storage_Count'Image (Header.Block_Size + Extra_Allocation) & Storage_Count'Image (Header.Block_Size + Extra_Allocation)
...@@ -1263,6 +1474,17 @@ package body GNAT.Debug_Pools is ...@@ -1263,6 +1474,17 @@ package body GNAT.Debug_Pools is
end if; end if;
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 -- Update the header
Header.all := Header.all :=
...@@ -1271,7 +1493,7 @@ package body GNAT.Debug_Pools is ...@@ -1271,7 +1493,7 @@ package body GNAT.Debug_Pools is
Dealloc_Traceback => To_Traceback Dealloc_Traceback => To_Traceback
(Find_Or_Create_Traceback (Find_Or_Create_Traceback
(Pool, Dealloc, (Pool, Dealloc,
Size_In_Storage_Elements, Header.Block_Size,
Deallocate_Label'Address, Deallocate_Label'Address,
Code_Address_For_Deallocate_End)), Code_Address_For_Deallocate_End)),
Next => System.Null_Address, Next => System.Null_Address,
...@@ -1453,9 +1675,7 @@ package body GNAT.Debug_Pools is ...@@ -1453,9 +1675,7 @@ package body GNAT.Debug_Pools is
Put_Line Put_Line
("Current Water Mark: " & ("Current Water Mark: " &
Byte_Count'Image Byte_Count'Image (Pool.Current_Water_Mark));
(Pool.Allocated - Pool.Logically_Deallocated
- Pool.Physically_Deallocated));
Put_Line Put_Line
("High Water Mark: " & ("High Water Mark: " &
...@@ -1473,6 +1693,8 @@ package body GNAT.Debug_Pools is ...@@ -1473,6 +1693,8 @@ package body GNAT.Debug_Pools is
Count => Data.Count, Count => Data.Count,
Kind => Data.Kind, Kind => Data.Kind,
Total => Data.Total, Total => Data.Total,
Frees => Data.Frees,
Total_Frees => Data.Total_Frees,
Next => null); Next => null);
Backtrace_Htable_Cumulate.Set (Elem); Backtrace_Htable_Cumulate.Set (Elem);
...@@ -1496,6 +1718,8 @@ package body GNAT.Debug_Pools is ...@@ -1496,6 +1718,8 @@ package body GNAT.Debug_Pools is
Count => Data.Count, Count => Data.Count,
Kind => K, Kind => K,
Total => Data.Total, Total => Data.Total,
Frees => Data.Frees,
Total_Frees => Data.Total_Frees,
Next => null); Next => null);
Backtrace_Htable_Cumulate.Set (Elem); Backtrace_Htable_Cumulate.Set (Elem);
...@@ -1575,6 +1799,204 @@ package body GNAT.Debug_Pools is ...@@ -1575,6 +1799,204 @@ package body GNAT.Debug_Pools is
end if; end if;
end Print_Info; 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 -- -- Storage_Size --
------------------ ------------------
...@@ -1585,6 +2007,38 @@ package body GNAT.Debug_Pools is ...@@ -1585,6 +2007,38 @@ package body GNAT.Debug_Pools is
return Storage_Count'Last; return Storage_Count'Last;
end Storage_Size; 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 -- -- Configure --
--------------- ---------------
...@@ -1661,33 +2115,11 @@ package body GNAT.Debug_Pools is ...@@ -1661,33 +2115,11 @@ package body GNAT.Debug_Pools is
Display_Slots : Boolean := False; Display_Slots : Boolean := False;
Display_Leaks : Boolean := False) Display_Leaks : Boolean := False)
is 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 procedure Internal is new Print_Info
(Put_Line => Stdout_Put_Line, (Put_Line => Stdout_Put_Line,
Put => Stdout_Put); 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 -- Start of processing for Print_Info_Stdout
begin begin
...@@ -1780,6 +2212,24 @@ package body GNAT.Debug_Pools is ...@@ -1780,6 +2212,24 @@ package body GNAT.Debug_Pools is
fclose (File); fclose (File);
end Dump_Gnatmem; 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 -- Package initialization
begin begin
......
gcc/ada/g-debpoo.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -254,6 +254,71 @@ package GNAT.Debug_Pools is ...@@ -254,6 +254,71 @@ package GNAT.Debug_Pools is
-- deallocation of that memory chunk, its current status (allocated or -- deallocation of that memory chunk, its current status (allocated or
-- logically freed), etc. -- 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 private
-- The following are the standard primitive subprograms for a pool -- The following are the standard primitive subprograms for a pool
...@@ -292,10 +357,6 @@ private ...@@ -292,10 +357,6 @@ private
-- on the setup of the storage pool. -- on the setup of the storage pool.
-- The parameters have the same semantics as defined in the ARM95. -- 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 type Debug_Pool is new System.Checked_Pools.Checked_Pool with record
Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
...@@ -306,6 +367,12 @@ private ...@@ -306,6 +367,12 @@ private
Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; Errors_To_Stdout : Boolean := Default_Errors_To_Stdout;
Low_Level_Traces : Boolean := Default_Low_Level_Traces; 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; Allocated : Byte_Count := 0;
-- Total number of bytes allocated in this pool -- Total number of bytes allocated in this pool
...@@ -337,5 +404,6 @@ private ...@@ -337,5 +404,6 @@ private
-- for the advanced freeing algorithms that needs to traverse all these -- for the advanced freeing algorithms that needs to traverse all these
-- blocks to find possible references to the block being physically -- blocks to find possible references to the block being physically
-- freed. -- freed.
end record; end record;
end GNAT.Debug_Pools; end GNAT.Debug_Pools;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment