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 624 additions and 77 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>
* sem_cat.adb (Check_Categorization_Dependencies): Do nothing
......
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
......
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
<<Allocate_Label>>
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
......
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;
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