[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

4 files changed, 624 insertions, 77 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5196fa7..d8bb5cb 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,32 @@
+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
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 88686e8..1df23b5 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 8d4372f..94171c4 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
       <<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
diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads
index e87c0e4..049c206 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;