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