gcc/ada/g-debpoo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       G N A T . D E B U G _ P O O L S                    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions.Traceback;
  35 with GNAT.IO; use GNAT.IO;
  36
  37 with System.Address_Image;
  38 with System.Memory;     use System.Memory;
  39 with System.Soft_Links; use System.Soft_Links;
  40
  41 with System.Traceback_Entries; use System.Traceback_Entries;
  42
  43 with GNAT.HTable;
  44 with GNAT.Traceback; use GNAT.Traceback;
  45
  46 with Ada.Unchecked_Conversion;
  47
  48 package body GNAT.Debug_Pools is
  49    use System;
  50    use System.Storage_Elements;
  51
  52    Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment;
  53    --  Alignment used for the memory chunks returned by Allocate. Using this
  54    --  value garantees that this alignment will be compatible with all types
  55    --  and at the same time makes it easy to find the location of the extra
  56    --  header allocated for each chunk.
  57
  58    Initial_Memory_Size : constant Storage_Offset := 2 ** 26; --  64 Mb
  59    --  Initial size of memory that the debug pool can handle. This is used to
  60    --  compute the size of the htable used to monitor the blocks, but this is
  61    --  dynamic and will grow as needed. Having a bigger size here means a
  62    --  longer setup time, but less time spent later on to grow the array.
  63
  64    Max_Ignored_Levels : constant Natural := 10;
  65    --  Maximum number of levels that will be ignored in backtraces. This is so
  66    --  that we still have enough significant levels in the tracebacks returned
  67    --  to the user.
  68    --  The value 10 is chosen as being greater than the maximum callgraph
  69    --  in this package. Its actual value is not really relevant, as long as it
  70    --  is high enough to make sure we still have enough frames to return to
  71    --  the user after we have hidden the frames internal to this package.
  72
  73    -----------------------
  74    -- Tracebacks_Htable --
  75    -----------------------
  76
  77    --  This package needs to store one set of tracebacks for each allocation
  78    --  point (when was it allocated or deallocated). This would use too much
  79    --  memory,  so the tracebacks are actually stored in a hash table, and
  80    --  we reference elements in this hash table instead.
  81
  82    --  This hash-table will remain empty if the discriminant Stack_Trace_Depth
  83    --  for the pools is set to 0.
  84
  85    --  This table is a global table, that can be shared among all debug pools
  86    --  with no problems.
  87
  88    type Header is range 1 .. 1023;
  89    --  Number of elements in the hash-table
  90
  91    type Tracebacks_Array_Access
  92       is access GNAT.Traceback.Tracebacks_Array;
  93
  94    type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);
  95
  96    type Traceback_Htable_Elem;
  97    type Traceback_Htable_Elem_Ptr
  98       is access Traceback_Htable_Elem;
  99
 100    type Traceback_Htable_Elem is record
 101       Traceback : Tracebacks_Array_Access;
 102       Kind      : Traceback_Kind;
 103       Count     : Natural;
 104       Total     : Byte_Count;
 105       Next      : Traceback_Htable_Elem_Ptr;
 106    end record;
 107
 108    procedure Set_Next
 109      (E    : Traceback_Htable_Elem_Ptr;
 110       Next : Traceback_Htable_Elem_Ptr);
 111    function Next
 112      (E    : Traceback_Htable_Elem_Ptr)
 113       return Traceback_Htable_Elem_Ptr;
 114    function Get_Key
 115      (E    : Traceback_Htable_Elem_Ptr)
 116       return Tracebacks_Array_Access;
 117    function Hash (T : Tracebacks_Array_Access) return Header;
 118    function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
 119    pragma Inline (Set_Next, Next, Get_Key, Hash);
 120    --  Subprograms required for instantiation of the htable. See GNAT.HTable.
 121
 122    package Backtrace_Htable is new GNAT.HTable.Static_HTable
 123      (Header_Num => Header,
 124       Element    => Traceback_Htable_Elem,
 125       Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
 126       Null_Ptr   => null,
 127       Set_Next   => Set_Next,
 128       Next       => Next,
 129       Key        => Tracebacks_Array_Access,
 130       Get_Key    => Get_Key,
 131       Hash       => Hash,
 132       Equal      => Equal);
 133
 134    -----------------------
 135    -- Allocations table --
 136    -----------------------
 137
 138    type Allocation_Header;
 139    type Allocation_Header_Access is access Allocation_Header;
 140
 141    --  The following record stores extra information that needs to be
 142    --  memorized for each block allocated with the special debug pool.
 143
 144    type Traceback_Ptr_Or_Address is new System.Address;
 145    --  A type that acts as a C union, and is either a System.Address or a
 146    --  Traceback_Htable_Elem_Ptr.
 147
 148    type Allocation_Header is record
 149       Allocation_Address : System.Address;
 150       --  Address of the block returned by malloc, possibly unaligned.
 151
 152       Block_Size    : Storage_Offset;
 153       --  Needed only for advanced freeing algorithms (traverse all allocated
 154       --  blocks for potential references). This value is negated when the
 155       --  chunk of memory has been logically freed by the application. This
 156       --  chunk has not been physically released yet.
 157
 158       Alloc_Traceback   : Traceback_Htable_Elem_Ptr;
 159       Dealloc_Traceback : Traceback_Ptr_Or_Address;
 160       --  Pointer to the traceback for the allocation (if the memory chunk is
 161       --  still valid), or to the first deallocation otherwise. Make sure this
 162       --  is a thin pointer to save space.
 163       --
 164       --  Dealloc_Traceback is also for blocks that are still allocated to
 165       --  point to the previous block in the list. This saves space in this
 166       --  header, and make manipulation of the lists of allocated pointers
 167       --  faster.
 168
 169       Next : System.Address;
 170       --  Point to the next block of the same type (either allocated or
 171       --  logically freed) in memory. This points to the beginning of the user
 172       --  data, and does not include the header of that block.
 173    end record;
 174
 175    function Header_Of (Address : System.Address)
 176       return Allocation_Header_Access;
 177    pragma Inline (Header_Of);
 178    --  Return the header corresponding to a previously allocated address
 179
 180    function To_Address is new Ada.Unchecked_Conversion
 181      (Traceback_Ptr_Or_Address, System.Address);
 182    function To_Address is new Ada.Unchecked_Conversion
 183      (System.Address, Traceback_Ptr_Or_Address);
 184    function To_Traceback is new Ada.Unchecked_Conversion
 185      (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);
 186    function To_Traceback is new Ada.Unchecked_Conversion
 187      (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
 188
 189    Header_Offset : constant Storage_Count
 190      := Default_Alignment *
 191      ((Allocation_Header'Size / System.Storage_Unit + Default_Alignment - 1)
 192       / Default_Alignment);
 193    --  Offset of user data after allocation header.
 194
 195    Minimum_Allocation : constant Storage_Count :=
 196      Default_Alignment - 1
 197      + Header_Offset;
 198    --  Minimal allocation: size of allocation_header rounded up to next
 199    --  multiple of default alignment + worst-case padding.
 200
 201    -----------------------
 202    -- Allocations table --
 203    -----------------------
 204
 205    --  This table is indexed on addresses modulo Default_Alignment, and
 206    --  for each index it indicates whether that memory block is valid.
 207    --  Its behavior is similar to GNAT.Table, except that we need to pack
 208    --  the table to save space, so we cannot reuse GNAT.Table as is.
 209
 210    --  This table is the reason why all alignments have to be forced to a
 211    --  common value (Default_Alignment), so that this table can be
 212    --  kept to a reasonnable size.
 213
 214    type Byte is mod 2 ** System.Storage_Unit;
 215
 216    Big_Table_Size : constant Storage_Offset :=
 217                       (Storage_Offset'Last - 1) / Default_Alignment;
 218    type Big_Table is array (0 .. Big_Table_Size) of Byte;
 219    --  A simple, flat-array type used to access memory bytes (see the comment
 220    --  for Valid_Blocks below).
 221    --
 222    --  It would be cleaner to represent this as a packed array of Boolean.
 223    --  However, we cannot specify pragma Pack for such an array, since the
 224    --  total size on a 64 bit machine would be too big (> Integer'Last).
 225    --
 226    --  Given an address, we know if it is under control of the debug pool if
 227    --  the byte at index:
 228    --       ((Address - Edata'Address) / Default_Alignment)
 229    --        / Storage_unit
 230    --  has the bit
 231    --       ((Address - Edata'Address) / Default_Alignment)
 232    --        mod Storage_Unit
 233    --  set to 1.
 234    --
 235    --  See the subprograms Is_Valid and Set_Valid for proper manipulation of
 236    --  this array.
 237
 238    type Table_Ptr is access Big_Table;
 239    function To_Pointer is new Ada.Unchecked_Conversion
 240      (System.Address, Table_Ptr);
 241
 242    Valid_Blocks      : Table_Ptr      := null;
 243    Valid_Blocks_Size : Storage_Offset := 0;
 244    --  These two variables represents a mapping of the currently allocated
 245    --  memory. Every time the pool works on an address, we first check that the
 246    --  index Address / Default_Alignment is True. If not, this means that this
 247    --  address is not under control of the debug pool, and thus this is
 248    --  probably an invalid memory access (it could also be a general access
 249    --  type).
 250    --
 251    --  Note that in fact we never allocate the full size of Big_Table, only a
 252    --  slice big enough to manage the currently allocated memory.
 253
 254    Edata  : System.Address := System.Null_Address;
 255    --  Address in memory that matches the index 0 in Valid_Blocks. It is named
 256    --  after the symbol _edata, which, on most systems, indicate the lowest
 257    --  possible address returned by malloc. Unfortunately, this symbol
 258    --  doesn't exist on windows, so we cannot use it instead of this variable.
 259
 260    -----------------------
 261    -- Local subprograms --
 262    -----------------------
 263
 264    function Find_Or_Create_Traceback
 265      (Pool                : Debug_Pool;
 266       Kind                : Traceback_Kind;
 267       Size                : Storage_Count;
 268       Ignored_Frame_Start : System.Address;
 269       Ignored_Frame_End   : System.Address)
 270       return                Traceback_Htable_Elem_Ptr;
 271    --  Return an element matching the current traceback (omitting the frames
 272    --  that are in the current package). If this traceback already existed in
 273    --  the htable, a pointer to this is returned to spare memory. Null is
 274    --  returned if the pool is set not to store tracebacks. If the traceback
 275    --  already existed in the table, the count is incremented so that
 276    --  Dump_Tracebacks returns useful results.
 277    --  All addresses up to, and including, an address between
 278    --  Ignored_Frame_Start .. Ignored_Frame_End are ignored.
 279
 280    procedure Put_Line
 281      (Depth               : Natural;
 282       Traceback           : Tracebacks_Array_Access;
 283       Ignored_Frame_Start : System.Address := System.Null_Address;
 284       Ignored_Frame_End   : System.Address := System.Null_Address);
 285    --  Print Traceback to Standard_Output. If Traceback is null, print the
 286    --  call_chain at the current location, up to Depth levels, ignoring all
 287    --  addresses up to the first one in the range
 288    --  Ignored_Frame_Start .. Ignored_Frame_End
 289
 290    function Is_Valid (Storage : System.Address) return Boolean;
 291    pragma Inline (Is_Valid);
 292    --  Return True if Storage is an address that the debug pool has under its
 293    --  control.
 294
 295    procedure Set_Valid (Storage : System.Address; Value : Boolean);
 296    pragma Inline (Set_Valid);
 297    --  Mark the address Storage as being under control of the memory pool (if
 298    --  Value is True), or not (if Value is False). This procedure will
 299    --  reallocate the table Valid_Blocks as needed.
 300
 301    procedure Set_Dead_Beef
 302      (Storage_Address          : System.Address;
 303       Size_In_Storage_Elements : Storage_Count);
 304    --  Set the contents of the memory block pointed to by Storage_Address to
 305    --  the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
 306    --  of the length of this pattern, the last instance may be partial.
 307
 308    procedure Free_Physically (Pool : in out Debug_Pool);
 309    --  Start to physically release some memory to the system, until the amount
 310    --  of logically (but not physically) freed memory is lower than the
 311    --  expected amount in Pool.
 312
 313    procedure Allocate_End;
 314    procedure Deallocate_End;
 315    procedure Dereference_End;
 316    --  These procedures are used as markers when computing the stacktraces,
 317    --  so that addresses in the debug pool itself are not reported to the user.
 318
 319    Code_Address_For_Allocate_End    : System.Address;
 320    Code_Address_For_Deallocate_End  : System.Address;
 321    Code_Address_For_Dereference_End : System.Address;
 322    --  Taking the address of the above procedures will not work on some
 323    --  architectures (HPUX and VMS for instance). Thus we do the same thing
 324    --  that is done in a-except.adb, and get the address of labels instead
 325
 326    procedure Skip_Levels
 327      (Depth               : Natural;
 328       Trace               : Tracebacks_Array;
 329       Start               : out Natural;
 330       Len                 : in out Natural;
 331       Ignored_Frame_Start : System.Address;
 332       Ignored_Frame_End   : System.Address);
 333    --  Set Start .. Len to the range of values from Trace that should be output
 334    --  to the user. This range of values exludes any address prior to the first
 335    --  one in Ignored_Frame_Start .. Ignored_Frame_End (basically addresses
 336    --  internal to this package). Depth is the number of levels that the user
 337    --  is interested in.
 338
 339    ---------------
 340    -- Header_Of --
 341    ---------------
 342
 343    function Header_Of (Address : System.Address)
 344       return Allocation_Header_Access
 345    is
 346       function Convert is new Ada.Unchecked_Conversion
 347         (System.Address, Allocation_Header_Access);
 348    begin
 349       return Convert (Address - Header_Offset);
 350    end Header_Of;
 351
 352    --------------
 353    -- Set_Next --
 354    --------------
 355
 356    procedure Set_Next
 357      (E    : Traceback_Htable_Elem_Ptr;
 358       Next : Traceback_Htable_Elem_Ptr)
 359    is
 360    begin
 361       E.Next := Next;
 362    end Set_Next;
 363
 364    ----------
 365    -- Next --
 366    ----------
 367
 368    function Next
 369      (E    : Traceback_Htable_Elem_Ptr)
 370       return Traceback_Htable_Elem_Ptr
 371    is
 372    begin
 373       return E.Next;
 374    end Next;
 375
 376    -----------
 377    -- Equal --
 378    -----------
 379
 380    function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
 381       use Ada.Exceptions.Traceback;
 382    begin
 383       return K1.all = K2.all;
 384    end Equal;
 385
 386    -------------
 387    -- Get_Key --
 388    -------------
 389
 390    function Get_Key
 391      (E    : Traceback_Htable_Elem_Ptr)
 392       return Tracebacks_Array_Access
 393    is
 394    begin
 395       return E.Traceback;
 396    end Get_Key;
 397
 398    ----------
 399    -- Hash --
 400    ----------
 401
 402    function Hash (T : Tracebacks_Array_Access) return Header is
 403       Result : Integer_Address := 0;
 404    begin
 405       for X in T'Range loop
 406          Result := Result + To_Integer (PC_For (T (X)));
 407       end loop;
 408       return Header (1 + Result mod Integer_Address (Header'Last));
 409    end Hash;
 410
 411    --------------
 412    -- Put_Line --
 413    --------------
 414
 415    procedure Put_Line
 416      (Depth               : Natural;
 417       Traceback           : Tracebacks_Array_Access;
 418       Ignored_Frame_Start : System.Address := System.Null_Address;
 419       Ignored_Frame_End   : System.Address := System.Null_Address)
 420    is
 421       procedure Print (Tr : Tracebacks_Array);
 422       --  Print the traceback to standard_output
 423
 424       -----------
 425       -- Print --
 426       -----------
 427
 428       procedure Print (Tr : Tracebacks_Array) is
 429       begin
 430          for J in Tr'Range loop
 431             Put ("0x" & Address_Image (PC_For (Tr (J))) & ' ');
 432          end loop;
 433          Put (ASCII.LF);
 434       end Print;
 435
 436    --  Start of processing for Put_Line
 437
 438    begin
 439       if Traceback = null then
 440          declare
 441             Tr  : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
 442             Start, Len : Natural;
 443
 444          begin
 445             Call_Chain (Tr, Len);
 446             Skip_Levels (Depth, Tr, Start, Len,
 447                          Ignored_Frame_Start, Ignored_Frame_End);
 448             Print (Tr (Start .. Len));
 449          end;
 450
 451       else
 452          Print (Traceback.all);
 453       end if;
 454    end Put_Line;
 455
 456    -----------------
 457    -- Skip_Levels --
 458    -----------------
 459
 460    procedure Skip_Levels
 461      (Depth               : Natural;
 462       Trace               : Tracebacks_Array;
 463       Start               : out Natural;
 464       Len                 : in out Natural;
 465       Ignored_Frame_Start : System.Address;
 466       Ignored_Frame_End   : System.Address)
 467    is
 468    begin
 469       Start := Trace'First;
 470
 471       while Start <= Len
 472         and then (PC_For (Trace (Start)) < Ignored_Frame_Start
 473                     or else PC_For (Trace (Start)) > Ignored_Frame_End)
 474       loop
 475          Start := Start + 1;
 476       end loop;
 477
 478       Start := Start + 1;
 479
 480       --  Just in case: make sure we have a traceback even if Ignore_Till
 481       --  wasn't found.
 482
 483       if Start > Len then
 484          Start := 1;
 485       end if;
 486
 487       if Len - Start + 1 > Depth then
 488          Len := Depth + Start - 1;
 489       end if;
 490    end Skip_Levels;
 491
 492    ------------------------------
 493    -- Find_Or_Create_Traceback --
 494    ------------------------------
 495
 496    function Find_Or_Create_Traceback
 497      (Pool                : Debug_Pool;
 498       Kind                : Traceback_Kind;
 499       Size                : Storage_Count;
 500       Ignored_Frame_Start : System.Address;
 501       Ignored_Frame_End   : System.Address)
 502       return                Traceback_Htable_Elem_Ptr
 503    is
 504    begin
 505       if Pool.Stack_Trace_Depth = 0 then
 506          return null;
 507       end if;
 508
 509       declare
 510          Trace : aliased Tracebacks_Array
 511                   (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
 512          Len, Start   : Natural;
 513          Elem  : Traceback_Htable_Elem_Ptr;
 514
 515       begin
 516          Call_Chain (Trace, Len);
 517          Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
 518                       Ignored_Frame_Start, Ignored_Frame_End);
 519
 520          --  Check if the traceback is already in the table.
 521
 522          Elem :=
 523            Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
 524
 525          --  If not, insert it
 526
 527          if Elem = null then
 528             Elem := new Traceback_Htable_Elem'
 529               (Traceback => new Tracebacks_Array'(Trace (Start .. Len)),
 530                Count     => 1,
 531                Kind      => Kind,
 532                Total     => Byte_Count (Size),
 533                Next      => null);
 534             Backtrace_Htable.Set (Elem);
 535
 536          else
 537             Elem.Count := Elem.Count + 1;
 538             Elem.Total := Elem.Total + Byte_Count (Size);
 539          end if;
 540
 541          return Elem;
 542       end;
 543    end Find_Or_Create_Traceback;
 544
 545    --------------
 546    -- Is_Valid --
 547    --------------
 548
 549    function Is_Valid (Storage : System.Address) return Boolean is
 550       Offset : constant Storage_Offset :=
 551                  (Storage - Edata) / Default_Alignment;
 552
 553       Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit);
 554
 555    begin
 556       return (Storage mod Default_Alignment) = 0
 557         and then Offset >= 0
 558         and then Offset < Valid_Blocks_Size * Storage_Unit
 559         and then (Valid_Blocks (Offset / Storage_Unit) and Bit) /= 0;
 560    end Is_Valid;
 561
 562    ---------------
 563    -- Set_Valid --
 564    ---------------
 565
 566    procedure Set_Valid (Storage : System.Address; Value : Boolean) is
 567       Offset : Storage_Offset;
 568       Bit    : Byte;
 569       Bytes  : Storage_Offset;
 570       Tmp    : constant Table_Ptr := Valid_Blocks;
 571
 572       Edata_Align : constant Storage_Offset :=
 573                       Default_Alignment * Storage_Unit;
 574
 575       procedure Memset (A : Address; C : Integer; N : size_t);
 576       pragma Import (C, Memset, "memset");
 577
 578       procedure Memmove (Dest, Src : Address; N : size_t);
 579       pragma Import (C, Memmove, "memmove");
 580
 581    begin
 582       --  Allocate, or reallocate, the valid blocks table as needed. We start
 583       --  with a size big enough to handle Initial_Memory_Size bytes of memory,
 584       --  to avoid too many reallocations. The table will typically be around
 585       --  16Mb in that case, which is still small enough.
 586
 587       if Valid_Blocks_Size = 0 then
 588          Valid_Blocks_Size := (Initial_Memory_Size / Default_Alignment)
 589                                                       / Storage_Unit;
 590          Valid_Blocks := To_Pointer (Alloc (size_t (Valid_Blocks_Size)));
 591          Edata := Storage;
 592
 593          --  Reset the memory using memset, which is much faster than the
 594          --  standard Ada code with "when others"
 595
 596          Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size));
 597       end if;
 598
 599       --  First case : the new address is outside of the current scope of
 600       --  Valid_Blocks, before the current start address. We need to reallocate
 601       --  the table accordingly. This should be a rare occurence, since in most
 602       --  cases, the first allocation will also have the lowest address. But
 603       --  there is no garantee...
 604
 605       if Storage < Edata then
 606
 607          --  The difference between the new Edata and the current one must be
 608          --  a multiple of Default_Alignment * Storage_Unit, so that the bit
 609          --  representing an address in Valid_Blocks are kept the same.
 610
 611          Offset := ((Edata - Storage) / Edata_Align + 1) * Edata_Align;
 612          Offset := Offset / Default_Alignment;
 613          Bytes  := Offset / Storage_Unit;
 614          Valid_Blocks :=
 615            To_Pointer (Alloc (Size => size_t (Valid_Blocks_Size + Bytes)));
 616          Memmove (Dest => Valid_Blocks.all'Address + Bytes,
 617                   Src  => Tmp.all'Address,
 618                   N    => size_t (Valid_Blocks_Size));
 619          Memset (A => Valid_Blocks.all'Address,
 620                  C => 0,
 621                  N => size_t (Bytes));
 622          Free (Tmp.all'Address);
 623          Valid_Blocks_Size := Valid_Blocks_Size + Bytes;
 624
 625          --  Take into the account the new start address
 626          Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align;
 627       end if;
 628
 629       --  Second case : the new address is outside of the current scope of
 630       --  Valid_Blocks, so we have to grow the table as appropriate
 631
 632       Offset := (Storage - Edata) / Default_Alignment;
 633
 634       if Offset >= Valid_Blocks_Size * System.Storage_Unit then
 635          Bytes := Valid_Blocks_Size;
 636          loop
 637             Bytes := 2 * Bytes;
 638             exit when Offset <= Bytes * System.Storage_Unit;
 639          end loop;
 640
 641          Valid_Blocks := To_Pointer
 642            (Realloc (Ptr  => Valid_Blocks.all'Address,
 643                      Size => size_t (Bytes)));
 644          Memset
 645            (Valid_Blocks.all'Address + Valid_Blocks_Size,
 646             0,
 647             size_t (Bytes - Valid_Blocks_Size));
 648          Valid_Blocks_Size := Bytes;
 649       end if;
 650
 651       Bit    := 2 ** Natural (Offset mod System.Storage_Unit);
 652       Bytes  := Offset / Storage_Unit;
 653
 654       --  Then set the value as valid
 655
 656       if Value then
 657          Valid_Blocks (Bytes) := Valid_Blocks (Bytes) or Bit;
 658       else
 659          Valid_Blocks (Bytes) := Valid_Blocks (Bytes) and (not Bit);
 660       end if;
 661    end Set_Valid;
 662
 663    --------------
 664    -- Allocate --
 665    --------------
 666
 667    procedure Allocate
 668      (Pool                     : in out Debug_Pool;
 669       Storage_Address          : out Address;
 670       Size_In_Storage_Elements : Storage_Count;
 671       Alignment                : Storage_Count)
 672    is
 673       pragma Unreferenced (Alignment);
 674       --  Ignored, we always force 'Default_Alignment
 675
 676       type Local_Storage_Array is new Storage_Array
 677         (1 .. Size_In_Storage_Elements + Minimum_Allocation);
 678
 679       type Ptr is access Local_Storage_Array;
 680       --  On some systems, we might want to physically protect pages
 681       --  against writing when they have been freed (of course, this is
 682       --  expensive in terms of wasted memory). To do that, all we should
 683       --  have to do it to set the size of this array to the page size.
 684       --  See mprotect().
 685
 686       P : Ptr;
 687
 688       Current : Byte_Count;
 689       Trace   : Traceback_Htable_Elem_Ptr;
 690
 691    begin
 692       <<Allocate_Label>>
 693       Lock_Task.all;
 694
 695       --  If necessary, start physically releasing memory. The reason this is
 696       --  done here, although Pool.Logically_Deallocated has not changed above,
 697       --  is so that we do this only after a series of deallocations (e.g a
 698       --  loop that deallocates a big array). If we were doing that in
 699       --  Deallocate, we might be physically freeing memory several times
 700       --  during the loop, which is expensive.
 701
 702       if Pool.Logically_Deallocated >
 703         Byte_Count (Pool.Maximum_Logically_Freed_Memory)
 704       then
 705          Free_Physically (Pool);
 706       end if;
 707
 708       --  Use standard (ie through malloc) allocations. This automatically
 709       --  raises Storage_Error if needed. We also try once more to physically
 710       --  release memory, so that even marked blocks, in the advanced scanning,
 711       --  are freed.
 712
 713       begin
 714          P := new Local_Storage_Array;
 715
 716       exception
 717          when Storage_Error =>
 718             Free_Physically (Pool);
 719             P := new Local_Storage_Array;
 720       end;
 721
 722       Storage_Address := System.Null_Address + Default_Alignment
 723         * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
 724            / Default_Alignment)
 725         + Header_Offset;
 726       pragma Assert ((Storage_Address - System.Null_Address)
 727                      mod Default_Alignment = 0);
 728       pragma Assert (Storage_Address + Size_In_Storage_Elements
 729                      <= P.all'Address + P'Length);
 730
 731       Trace := Find_Or_Create_Traceback
 732         (Pool, Alloc, Size_In_Storage_Elements,
 733          Allocate_Label'Address, Code_Address_For_Allocate_End);
 734
 735       pragma Warnings (Off);
 736       --  Turn warning on alignment for convert call off. We know that in
 737       --  fact this conversion is safe since P itself is always aligned on
 738       --  Default_Alignment.
 739
 740       Header_Of (Storage_Address).all :=
 741         (Allocation_Address => P.all'Address,
 742          Alloc_Traceback    => Trace,
 743          Dealloc_Traceback  => To_Traceback (null),
 744          Next               => Pool.First_Used_Block,
 745          Block_Size         => Size_In_Storage_Elements);
 746
 747       pragma Warnings (On);
 748
 749       --  Link this block in the list of used blocks. This will be used to list
 750       --  memory leaks in Print_Info, and for the advanced schemes of
 751       --  Physical_Free, where we want to traverse all allocated blocks and
 752       --  search for possible references.
 753
 754       --  We insert in front, since most likely we'll be freeing the most
 755       --  recently allocated blocks first (the older one might stay allocated
 756       --  for the whole life of the application).
 757
 758       if Pool.First_Used_Block /= System.Null_Address then
 759          Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
 760            To_Address (Storage_Address);
 761       end if;
 762
 763       Pool.First_Used_Block := Storage_Address;
 764
 765       --  Mark the new address as valid
 766
 767       Set_Valid (Storage_Address, True);
 768
 769       --  Update internal data
 770
 771       Pool.Allocated :=
 772         Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
 773
 774       Current := Pool.Allocated -
 775                    Pool.Logically_Deallocated -
 776                      Pool.Physically_Deallocated;
 777
 778       if Current > Pool.High_Water then
 779          Pool.High_Water := Current;
 780       end if;
 781
 782       Unlock_Task.all;
 783
 784    exception
 785       when others =>
 786          Unlock_Task.all;
 787          raise;
 788    end Allocate;
 789
 790    ------------------
 791    -- Allocate_End --
 792    ------------------
 793
 794    --  DO NOT MOVE, this must be right after Allocate. This is similar to
 795    --  what is done in a-except, so that we can hide the traceback frames
 796    --  internal to this package
 797
 798    procedure Allocate_End is
 799    begin
 800       <<Allocate_End_Label>>
 801       Code_Address_For_Allocate_End := Allocate_End_Label'Address;
 802    end Allocate_End;
 803
 804    -------------------
 805    -- Set_Dead_Beef --
 806    -------------------
 807
 808    procedure Set_Dead_Beef
 809      (Storage_Address          : System.Address;
 810       Size_In_Storage_Elements : Storage_Count)
 811    is
 812       Dead_Bytes : constant := 4;
 813
 814       type Data is mod 2 ** (Dead_Bytes * 8);
 815       for Data'Size use Dead_Bytes * 8;
 816
 817       Dead : constant Data := 16#DEAD_BEEF#;
 818
 819       type Dead_Memory is array
 820         (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
 821       type Mem_Ptr is access Dead_Memory;
 822
 823       type Byte is mod 2 ** 8;
 824       for Byte'Size use 8;
 825
 826       type Dead_Memory_Bytes is array (0 .. 2) of Byte;
 827       type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
 828
 829       function From_Ptr is new Ada.Unchecked_Conversion
 830         (System.Address, Mem_Ptr);
 831
 832       function From_Ptr is new Ada.Unchecked_Conversion
 833         (System.Address, Dead_Memory_Bytes_Ptr);
 834
 835       M      : constant Mem_Ptr := From_Ptr (Storage_Address);
 836       M2     : Dead_Memory_Bytes_Ptr;
 837       Modulo : constant Storage_Count :=
 838                  Size_In_Storage_Elements mod Dead_Bytes;
 839    begin
 840       M.all := (others => Dead);
 841
 842       --  Any bytes left (up to three of them)
 843
 844       if Modulo /= 0 then
 845          M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
 846
 847          M2 (0) := 16#DE#;
 848          if Modulo >= 2 then
 849             M2 (1) := 16#AD#;
 850
 851             if Modulo >= 3 then
 852                M2 (2) := 16#BE#;
 853             end if;
 854          end if;
 855       end if;
 856    end Set_Dead_Beef;
 857
 858    ---------------------
 859    -- Free_Physically --
 860    ---------------------
 861
 862    procedure Free_Physically (Pool : in out Debug_Pool) is
 863       type Byte is mod 256;
 864       type Byte_Access is access Byte;
 865
 866       function To_Byte is new Ada.Unchecked_Conversion
 867         (System.Address, Byte_Access);
 868
 869       type Address_Access is access System.Address;
 870
 871       function To_Address_Access is new Ada.Unchecked_Conversion
 872         (System.Address, Address_Access);
 873
 874       In_Use_Mark : constant Byte := 16#D#;
 875       Free_Mark   : constant Byte := 16#F#;
 876
 877       Total_Freed : Storage_Count := 0;
 878
 879       procedure Reset_Marks;
 880       --  Unmark all the logically freed blocks, so that they are considered
 881       --  for physical deallocation
 882
 883       procedure Mark
 884         (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
 885       --  Mark the user data block starting at A. For a block of size zero,
 886       --  nothing is done. For a block with a different size, the first byte
 887       --  is set to either "D" (in use) or "F" (free).
 888
 889       function Marked (A : System.Address) return Boolean;
 890       --  Return true if the user data block starting at A might be in use
 891       --  somewhere else
 892
 893       procedure Mark_Blocks;
 894       --  Traverse all allocated blocks, and search for possible references
 895       --  to logically freed blocks. Mark them appropriately
 896
 897       procedure Free_Blocks (Ignore_Marks : Boolean);
 898       --  Physically release blocks. Only the blocks that haven't been marked
 899       --  will be released, unless Ignore_Marks is true.
 900
 901       -----------------
 902       -- Free_Blocks --
 903       -----------------
 904
 905       procedure Free_Blocks (Ignore_Marks : Boolean) is
 906          Header   : Allocation_Header_Access;
 907          Tmp      : System.Address := Pool.First_Free_Block;
 908          Next     : System.Address;
 909          Previous : System.Address := System.Null_Address;
 910
 911       begin
 912          while Tmp /= System.Null_Address
 913            and then Total_Freed < Pool.Minimum_To_Free
 914          loop
 915             Header := Header_Of (Tmp);
 916
 917             --  If we know, or at least assume, the block is no longer
 918             --  reference anywhere, we can free it physically.
 919
 920             if Ignore_Marks or else not Marked (Tmp) then
 921
 922                declare
 923                   pragma Suppress (All_Checks);
 924                   --  Suppress the checks on this section. If they are overflow
 925                   --  errors, it isn't critical, and we'd rather avoid a
 926                   --  Constraint_Error in that case.
 927                begin
 928                   --  Note that block_size < zero for freed blocks
 929
 930                   Pool.Physically_Deallocated :=
 931                     Pool.Physically_Deallocated -
 932                       Byte_Count (Header.Block_Size);
 933
 934                   Pool.Logically_Deallocated :=
 935                     Pool.Logically_Deallocated +
 936                       Byte_Count (Header.Block_Size);
 937
 938                   Total_Freed := Total_Freed - Header.Block_Size;
 939                end;
 940
 941                Next := Header.Next;
 942                System.Memory.Free (Header.Allocation_Address);
 943                Set_Valid (Tmp, False);
 944
 945                --  Remove this block from the list.
 946
 947                if Previous = System.Null_Address then
 948                   Pool.First_Free_Block := Next;
 949                else
 950                   Header_Of (Previous).Next := Next;
 951                end if;
 952
 953                Tmp  := Next;
 954
 955             else
 956                Previous := Tmp;
 957                Tmp := Header.Next;
 958             end if;
 959          end loop;
 960       end Free_Blocks;
 961
 962       ----------
 963       -- Mark --
 964       ----------
 965
 966       procedure Mark
 967         (H      : Allocation_Header_Access;
 968          A      : System.Address;
 969          In_Use : Boolean)
 970       is
 971       begin
 972          if H.Block_Size /= 0 then
 973             if In_Use then
 974                To_Byte (A).all := In_Use_Mark;
 975             else
 976                To_Byte (A).all := Free_Mark;
 977             end if;
 978          end if;
 979       end Mark;
 980
 981       -----------------
 982       -- Mark_Blocks --
 983       -----------------
 984
 985       procedure Mark_Blocks is
 986          Tmp      : System.Address := Pool.First_Used_Block;
 987          Previous : System.Address;
 988          Last     : System.Address;
 989          Pointed  : System.Address;
 990          Header   : Allocation_Header_Access;
 991
 992       begin
 993          --  For each allocated block, check its contents. Things that look
 994          --  like a possible address are used to mark the blocks so that we try
 995          --  and keep them, for better detection in case of invalid access.
 996          --  This mechanism is far from being fool-proof: it doesn't check the
 997          --  stacks of the threads, doesn't check possible memory allocated not
 998          --  under control of this debug pool. But it should allow us to catch
 999          --  more cases.
1000
1001          while Tmp /= System.Null_Address loop
1002             Previous := Tmp;
1003             Last     := Tmp + Header_Of (Tmp).Block_Size;
1004             while Previous < Last loop
1005                --  ??? Should we move byte-per-byte, or consider that addresses
1006                --  are always aligned on 4-bytes boundaries ? Let's use the
1007                --  fastest for now.
1008
1009                Pointed := To_Address_Access (Previous).all;
1010                if Is_Valid (Pointed) then
1011                   Header := Header_Of (Pointed);
1012
1013                   --  Do not even attempt to mark blocks in use. That would
1014                   --  screw up the whole application, of course.
1015                   if Header.Block_Size < 0 then
1016                      Mark (Header, Pointed, In_Use => True);
1017                   end if;
1018                end if;
1019
1020                Previous := Previous + System.Address'Size;
1021             end loop;
1022
1023             Tmp := Header_Of (Tmp).Next;
1024          end loop;
1025       end Mark_Blocks;
1026
1027       ------------
1028       -- Marked --
1029       ------------
1030
1031       function Marked (A : System.Address) return Boolean is
1032       begin
1033          return To_Byte (A).all = In_Use_Mark;
1034       end Marked;
1035
1036       -----------------
1037       -- Reset_Marks --
1038       -----------------
1039
1040       procedure Reset_Marks is
1041          Current : System.Address := Pool.First_Free_Block;
1042          Header  : Allocation_Header_Access;
1043
1044       begin
1045          while Current /= System.Null_Address loop
1046             Header := Header_Of (Current);
1047             Mark (Header, Current, False);
1048             Current := Header.Next;
1049          end loop;
1050       end Reset_Marks;
1051
1052    --  Start of processing for Free_Physically
1053
1054    begin
1055       Lock_Task.all;
1056
1057       if Pool.Advanced_Scanning then
1058          Reset_Marks; --  Reset the mark for each freed block
1059          Mark_Blocks;
1060       end if;
1061
1062       Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
1063
1064       --  The contract is that we need to free at least Minimum_To_Free bytes,
1065       --  even if this means freeing marked blocks in the advanced scheme
1066
1067       if Total_Freed < Pool.Minimum_To_Free
1068         and then Pool.Advanced_Scanning
1069       then
1070          Pool.Marked_Blocks_Deallocated := True;
1071          Free_Blocks (Ignore_Marks => True);
1072       end if;
1073
1074       Unlock_Task.all;
1075
1076    exception
1077       when others =>
1078          Unlock_Task.all;
1079          raise;
1080    end Free_Physically;
1081
1082    ----------------
1083    -- Deallocate --
1084    ----------------
1085
1086    procedure Deallocate
1087      (Pool                     : in out Debug_Pool;
1088       Storage_Address          : Address;
1089       Size_In_Storage_Elements : Storage_Count;
1090       Alignment                : Storage_Count)
1091    is
1092       pragma Unreferenced (Alignment);
1093
1094       Header   : constant Allocation_Header_Access :=
1095         Header_Of (Storage_Address);
1096       Valid    : Boolean;
1097       Previous : System.Address;
1098
1099    begin
1100       <<Deallocate_Label>>
1101       Lock_Task.all;
1102       Valid := Is_Valid (Storage_Address);
1103
1104       if not Valid then
1105          Unlock_Task.all;
1106          if Pool.Raise_Exceptions then
1107             raise Freeing_Not_Allocated_Storage;
1108          else
1109             Put ("error: Freeing not allocated storage, at ");
1110             Put_Line (Pool.Stack_Trace_Depth, null,
1111                       Deallocate_Label'Address,
1112                       Code_Address_For_Deallocate_End);
1113          end if;
1114
1115       elsif Header.Block_Size < 0 then
1116          Unlock_Task.all;
1117          if Pool.Raise_Exceptions then
1118             raise Freeing_Deallocated_Storage;
1119          else
1120             Put ("error: Freeing already deallocated storage, at ");
1121             Put_Line (Pool.Stack_Trace_Depth, null,
1122                       Deallocate_Label'Address,
1123                       Code_Address_For_Deallocate_End);
1124             Put ("   Memory already deallocated at ");
1125             Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
1126          end if;
1127
1128       else
1129          --  Remove this block from the list of used blocks.
1130
1131          Previous :=
1132            To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
1133
1134          if Previous = System.Null_Address then
1135             Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
1136
1137             if Pool.First_Used_Block /= System.Null_Address then
1138                Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
1139                  To_Traceback (null);
1140             end if;
1141
1142          else
1143             Header_Of (Previous).Next := Header_Of (Storage_Address).Next;
1144
1145             if Header_Of (Storage_Address).Next /= System.Null_Address then
1146                Header_Of
1147                  (Header_Of (Storage_Address).Next).Dealloc_Traceback :=
1148                     To_Address (Previous);
1149             end if;
1150          end if;
1151
1152          --  Update the header
1153
1154          Header.all :=
1155            (Allocation_Address => Header.Allocation_Address,
1156             Alloc_Traceback    => Header.Alloc_Traceback,
1157             Dealloc_Traceback  => To_Traceback
1158                                     (Find_Or_Create_Traceback
1159                                        (Pool, Dealloc,
1160                                         Size_In_Storage_Elements,
1161                                         Deallocate_Label'Address,
1162                                         Code_Address_For_Deallocate_End)),
1163             Next               => System.Null_Address,
1164             Block_Size         => -Size_In_Storage_Elements);
1165
1166          if Pool.Reset_Content_On_Free then
1167             Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
1168          end if;
1169
1170          Pool.Logically_Deallocated :=
1171            Pool.Logically_Deallocated +
1172              Byte_Count (Size_In_Storage_Elements);
1173
1174          --  Link this free block with the others (at the end of the list, so
1175          --  that we can start releasing the older blocks first later on).
1176
1177          if Pool.First_Free_Block = System.Null_Address then
1178             Pool.First_Free_Block := Storage_Address;
1179             Pool.Last_Free_Block := Storage_Address;
1180
1181          else
1182             Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
1183             Pool.Last_Free_Block := Storage_Address;
1184          end if;
1185
1186          --  Do not physically release the memory here, but in Alloc.
1187          --  See comment there for details.
1188
1189          Unlock_Task.all;
1190       end if;
1191
1192    exception
1193       when others =>
1194          Unlock_Task.all;
1195          raise;
1196    end Deallocate;
1197
1198    --------------------
1199    -- Deallocate_End --
1200    --------------------
1201
1202    --  DO NOT MOVE, this must be right after Deallocate
1203    --  See Allocate_End
1204
1205    procedure Deallocate_End is
1206    begin
1207       <<Deallocate_End_Label>>
1208       Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
1209    end Deallocate_End;
1210
1211    -----------------
1212    -- Dereference --
1213    -----------------
1214
1215    procedure Dereference
1216      (Pool                     : in out Debug_Pool;
1217       Storage_Address          : Address;
1218       Size_In_Storage_Elements : Storage_Count;
1219       Alignment                : Storage_Count)
1220    is
1221       pragma Unreferenced (Alignment, Size_In_Storage_Elements);
1222
1223       Valid   : constant Boolean := Is_Valid (Storage_Address);
1224       Header  : Allocation_Header_Access;
1225
1226    begin
1227       --  Locking policy: we do not do any locking in this procedure. The
1228       --  tables are only read, not written to, and although a problem might
1229       --  appear if someone else is modifying the tables at the same time, this
1230       --  race condition is not intended to be detected by this storage_pool (a
1231       --  now invalid pointer would appear as valid). Instead, we prefer
1232       --  optimum performance for dereferences.
1233
1234       <<Dereference_Label>>
1235
1236       if not Valid then
1237          if Pool.Raise_Exceptions then
1238             raise Accessing_Not_Allocated_Storage;
1239          else
1240             Put ("error: Accessing not allocated storage, at ");
1241             Put_Line (Pool.Stack_Trace_Depth, null,
1242                       Dereference_Label'Address,
1243                       Code_Address_For_Dereference_End);
1244          end if;
1245
1246       else
1247          Header := Header_Of (Storage_Address);
1248
1249          if Header.Block_Size < 0 then
1250             if Pool.Raise_Exceptions then
1251                raise Accessing_Deallocated_Storage;
1252             else
1253                Put ("error: Accessing deallocated storage, at ");
1254                Put_Line
1255                  (Pool.Stack_Trace_Depth, null,
1256                   Dereference_Label'Address,
1257                   Code_Address_For_Dereference_End);
1258                Put ("  First deallocation at ");
1259                Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
1260             end if;
1261          end if;
1262       end if;
1263    end Dereference;
1264
1265    ---------------------
1266    -- Dereference_End --
1267    ---------------------
1268
1269    --  DO NOT MOVE: this must be right after Dereference
1270    --  See Allocate_End
1271
1272    procedure Dereference_End is
1273    begin
1274       <<Dereference_End_Label>>
1275       Code_Address_For_Dereference_End := Dereference_End_Label'Address;
1276    end Dereference_End;
1277
1278    ----------------
1279    -- Print_Info --
1280    ----------------
1281
1282    procedure Print_Info
1283      (Pool          : Debug_Pool;
1284       Cumulate      : Boolean := False;
1285       Display_Slots : Boolean := False;
1286       Display_Leaks : Boolean := False)
1287    is
1288       use System.Storage_Elements;
1289
1290       package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
1291         (Header_Num => Header,
1292          Element    => Traceback_Htable_Elem,
1293          Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
1294          Null_Ptr   => null,
1295          Set_Next   => Set_Next,
1296          Next       => Next,
1297          Key        => Tracebacks_Array_Access,
1298          Get_Key    => Get_Key,
1299          Hash       => Hash,
1300          Equal      => Equal);
1301       --  This needs a comment ??? probably some of the ones below do too???
1302
1303       Data    : Traceback_Htable_Elem_Ptr;
1304       Elem    : Traceback_Htable_Elem_Ptr;
1305       Current : System.Address;
1306       Header  : Allocation_Header_Access;
1307       K       : Traceback_Kind;
1308
1309    begin
1310       Put_Line
1311         ("Total allocated bytes : " &
1312          Byte_Count'Image (Pool.Allocated));
1313
1314       Put_Line
1315         ("Total logically deallocated bytes : " &
1316          Byte_Count'Image (Pool.Logically_Deallocated));
1317
1318       Put_Line
1319         ("Total physically deallocated bytes : " &
1320          Byte_Count'Image (Pool.Physically_Deallocated));
1321
1322       if Pool.Marked_Blocks_Deallocated then
1323          Put_Line ("Marked blocks were physically deallocated. This is");
1324          Put_Line ("potentially dangereous, and you might want to run");
1325          Put_Line ("again with a lower value of Minimum_To_Free");
1326       end if;
1327
1328       Put_Line
1329         ("Current Water Mark: " &
1330          Byte_Count'Image
1331           (Pool.Allocated - Pool.Logically_Deallocated
1332                                    - Pool.Physically_Deallocated));
1333
1334       Put_Line
1335         ("High Water Mark: " &
1336           Byte_Count'Image (Pool.High_Water));
1337
1338       Put_Line ("");
1339
1340       if Display_Slots then
1341          Data := Backtrace_Htable.Get_First;
1342          while Data /= null loop
1343             if Data.Kind in Alloc .. Dealloc then
1344                Elem :=
1345                  new Traceback_Htable_Elem'
1346                       (Traceback => new Tracebacks_Array'(Data.Traceback.all),
1347                        Count     => Data.Count,
1348                        Kind      => Data.Kind,
1349                        Total     => Data.Total,
1350                        Next      => null);
1351                Backtrace_Htable_Cumulate.Set (Elem);
1352
1353                if Cumulate then
1354                   if Data.Kind = Alloc then
1355                      K := Indirect_Alloc;
1356                   else
1357                      K := Indirect_Dealloc;
1358                   end if;
1359
1360                   --  Propagate the direct call to all its parents
1361
1362                   for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
1363                      Elem := Backtrace_Htable_Cumulate.Get
1364                        (Data.Traceback
1365                           (T .. Data.Traceback'Last)'Unrestricted_Access);
1366
1367                      --  If not, insert it
1368
1369                      if Elem = null then
1370                         Elem := new Traceback_Htable_Elem'
1371                           (Traceback => new Tracebacks_Array'
1372                              (Data.Traceback (T .. Data.Traceback'Last)),
1373                            Count     => Data.Count,
1374                            Kind      => K,
1375                            Total     => Data.Total,
1376                            Next      => null);
1377                         Backtrace_Htable_Cumulate.Set (Elem);
1378
1379                         --  Properly take into account that the subprograms
1380                         --  indirectly called might be doing either allocations
1381                         --  or deallocations. This needs to be reflected in the
1382                         --  counts.
1383
1384                      else
1385                         Elem.Count := Elem.Count + Data.Count;
1386
1387                         if K = Elem.Kind then
1388                            Elem.Total := Elem.Total + Data.Total;
1389
1390                         elsif Elem.Total > Data.Total then
1391                            Elem.Total := Elem.Total - Data.Total;
1392
1393                         else
1394                            Elem.Kind  := K;
1395                            Elem.Total := Data.Total - Elem.Total;
1396                         end if;
1397                      end if;
1398                   end loop;
1399                end if;
1400
1401                Data := Backtrace_Htable.Get_Next;
1402             end if;
1403          end loop;
1404
1405          Put_Line ("List of allocations/deallocations: ");
1406
1407          Data := Backtrace_Htable_Cumulate.Get_First;
1408          while Data /= null loop
1409             case Data.Kind is
1410                when Alloc            => Put ("alloc (count:");
1411                when Indirect_Alloc   => Put ("indirect alloc (count:");
1412                when Dealloc          => Put ("free  (count:");
1413                when Indirect_Dealloc => Put ("indirect free  (count:");
1414             end case;
1415
1416             Put (Natural'Image (Data.Count) & ", total:" &
1417                  Byte_Count'Image (Data.Total) & ") ");
1418
1419             for T in Data.Traceback'Range loop
1420                Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
1421             end loop;
1422
1423             Put_Line ("");
1424
1425             Data := Backtrace_Htable_Cumulate.Get_Next;
1426          end loop;
1427
1428          Backtrace_Htable_Cumulate.Reset;
1429       end if;
1430
1431       if Display_Leaks then
1432          Put_Line ("");
1433          Put_Line ("List of not deallocated blocks:");
1434
1435          --  Do not try to group the blocks with the same stack traces
1436          --  together. This is done by the gnatmem output.
1437
1438          Current := Pool.First_Used_Block;
1439          while Current /= System.Null_Address loop
1440             Header := Header_Of (Current);
1441
1442             Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
1443
1444             for T in Header.Alloc_Traceback.Traceback'Range loop
1445                Put ("0x" & Address_Image
1446                       (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
1447             end loop;
1448
1449             Put_Line ("");
1450             Current := Header.Next;
1451          end loop;
1452       end if;
1453    end Print_Info;
1454
1455    ------------------
1456    -- Storage_Size --
1457    ------------------
1458
1459    function Storage_Size (Pool : Debug_Pool) return Storage_Count is
1460       pragma Unreferenced (Pool);
1461
1462    begin
1463       return Storage_Count'Last;
1464    end Storage_Size;
1465
1466    ---------------
1467    -- Configure --
1468    ---------------
1469
1470    procedure Configure
1471      (Pool                           : in out Debug_Pool;
1472       Stack_Trace_Depth              : Natural := Default_Stack_Trace_Depth;
1473       Maximum_Logically_Freed_Memory : SSC     := Default_Max_Freed;
1474       Minimum_To_Free                : SSC     := Default_Min_Freed;
1475       Reset_Content_On_Free          : Boolean := Default_Reset_Content;
1476       Raise_Exceptions               : Boolean := Default_Raise_Exceptions;
1477       Advanced_Scanning              : Boolean := Default_Advanced_Scanning)
1478    is
1479    begin
1480       Pool.Stack_Trace_Depth              := Stack_Trace_Depth;
1481       Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
1482       Pool.Reset_Content_On_Free          := Reset_Content_On_Free;
1483       Pool.Raise_Exceptions               := Raise_Exceptions;
1484       Pool.Minimum_To_Free                := Minimum_To_Free;
1485       Pool.Advanced_Scanning              := Advanced_Scanning;
1486    end Configure;
1487
1488    ----------------
1489    -- Print_Pool --
1490    ----------------
1491
1492    procedure Print_Pool (A : System.Address) is
1493       Storage : constant Address := A;
1494       Valid   : constant Boolean := Is_Valid (Storage);
1495       Header  : Allocation_Header_Access;
1496
1497    begin
1498       --  We might get Null_Address if the call from gdb was done
1499       --  incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
1500       --  instead of passing the value of my_var
1501
1502       if A = System.Null_Address then
1503          Put_Line ("Memory not under control of the storage pool");
1504          return;
1505       end if;
1506
1507       if not Valid then
1508          Put_Line ("Memory not under control of the storage pool");
1509
1510       else
1511          Header := Header_Of (Storage);
1512          Put_Line ("0x" & Address_Image (A)
1513                      & " allocated at:");
1514          Put_Line (0, Header.Alloc_Traceback.Traceback);
1515
1516          if To_Traceback (Header.Dealloc_Traceback) /= null then
1517             Put_Line ("0x" & Address_Image (A)
1518                       & " logically freed memory, deallocated at:");
1519             Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
1520          end if;
1521       end if;
1522    end Print_Pool;
1523
1524    -----------------------
1525    -- Print_Info_Stdout --
1526    -----------------------
1527
1528    procedure Print_Info_Stdout
1529      (Pool          : Debug_Pool;
1530       Cumulate      : Boolean := False;
1531       Display_Slots : Boolean := False;
1532       Display_Leaks : Boolean := False)
1533    is
1534       procedure Internal is new Print_Info
1535         (Put_Line => GNAT.IO.Put_Line,
1536          Put      => GNAT.IO.Put);
1537
1538    begin
1539       Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
1540    end Print_Info_Stdout;
1541
1542    ------------------
1543    -- Dump_Gnatmem --
1544    ------------------
1545
1546    procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
1547       type File_Ptr is new System.Address;
1548
1549       function fopen (Path : String; Mode : String) return File_Ptr;
1550       pragma Import (C, fopen);
1551
1552       procedure fwrite
1553         (Ptr    : System.Address;
1554          Size   : size_t;
1555          Nmemb  : size_t;
1556          Stream : File_Ptr);
1557
1558       procedure fwrite
1559         (Str    : String;
1560          Size   : size_t;
1561          Nmemb  : size_t;
1562          Stream : File_Ptr);
1563       pragma Import (C, fwrite);
1564
1565       procedure fputc (C : Integer; Stream : File_Ptr);
1566       pragma Import (C, fputc);
1567
1568       procedure fclose (Stream : File_Ptr);
1569       pragma Import (C, fclose);
1570
1571       Address_Size : constant size_t :=
1572                        System.Address'Max_Size_In_Storage_Elements;
1573       --  Size in bytes of a pointer
1574
1575       File        : File_Ptr;
1576       Current     : System.Address;
1577       Header      : Allocation_Header_Access;
1578       Actual_Size : size_t;
1579       Num_Calls   : Integer;
1580       Tracebk     : Tracebacks_Array_Access;
1581
1582    begin
1583       File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
1584       fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
1585
1586       --  List of not deallocated blocks (see Print_Info)
1587
1588       Current := Pool.First_Used_Block;
1589       while Current /= System.Null_Address loop
1590          Header := Header_Of (Current);
1591
1592          Actual_Size := size_t (Header.Block_Size);
1593          Tracebk := Header.Alloc_Traceback.Traceback;
1594          Num_Calls := Tracebk'Length;
1595
1596          --  Code taken from memtrack.adb in GNAT's sources
1597          --  Logs allocation call
1598          --  format is:
1599          --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
1600
1601          fputc (Character'Pos ('A'), File);
1602          fwrite (Current'Address, Address_Size, 1, File);
1603          fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
1604                  File);
1605          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
1606                  File);
1607
1608          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
1609             declare
1610                Ptr : System.Address := PC_For (Tracebk (J));
1611             begin
1612                fwrite (Ptr'Address, Address_Size, 1, File);
1613             end;
1614          end loop;
1615
1616          Current := Header.Next;
1617       end loop;
1618
1619       fclose (File);
1620    end Dump_Gnatmem;
1621
1622 begin
1623    Allocate_End;
1624    Deallocate_End;
1625    Dereference_End;
1626 end GNAT.Debug_Pools;