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