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