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
32with Ada.Exceptions.Traceback;
33with GNAT.IO; use GNAT.IO;
34
35with System.Address_Image;
36with System.Memory;     use System.Memory;
37with System.Soft_Links; use System.Soft_Links;
38
39with System.Traceback_Entries; use System.Traceback_Entries;
40
41with GNAT.HTable;
42with GNAT.Traceback; use GNAT.Traceback;
43
44with Ada.Unchecked_Conversion;
45
46package 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
1721begin
1722   Allocate_End;
1723   Deallocate_End;
1724   Dereference_End;
1725end GNAT.Debug_Pools;
1726