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