Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                       G N A T . D E B U G _ P O O L S                    --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Ada.Exceptions.Traceback;

with GNAT.IO; use GNAT.IO;

with System.Address_Image;

with System.Memory;     use System.Memory;

with System.Soft_Links; use System.Soft_Links;

with System.Traceback_Entries; use System.Traceback_Entries;

with GNAT.HTable;

with GNAT.Traceback; use GNAT.Traceback;

with Ada.Unchecked_Conversion;

package body GNAT.Debug_Pools is

   Default_Alignment : constant := Standard'Maximum_Alignment;

   --  Alignment used for the memory chunks returned by Allocate. Using this

   --  value guarantees that this alignment will be compatible with all types

   --  and at the same time makes it easy to find the location of the extra

   --  header allocated for each chunk.

   Max_Ignored_Levels : constant Natural := 10;

   --  Maximum number of levels that will be ignored in backtraces. This is so

   --  that we still have enough significant levels in the tracebacks returned

   --  to the user.

   --

   --  The value 10 is chosen as being greater than the maximum callgraph

   --  in this package. Its actual value is not really relevant, as long as it

   --  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.

   ---------------------------

   -- Back Trace Hash Table --

   ---------------------------

   --  This package needs to store one set of tracebacks for each allocation

   --  point (when was it allocated or deallocated). This would use too much

   --  memory,  so the tracebacks are actually stored in a hash table, and

   --  we reference elements in this hash table instead.

   --  This hash-table will remain empty if the discriminant Stack_Trace_Depth

   --  for the pools is set to 0.

   --  This table is a global table, that can be shared among all debug pools

   --  with no problems.

   type Header is range 1 .. 1023;

   --  Number of elements in the hash-table

   type Tracebacks_Array_Access

      is access GNAT.Traceback.Tracebacks_Array;

   type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);

   type Traceback_Htable_Elem;

   type Traceback_Htable_Elem_Ptr

      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;

   end record;

   --  Subprograms used for the Backtrace_Htable instantiation

   procedure Set_Next

     (E    : Traceback_Htable_Elem_Ptr;

      Next : Traceback_Htable_Elem_Ptr);

   pragma Inline (Set_Next);

   function Next

     (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr;

   pragma Inline (Next);

   function Get_Key

     (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access;

   pragma Inline (Get_Key);

   function Hash (T : Tracebacks_Array_Access) return Header;

   pragma Inline (Hash);

   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;

   --  Why is this not inlined???

   --  The hash table for back traces

   package Backtrace_Htable is new GNAT.HTable.Static_HTable

     (Header_Num => Header,

      Element    => Traceback_Htable_Elem,

      Elmt_Ptr   => Traceback_Htable_Elem_Ptr,

      Null_Ptr   => null,

      Set_Next   => Set_Next,

      Next       => Next,

      Key        => Tracebacks_Array_Access,

      Get_Key    => Get_Key,

      Hash       => Hash,

      Equal      => Equal);

   -----------------------

   -- Allocations table --

   -----------------------

   type Allocation_Header;

   type Allocation_Header_Access is access Allocation_Header;

   type Traceback_Ptr_Or_Address is new System.Address;

   --  A type that acts as a C union, and is either a System.Address or a

   --  Traceback_Htable_Elem_Ptr.

   --  The following record stores extra information that needs to be

   --  memorized for each block allocated with the special debug pool.

   type Allocation_Header is record

      Allocation_Address : System.Address;

      --  Address of the block returned by malloc, possibly unaligned

      Block_Size : Storage_Offset;

      --  Needed only for advanced freeing algorithms (traverse all allocated

      --  blocks for potential references). This value is negated when the

      --  chunk of memory has been logically freed by the application. This

      --  chunk has not been physically released yet.

      Alloc_Traceback : Traceback_Htable_Elem_Ptr;

      --  ??? comment required

      Dealloc_Traceback : Traceback_Ptr_Or_Address;

      --  Pointer to the traceback for the allocation (if the memory chunk is

      --  still valid), or to the first deallocation otherwise. Make sure this

      --  is a thin pointer to save space.

      --

      --  Dealloc_Traceback is also for blocks that are still allocated to

      --  point to the previous block in the list. This saves space in this

      --  header, and make manipulation of the lists of allocated pointers

      --  faster.

      Next : System.Address;

      --  Point to the next block of the same type (either allocated or

      --  logically freed) in memory. This points to the beginning of the user

      --  data, and does not include the header of that block.

   end record;

   function Header_Of (Address : System.Address)

      return Allocation_Header_Access;

   pragma Inline (Header_Of);

   --  Return the header corresponding to a previously allocated address

   function To_Address is new Ada.Unchecked_Conversion

     (Traceback_Ptr_Or_Address, System.Address);

   function To_Address is new Ada.Unchecked_Conversion

     (System.Address, Traceback_Ptr_Or_Address);

   function To_Traceback is new Ada.Unchecked_Conversion

     (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);

   function To_Traceback is new Ada.Unchecked_Conversion

     (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);

   Header_Offset : constant Storage_Count :=

                     Default_Alignment *

                       ((Allocation_Header'Size / System.Storage_Unit

                          + Default_Alignment - 1) / Default_Alignment);

   --  Offset of user data after allocation header

   Minimum_Allocation : constant Storage_Count :=

                          Default_Alignment - 1 + Header_Offset;

   --  Minimal allocation: size of allocation_header rounded up to next

   --  multiple of default alignment + worst-case padding.

   -----------------------

   -- Local subprograms --

   -----------------------

   function Find_Or_Create_Traceback

     (Pool                : Debug_Pool;

      Kind                : Traceback_Kind;

      Size                : Storage_Count;

      Ignored_Frame_Start : System.Address;

      Ignored_Frame_End   : System.Address) return Traceback_Htable_Elem_Ptr;

   --  Return an element matching the current traceback (omitting the frames

   --  that are in the current package). If this traceback already existed in

   --  the htable, a pointer to this is returned to spare memory. Null is

   --  returned if the pool is set not to store tracebacks. If the traceback

   --  already existed in the table, the count is incremented so that

   --  Dump_Tracebacks returns useful results. All addresses up to, and

   --  including, an address between Ignored_Frame_Start .. Ignored_Frame_End

   --  are ignored.

   function Output_File (Pool : Debug_Pool) return File_Type;

   pragma Inline (Output_File);

   --  Returns file_type on which error messages have to be generated for Pool

   procedure Put_Line

     (File                : File_Type;

      Depth               : Natural;

      Traceback           : Tracebacks_Array_Access;

      Ignored_Frame_Start : System.Address := System.Null_Address;

      Ignored_Frame_End   : System.Address := System.Null_Address);

   --  Print Traceback to File. If Traceback is null, print the call_chain

   --  at the current location, up to Depth levels, ignoring all addresses

   --  up to the first one in the range:

   --    Ignored_Frame_Start .. Ignored_Frame_End

   package Validity is

      function Is_Valid (Storage : System.Address) return Boolean;

      pragma Inline (Is_Valid);

      --  Return True if Storage is the address of a block that the debug pool

      --  has under its control, in which case Header_Of may be used to access

      --  the associated allocation header.

      procedure Set_Valid (Storage : System.Address; Value : Boolean);

      pragma Inline (Set_Valid);

      --  Mark the address Storage as being under control of the memory pool

      --  (if Value is True), or not (if Value is False).

   end Validity;

   use Validity;

   procedure Set_Dead_Beef

     (Storage_Address          : System.Address;

      Size_In_Storage_Elements : Storage_Count);

   --  Set the contents of the memory block pointed to by Storage_Address to

   --  the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple

   --  of the length of this pattern, the last instance may be partial.

   procedure Free_Physically (Pool : in out Debug_Pool);

   --  Start to physically release some memory to the system, until the amount

   --  of logically (but not physically) freed memory is lower than the

   --  expected amount in Pool.

   procedure Allocate_End;

   procedure Deallocate_End;

   procedure Dereference_End;

   --  These procedures are used as markers when computing the stacktraces,

   --  so that addresses in the debug pool itself are not reported to the user.

   Code_Address_For_Allocate_End    : System.Address;

   Code_Address_For_Deallocate_End  : System.Address;

   Code_Address_For_Dereference_End : System.Address;

   --  Taking the address of the above procedures will not work on some

   --  architectures (HPUX and VMS for instance). Thus we do the same thing

   --  that is done in a-except.adb, and get the address of labels instead

   procedure Skip_Levels

     (Depth               : Natural;

      Trace               : Tracebacks_Array;

      Start               : out Natural;

      Len                 : in out Natural;

      Ignored_Frame_Start : System.Address;

      Ignored_Frame_End   : System.Address);

   --  Set Start .. Len to the range of values from Trace that should be output

   --  to the user. This range of values excludes any address prior to the

   --  first one in Ignored_Frame_Start .. Ignored_Frame_End (basically

   --  addresses internal to this package). Depth is the number of levels that

   --  the user is interested in.

   ---------------

   -- Header_Of --

   ---------------

   function Header_Of (Address : System.Address)

      return Allocation_Header_Access

   is

      function Convert is new Ada.Unchecked_Conversion

        (System.Address, Allocation_Header_Access);

   begin

      return Convert (Address - Header_Offset);

   end Header_Of;

   --------------

   -- Set_Next --

   --------------

   procedure Set_Next

     (E    : Traceback_Htable_Elem_Ptr;

      Next : Traceback_Htable_Elem_Ptr)

   is

   begin

      E.Next := Next;

   end Set_Next;

   ----------

   -- Next --

   ----------

   function Next

     (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is

   begin

      return E.Next;

   end Next;

   -----------

   -- Equal --

   -----------

   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is

      use Ada.Exceptions.Traceback;

   begin

      return K1.all = K2.all;

   end Equal;

   -------------

   -- Get_Key --

   -------------

   function Get_Key

     (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access

   is

   begin

      return E.Traceback;

   end Get_Key;

   ----------

   -- Hash --

   ----------

   function Hash (T : Tracebacks_Array_Access) return Header is

      Result : Integer_Address := 0;

   begin

      for X in T'Range loop

         Result := Result + To_Integer (PC_For (T (X)));

      end loop;

      return Header (1 + Result mod Integer_Address (Header'Last));

   end Hash;

   -----------------

   -- Output_File --

   -----------------

   function Output_File (Pool : Debug_Pool) return File_Type is

   begin

      if Pool.Errors_To_Stdout then

         return Standard_Output;

      else

         return Standard_Error;

      end if;

   end Output_File;

   --------------

   -- Put_Line --

   --------------

   procedure Put_Line

     (File                : File_Type;

      Depth               : Natural;

      Traceback           : Tracebacks_Array_Access;

      Ignored_Frame_Start : System.Address := System.Null_Address;

      Ignored_Frame_End   : System.Address := System.Null_Address)

   is

      procedure Print (Tr : Tracebacks_Array);

      --  Print the traceback to standard_output

      -----------

      -- Print --

      -----------

      procedure Print (Tr : Tracebacks_Array) is

      begin

         for J in Tr'Range loop

            Put (File, "0x" & Address_Image (PC_For (Tr (J))) & ' ');

         end loop;

         Put (File, ASCII.LF);

      end Print;

   --  Start of processing for Put_Line

   begin

      if Traceback = null then

         declare

            Tr  : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);

            Start, Len : Natural;

         begin

            Call_Chain (Tr, Len);

            Skip_Levels (Depth, Tr, Start, Len,

                         Ignored_Frame_Start, Ignored_Frame_End);

            Print (Tr (Start .. Len));

         end;

      else

         Print (Traceback.all);

      end if;

   end Put_Line;

   -----------------

   -- Skip_Levels --

   -----------------

   procedure Skip_Levels

     (Depth               : Natural;

      Trace               : Tracebacks_Array;

      Start               : out Natural;

      Len                 : in out Natural;

      Ignored_Frame_Start : System.Address;

      Ignored_Frame_End   : System.Address)

   is

   begin

      Start := Trace'First;

      while Start <= Len

        and then (PC_For (Trace (Start)) < Ignored_Frame_Start

                    or else PC_For (Trace (Start)) > Ignored_Frame_End)

      loop

         Start := Start + 1;

      end loop;

      Start := Start + 1;

      --  Just in case: make sure we have a traceback even if Ignore_Till

      --  wasn't found.

      if Start > Len then

         Start := 1;

      end if;

      if Len - Start + 1 > Depth then

         Len := Depth + Start - 1;

      end if;

   end Skip_Levels;

   ------------------------------

   -- Find_Or_Create_Traceback --

   ------------------------------

   function Find_Or_Create_Traceback

     (Pool                : Debug_Pool;

      Kind                : Traceback_Kind;

      Size                : Storage_Count;

      Ignored_Frame_Start : System.Address;

      Ignored_Frame_End   : System.Address) return Traceback_Htable_Elem_Ptr

   is

   begin

      if Pool.Stack_Trace_Depth = 0 then

         return null;

      end if;

      declare

         Trace : aliased Tracebacks_Array

                  (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);

         Len, Start   : Natural;

         Elem  : Traceback_Htable_Elem_Ptr;

      begin

         Call_Chain (Trace, Len);

         Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,

                      Ignored_Frame_Start, Ignored_Frame_End);

         --  Check if the traceback is already in the table

         Elem :=

           Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);

         --  If not, insert it

         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);

            Backtrace_Htable.Set (Elem);

         else

            Elem.Count := Elem.Count + 1;

            Elem.Total := Elem.Total + Byte_Count (Size);

         end if;

         return Elem;

      end;

   end Find_Or_Create_Traceback;

   --------------

   -- Validity --

   --------------

   package body Validity is

      --  The validity bits of the allocated blocks are kept in a has table.

      --  Each component of the hash table contains the validity bits for a

      --  16 Mbyte memory chunk.

      --  The reason the validity bits are kept for chunks of memory rather

      --  than in a big array is that on some 64 bit platforms, it may happen

      --  that two chunk of allocated data are very far from each other.

      Memory_Chunk_Size : constant Integer_Address := 2 ** 24; --  16 MB

      Validity_Divisor  : constant := Default_Alignment * System.Storage_Unit;

      Max_Validity_Byte_Index : constant :=

                                 Memory_Chunk_Size / Validity_Divisor;

      subtype Validity_Byte_Index is Integer_Address

                                      range 0 .. Max_Validity_Byte_Index - 1;

      type Byte is mod 2 ** System.Storage_Unit;

      type Validity_Bits is array (Validity_Byte_Index) of Byte;

      type Validity_Bits_Ref is access all Validity_Bits;

      No_Validity_Bits : constant Validity_Bits_Ref := null;

      Max_Header_Num : constant := 1023;

      type Header_Num is range 0 .. Max_Header_Num - 1;

      function Hash (F : Integer_Address) return Header_Num;

      package Validy_Htable is new GNAT.HTable.Simple_HTable

        (Header_Num => Header_Num,

         Element    => Validity_Bits_Ref,

         No_Element => No_Validity_Bits,

         Key        => Integer_Address,

         Hash       => Hash,

         Equal      => "=");

      --  Table to keep the validity bit blocks for the allocated data

      function To_Pointer is new Ada.Unchecked_Conversion

        (System.Address, Validity_Bits_Ref);

      procedure Memset (A : Address; C : Integer; N : size_t);

      pragma Import (C, Memset, "memset");

      ----------

      -- Hash --

      ----------

      function Hash (F : Integer_Address) return Header_Num is

      begin

         return Header_Num (F mod Max_Header_Num);

      end Hash;

      --------------

      -- Is_Valid --

      --------------

      function Is_Valid (Storage : System.Address) return Boolean is

         Int_Storage  : constant Integer_Address := To_Integer (Storage);

      begin

         --  The pool only returns addresses aligned on Default_Alignment so

         --  anything off cannot be a valid block address and we can return

         --  early in this case. We actually have to since our data structures

         --  map validity bits for such aligned addresses only.

         if Int_Storage mod Default_Alignment /= 0 then

            return False;

         end if;

         declare

            Block_Number : constant Integer_Address :=

                             Int_Storage /  Memory_Chunk_Size;

            Ptr          : constant Validity_Bits_Ref :=

                             Validy_Htable.Get (Block_Number);

            Offset       : constant Integer_Address :=

                             (Int_Storage -

                               (Block_Number * Memory_Chunk_Size)) /

                                  Default_Alignment;

            Bit          : constant Byte :=

                             2 ** Natural (Offset mod System.Storage_Unit);

         begin

            if Ptr = No_Validity_Bits then

               return False;

            else

               return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0;

            end if;

         end;

      end Is_Valid;

      ---------------

      -- Set_Valid --

      ---------------

      procedure Set_Valid (Storage : System.Address; Value : Boolean) is

         Int_Storage  : constant Integer_Address := To_Integer (Storage);

         Block_Number : constant Integer_Address :=

                          Int_Storage /  Memory_Chunk_Size;

         Ptr          : Validity_Bits_Ref := Validy_Htable.Get (Block_Number);

         Offset       : constant Integer_Address :=

                          (Int_Storage - (Block_Number * Memory_Chunk_Size)) /

                             Default_Alignment;

         Bit          : constant Byte :=

                          2 ** Natural (Offset mod System.Storage_Unit);

      begin

         if Ptr = No_Validity_Bits then

            --  First time in this memory area: allocate a new block and put

            --  it in the table.

            if Value then

               Ptr := 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;

            end if;

         else

            if Value then

               Ptr (Offset / System.Storage_Unit) :=

                 Ptr (Offset / System.Storage_Unit) or Bit;

            else

               Ptr (Offset / System.Storage_Unit) :=

                 Ptr (Offset / System.Storage_Unit) and (not Bit);

            end if;

         end if;

      end Set_Valid;

   end Validity;

   --------------

   -- Allocate --

   --------------

   procedure Allocate

     (Pool                     : in out Debug_Pool;

      Storage_Address          : out Address;

      Size_In_Storage_Elements : Storage_Count;

      Alignment                : Storage_Count)

   is

      pragma Unreferenced (Alignment);

      --  Ignored, we always force 'Default_Alignment

      type Local_Storage_Array is new Storage_Array

        (1 .. Size_In_Storage_Elements + Minimum_Allocation);

      type Ptr is access Local_Storage_Array;

      --  On some systems, we might want to physically protect pages against

      --  writing when they have been freed (of course, this is expensive in

      --  terms of wasted memory). To do that, all we should have to do it to

      --  set the size of this array to the page size. See mprotect().

      P : Ptr;

      Current : Byte_Count;

      Trace   : Traceback_Htable_Elem_Ptr;

   begin

      <<Allocate_Label>>

      Lock_Task.all;

      --  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

      --  that deallocates a big array). If we were doing that in Deallocate,

      --  we might be physically freeing memory several times during the loop,

      --  which is expensive.

      if Pool.Logically_Deallocated >

        Byte_Count (Pool.Maximum_Logically_Freed_Memory)

      then

         Free_Physically (Pool);

      end if;

      --  Use standard (i.e. through malloc) allocations. This automatically

      --  raises Storage_Error if needed. We also try once more to physically

      --  release memory, so that even marked blocks, in the advanced scanning,

      --  are freed.

      begin

         P := new Local_Storage_Array;

      exception

         when Storage_Error =>

            Free_Physically (Pool);

            P := new Local_Storage_Array;

      end;

      Storage_Address :=

        To_Address

          (Default_Alignment *

             ((To_Integer (P.all'Address) + Default_Alignment - 1)

               / Default_Alignment)

           + Integer_Address (Header_Offset));

      --  Computation is done in Integer_Address, not Storage_Offset, because

      --  the range of Storage_Offset may not be large enough.

      pragma Assert ((Storage_Address - System.Null_Address)

                     mod Default_Alignment = 0);

      pragma Assert (Storage_Address + Size_In_Storage_Elements

                     <= P.all'Address + P'Length);

      Trace := Find_Or_Create_Traceback

        (Pool, Alloc, Size_In_Storage_Elements,

         Allocate_Label'Address, Code_Address_For_Allocate_End);

      pragma Warnings (Off);

      --  Turn warning on alignment for convert call off. We know that in fact

      --  this conversion is safe since P itself is always aligned on

      --  Default_Alignment.

      Header_Of (Storage_Address).all :=

        (Allocation_Address => P.all'Address,

         Alloc_Traceback    => Trace,

         Dealloc_Traceback  => To_Traceback (null),

         Next               => Pool.First_Used_Block,

         Block_Size         => Size_In_Storage_Elements);

      pragma Warnings (On);

      --  Link this block in the list of used blocks. This will be used to list

      --  memory leaks in Print_Info, and for the advanced schemes of

      --  Physical_Free, where we want to traverse all allocated blocks and

      --  search for possible references.

      --  We insert in front, since most likely we'll be freeing the most

      --  recently allocated blocks first (the older one might stay allocated

      --  for the whole life of the application).

      if Pool.First_Used_Block /= System.Null_Address then

         Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=

           To_Address (Storage_Address);

      end if;

      Pool.First_Used_Block := Storage_Address;

      --  Mark the new address as valid

      Set_Valid (Storage_Address, True);

      if Pool.Low_Level_Traces then

         Put (Output_File (Pool),

              "info: Allocated"

                & Storage_Count'Image (Size_In_Storage_Elements)

                & " bytes at 0x" & Address_Image (Storage_Address)

                & " (physically:"

                & Storage_Count'Image (Local_Storage_Array'Length)

                & " bytes at 0x" & Address_Image (P.all'Address)

                & "), at ");

         Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,

                   Allocate_Label'Address,

                   Code_Address_For_Deallocate_End);

      end if;

      --  Update internal data

      Pool.Allocated :=

        Pool.Allocated + Byte_Count (Size_In_Storage_Elements);

      Current := Pool.Allocated -

                   Pool.Logically_Deallocated -

                     Pool.Physically_Deallocated;

      if Current > Pool.High_Water then

         Pool.High_Water := Current;

      end if;

      Unlock_Task.all;

   exception