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