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-2021, 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 GNAT.IO; use GNAT.IO;
33
34with System.CRTL;
35with System.Memory;     use System.Memory;
36with System.Soft_Links; use System.Soft_Links;
37
38with System.Traceback_Entries;
39
40with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
41with GNAT.HTable;
42with GNAT.Traceback; use GNAT.Traceback;
43
44with Ada.Finalization;
45with Ada.Unchecked_Conversion;
46
47package body GNAT.Debug_Pools is
48
49   Storage_Alignment : constant := Standard'Maximum_Alignment;
50   --  Alignment enforced for all the memory chunks returned by Allocate,
51   --  maximized to make sure that it will be compatible with all types.
52   --
53   --  The addresses returned by the underlying low-level allocator (be it
54   --  'new' or a straight 'malloc') aren't guaranteed to be that much aligned
55   --  on some targets, so we manage the needed alignment padding ourselves
56   --  systematically. Use of a common value for every allocation allows
57   --  significant simplifications in the code, nevertheless, for improved
58   --  robustness and efficiency overall.
59
60   --  We combine a few internal devices to offer the pool services:
61   --
62   --  * A management header attached to each allocated memory block, located
63   --    right ahead of it, like so:
64   --
65   --        Storage Address returned by the pool,
66   --        aligned on Storage_Alignment
67   --                       v
68   --      +------+--------+---------------------
69   --      | ~~~~ | HEADER | USER DATA ... |
70   --      +------+--------+---------------------
71   --       <---->
72   --       alignment
73   --       padding
74   --
75   --    The alignment padding is required
76   --
77   --  * A validity bitmap, which holds a validity bit for blocks managed by
78   --    the pool. Enforcing Storage_Alignment on those blocks allows efficient
79   --    validity management.
80   --
81   --  * A list of currently used blocks.
82
83   Max_Ignored_Levels : constant Natural := 10;
84   --  Maximum number of levels that will be ignored in backtraces. This is so
85   --  that we still have enough significant levels in the tracebacks returned
86   --  to the user.
87   --
88   --  The value 10 is chosen as being greater than the maximum callgraph
89   --  in this package. Its actual value is not really relevant, as long as it
90   --  is high enough to make sure we still have enough frames to return to
91   --  the user after we have hidden the frames internal to this package.
92
93   Disable : Boolean := False;
94   --  This variable is used to avoid infinite loops, where this package would
95   --  itself allocate memory and then call itself recursively, forever. Useful
96   --  when System_Memory_Debug_Pool_Enabled is True.
97
98   System_Memory_Debug_Pool_Enabled : Boolean := False;
99   --  If True, System.Memory allocation uses Debug_Pool
100
101   Allow_Unhandled_Memory : Boolean := False;
102   --  If True, protects Deallocate against releasing memory allocated before
103   --  System_Memory_Debug_Pool_Enabled was set.
104
105   Traceback_Count : Byte_Count := 0;
106   --  Total number of traceback elements
107
108   ---------------------------
109   -- Back Trace Hash Table --
110   ---------------------------
111
112   --  This package needs to store one set of tracebacks for each allocation
113   --  point (when was it allocated or deallocated). This would use too much
114   --  memory,  so the tracebacks are actually stored in a hash table, and
115   --  we reference elements in this hash table instead.
116
117   --  This hash-table will remain empty if the discriminant Stack_Trace_Depth
118   --  for the pools is set to 0.
119
120   --  This table is a global table, that can be shared among all debug pools
121   --  with no problems.
122
123   type Header is range 1 .. 1023;
124   --  Number of elements in the hash-table
125
126   type Tracebacks_Array_Access is access Tracebacks_Array;
127
128   type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);
129
130   type Traceback_Htable_Elem;
131   type Traceback_Htable_Elem_Ptr
132      is access Traceback_Htable_Elem;
133
134   type Traceback_Htable_Elem is record
135      Traceback   : Tracebacks_Array_Access;
136      Kind        : Traceback_Kind;
137      Count       : Natural;
138      --  Size of the memory allocated/freed at Traceback since last Reset call
139
140      Total       : Byte_Count;
141      --  Number of chunk of memory allocated/freed at Traceback since last
142      --  Reset call.
143
144      Frees       : Natural;
145      --  Number of chunk of memory allocated at Traceback, currently freed
146      --  since last Reset call. (only for Alloc & Indirect_Alloc elements)
147
148      Total_Frees : Byte_Count;
149      --  Size of the memory allocated at Traceback, currently freed since last
150      --  Reset call. (only for Alloc & Indirect_Alloc elements)
151
152      Next        : Traceback_Htable_Elem_Ptr;
153   end record;
154
155   --  Subprograms used for the Backtrace_Htable instantiation
156
157   procedure Set_Next
158     (E    : Traceback_Htable_Elem_Ptr;
159      Next : Traceback_Htable_Elem_Ptr);
160   pragma Inline (Set_Next);
161
162   function Next
163     (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr;
164   pragma Inline (Next);
165
166   function Get_Key
167     (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access;
168   pragma Inline (Get_Key);
169
170   function Hash (T : Tracebacks_Array_Access) return Header;
171   pragma Inline (Hash);
172
173   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
174   --  Why is this not inlined???
175
176   --  The hash table for back traces
177
178   package Backtrace_Htable is new GNAT.HTable.Static_HTable
179     (Header_Num => Header,
180      Element    => Traceback_Htable_Elem,
181      Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
182      Null_Ptr   => null,
183      Set_Next   => Set_Next,
184      Next       => Next,
185      Key        => Tracebacks_Array_Access,
186      Get_Key    => Get_Key,
187      Hash       => Hash,
188      Equal      => Equal);
189
190   -----------------------
191   -- Allocations table --
192   -----------------------
193
194   type Allocation_Header;
195   type Allocation_Header_Access is access Allocation_Header;
196
197   type Traceback_Ptr_Or_Address is new System.Address;
198   --  A type that acts as a C union, and is either a System.Address or a
199   --  Traceback_Htable_Elem_Ptr.
200
201   --  The following record stores extra information that needs to be
202   --  memorized for each block allocated with the special debug pool.
203
204   type Allocation_Header is record
205      Allocation_Address : System.Address;
206      --  Address of the block returned by malloc, possibly unaligned
207
208      Block_Size : Storage_Offset;
209      --  Needed only for advanced freeing algorithms (traverse all allocated
210      --  blocks for potential references). This value is negated when the
211      --  chunk of memory has been logically freed by the application. This
212      --  chunk has not been physically released yet.
213
214      Alloc_Traceback : Traceback_Htable_Elem_Ptr;
215      --  ??? comment required
216
217      Dealloc_Traceback : Traceback_Ptr_Or_Address;
218      --  Pointer to the traceback for the allocation (if the memory chunk is
219      --  still valid), or to the first deallocation otherwise. Make sure this
220      --  is a thin pointer to save space.
221      --
222      --  Dealloc_Traceback is also for blocks that are still allocated to
223      --  point to the previous block in the list. This saves space in this
224      --  header, and make manipulation of the lists of allocated pointers
225      --  faster.
226
227      Next : System.Address;
228      --  Point to the next block of the same type (either allocated or
229      --  logically freed) in memory. This points to the beginning of the user
230      --  data, and does not include the header of that block.
231   end record;
232
233   function Header_Of
234     (Address : System.Address) return Allocation_Header_Access;
235   pragma Inline (Header_Of);
236   --  Return the header corresponding to a previously allocated address
237
238   function To_Address is new Ada.Unchecked_Conversion
239     (Traceback_Ptr_Or_Address, System.Address);
240
241   function To_Address is new Ada.Unchecked_Conversion
242     (System.Address, Traceback_Ptr_Or_Address);
243
244   function To_Traceback is new Ada.Unchecked_Conversion
245     (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);
246
247   function To_Traceback is new Ada.Unchecked_Conversion
248     (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
249
250   Header_Offset : constant Storage_Count :=
251     (Allocation_Header'Object_Size / System.Storage_Unit);
252   --  Offset, in bytes, from start of allocation Header to start of User
253   --  data.  The start of user data is assumed to be aligned at least as much
254   --  as what the header type requires, so applying this offset yields a
255   --  suitably aligned address as well.
256
257   Extra_Allocation : constant Storage_Count :=
258     (Storage_Alignment - 1 + Header_Offset);
259   --  Amount we need to secure in addition to the user data for a given
260   --  allocation request: room for the allocation header plus worst-case
261   --  alignment padding.
262
263   -----------------------
264   -- Local subprograms --
265   -----------------------
266
267   function Align (Addr : Integer_Address) return Integer_Address;
268   pragma Inline (Align);
269   --  Return the next address aligned on Storage_Alignment from Addr.
270
271   function Find_Or_Create_Traceback
272     (Pool                : Debug_Pool;
273      Kind                : Traceback_Kind;
274      Size                : Storage_Count;
275      Ignored_Frame_Start : System.Address;
276      Ignored_Frame_End   : System.Address) return Traceback_Htable_Elem_Ptr;
277   --  Return an element matching the current traceback (omitting the frames
278   --  that are in the current package). If this traceback already existed in
279   --  the htable, a pointer to this is returned to spare memory. Null is
280   --  returned if the pool is set not to store tracebacks. If the traceback
281   --  already existed in the table, the count is incremented so that
282   --  Dump_Tracebacks returns useful results. All addresses up to, and
283   --  including, an address between Ignored_Frame_Start .. Ignored_Frame_End
284   --  are ignored.
285
286   function Output_File (Pool : Debug_Pool) return File_Type;
287   pragma Inline (Output_File);
288   --  Returns file_type on which error messages have to be generated for Pool
289
290   procedure Put_Line
291     (File                : File_Type;
292      Depth               : Natural;
293      Traceback           : Tracebacks_Array_Access;
294      Ignored_Frame_Start : System.Address := System.Null_Address;
295      Ignored_Frame_End   : System.Address := System.Null_Address);
296   --  Print Traceback to File. If Traceback is null, print the call_chain
297   --  at the current location, up to Depth levels, ignoring all addresses
298   --  up to the first one in the range:
299   --    Ignored_Frame_Start .. Ignored_Frame_End
300
301   procedure Stdout_Put (S : String);
302   --  Wrapper for Put that ensures we always write to stdout instead of the
303   --  current output file defined in GNAT.IO.
304
305   procedure Stdout_Put_Line (S : String);
306   --  Wrapper for Put_Line that ensures we always write to stdout instead of
307   --  the current output file defined in GNAT.IO.
308
309   procedure Print_Traceback
310     (Output_File : File_Type;
311      Prefix      : String;
312      Traceback   : Traceback_Htable_Elem_Ptr);
313   --  Output Prefix & Traceback & EOL. Print nothing if Traceback is null.
314
315   procedure Print_Address (File : File_Type; Addr : Address);
316   --  Output System.Address without using secondary stack.
317   --  When System.Memory uses Debug_Pool, secondary stack cannot be used
318   --  during Allocate calls, as some Allocate calls are done to
319   --  register/initialize a secondary stack for a foreign thread.
320   --  During these calls, the secondary stack is not available yet.
321
322   package Validity is
323      function Is_Handled (Storage : System.Address) return Boolean;
324      pragma Inline (Is_Handled);
325      --  Return True if Storage is the address of a block that the debug pool
326      --  already had under its control. Used to allow System.Memory to use
327      --  Debug_Pools
328
329      function Is_Valid (Storage : System.Address) return Boolean;
330      pragma Inline (Is_Valid);
331      --  Return True if Storage is the address of a block that the debug pool
332      --  has under its control, in which case Header_Of may be used to access
333      --  the associated allocation header.
334
335      procedure Set_Valid (Storage : System.Address; Value : Boolean);
336      pragma Inline (Set_Valid);
337      --  Mark the address Storage as being under control of the memory pool
338      --  (if Value is True), or not (if Value is False).
339
340      Validity_Count : Byte_Count := 0;
341      --  Total number of validity elements
342
343   end Validity;
344
345   use Validity;
346
347   procedure Set_Dead_Beef
348     (Storage_Address          : System.Address;
349      Size_In_Storage_Elements : Storage_Count);
350   --  Set the contents of the memory block pointed to by Storage_Address to
351   --  the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
352   --  of the length of this pattern, the last instance may be partial.
353
354   procedure Free_Physically (Pool : in out Debug_Pool);
355   --  Start to physically release some memory to the system, until the amount
356   --  of logically (but not physically) freed memory is lower than the
357   --  expected amount in Pool.
358
359   procedure Allocate_End;
360   procedure Deallocate_End;
361   procedure Dereference_End;
362   --  These procedures are used as markers when computing the stacktraces,
363   --  so that addresses in the debug pool itself are not reported to the user.
364
365   Code_Address_For_Allocate_End    : System.Address := System.Null_Address;
366   Code_Address_For_Deallocate_End  : System.Address;
367   Code_Address_For_Dereference_End : System.Address;
368   --  Taking the address of the above procedures will not work on some
369   --  architectures (HPUX for instance). Thus we do the same thing that
370   --  is done in a-except.adb, and get the address of labels instead.
371
372   procedure Skip_Levels
373     (Depth               : Natural;
374      Trace               : Tracebacks_Array;
375      Start               : out Natural;
376      Len                 : in out Natural;
377      Ignored_Frame_Start : System.Address;
378      Ignored_Frame_End   : System.Address);
379   --  Set Start .. Len to the range of values from Trace that should be output
380   --  to the user. This range of values excludes any address prior to the
381   --  first one in Ignored_Frame_Start .. Ignored_Frame_End (basically
382   --  addresses internal to this package). Depth is the number of levels that
383   --  the user is interested in.
384
385   package STBE renames System.Traceback_Entries;
386
387   function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address
388     renames STBE.PC_For;
389
390   type Scope_Lock is
391     new Ada.Finalization.Limited_Controlled with null record;
392   --  Used to handle Lock_Task/Unlock_Task calls
393
394   overriding procedure Initialize (This : in out Scope_Lock);
395   --  Lock task on initialization
396
397   overriding procedure Finalize   (This : in out Scope_Lock);
398   --  Unlock task on finalization
399
400   ----------------
401   -- Initialize --
402   ----------------
403
404   procedure Initialize (This : in out Scope_Lock) is
405      pragma Unreferenced (This);
406   begin
407      Lock_Task.all;
408   end Initialize;
409
410   --------------
411   -- Finalize --
412   --------------
413
414   procedure Finalize (This : in out Scope_Lock) is
415      pragma Unreferenced (This);
416   begin
417      Unlock_Task.all;
418   end Finalize;
419
420   -----------
421   -- Align --
422   -----------
423
424   function Align (Addr : Integer_Address) return Integer_Address is
425      Factor : constant Integer_Address := Storage_Alignment;
426   begin
427      return ((Addr + Factor - 1) / Factor) * Factor;
428   end Align;
429
430   ---------------
431   -- Header_Of --
432   ---------------
433
434   function Header_Of
435     (Address : System.Address) return Allocation_Header_Access
436   is
437      function Convert is
438        new Ada.Unchecked_Conversion
439                  (System.Address,
440                   Allocation_Header_Access);
441   begin
442      return Convert (Address - Header_Offset);
443   end Header_Of;
444
445   --------------
446   -- Set_Next --
447   --------------
448
449   procedure Set_Next
450     (E    : Traceback_Htable_Elem_Ptr;
451      Next : Traceback_Htable_Elem_Ptr)
452   is
453   begin
454      E.Next := Next;
455   end Set_Next;
456
457   ----------
458   -- Next --
459   ----------
460
461   function Next
462     (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr
463   is
464   begin
465      return E.Next;
466   end Next;
467
468   -----------
469   -- Equal --
470   -----------
471
472   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
473      use type Tracebacks_Array;
474   begin
475      return K1.all = K2.all;
476   end Equal;
477
478   -------------
479   -- Get_Key --
480   -------------
481
482   function Get_Key
483     (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access
484   is
485   begin
486      return E.Traceback;
487   end Get_Key;
488
489   ----------
490   -- Hash --
491   ----------
492
493   function Hash (T : Tracebacks_Array_Access) return Header is
494      Result : Integer_Address := 0;
495
496   begin
497      for X in T'Range loop
498         Result := Result + To_Integer (PC_For (T (X)));
499      end loop;
500
501      return Header (1 + Result mod Integer_Address (Header'Last));
502   end Hash;
503
504   -----------------
505   -- Output_File --
506   -----------------
507
508   function Output_File (Pool : Debug_Pool) return File_Type is
509   begin
510      if Pool.Errors_To_Stdout then
511         return Standard_Output;
512      else
513         return Standard_Error;
514      end if;
515   end Output_File;
516
517   -------------------
518   -- Print_Address --
519   -------------------
520
521   procedure Print_Address (File : File_Type; Addr : Address) is
522   begin
523      --  Warning: secondary stack cannot be used here. When System.Memory
524      --  implementation uses Debug_Pool, Print_Address can be called during
525      --  secondary stack creation for foreign threads.
526
527      Put (File, Image_C (Addr));
528   end Print_Address;
529
530   --------------
531   -- Put_Line --
532   --------------
533
534   procedure Put_Line
535     (File                : File_Type;
536      Depth               : Natural;
537      Traceback           : Tracebacks_Array_Access;
538      Ignored_Frame_Start : System.Address := System.Null_Address;
539      Ignored_Frame_End   : System.Address := System.Null_Address)
540   is
541      procedure Print (Tr : Tracebacks_Array);
542      --  Print the traceback to standard_output
543
544      -----------
545      -- Print --
546      -----------
547
548      procedure Print (Tr : Tracebacks_Array) is
549      begin
550         for J in Tr'Range loop
551            Print_Address (File, PC_For (Tr (J)));
552            Put (File, ' ');
553         end loop;
554         Put (File, ASCII.LF);
555      end Print;
556
557   --  Start of processing for Put_Line
558
559   begin
560      if Traceback = null then
561         declare
562            Len   : Natural;
563            Start : Natural;
564            Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
565
566         begin
567            Call_Chain (Trace, Len);
568            Skip_Levels
569              (Depth               => Depth,
570               Trace               => Trace,
571               Start               => Start,
572               Len                 => Len,
573               Ignored_Frame_Start => Ignored_Frame_Start,
574               Ignored_Frame_End   => Ignored_Frame_End);
575            Print (Trace (Start .. Len));
576         end;
577
578      else
579         Print (Traceback.all);
580      end if;
581   end Put_Line;
582
583   -----------------
584   -- Skip_Levels --
585   -----------------
586
587   procedure Skip_Levels
588     (Depth               : Natural;
589      Trace               : Tracebacks_Array;
590      Start               : out Natural;
591      Len                 : in out Natural;
592      Ignored_Frame_Start : System.Address;
593      Ignored_Frame_End   : System.Address)
594   is
595   begin
596      Start := Trace'First;
597
598      while Start <= Len
599        and then (PC_For (Trace (Start)) < Ignored_Frame_Start
600                    or else PC_For (Trace (Start)) > Ignored_Frame_End)
601      loop
602         Start := Start + 1;
603      end loop;
604
605      Start := Start + 1;
606
607      --  Just in case: make sure we have a traceback even if Ignore_Till
608      --  wasn't found.
609
610      if Start > Len then
611         Start := 1;
612      end if;
613
614      if Len - Start + 1 > Depth then
615         Len := Depth + Start - 1;
616      end if;
617   end Skip_Levels;
618
619   ------------------------------
620   -- Find_Or_Create_Traceback --
621   ------------------------------
622
623   function Find_Or_Create_Traceback
624     (Pool                : Debug_Pool;
625      Kind                : Traceback_Kind;
626      Size                : Storage_Count;
627      Ignored_Frame_Start : System.Address;
628      Ignored_Frame_End   : System.Address) return Traceback_Htable_Elem_Ptr
629   is
630   begin
631      if Pool.Stack_Trace_Depth = 0 then
632         return null;
633      end if;
634
635      declare
636         Disable_Exit_Value : constant Boolean := Disable;
637
638         Elem  : Traceback_Htable_Elem_Ptr;
639         Len   : Natural;
640         Start : Natural;
641         Trace : aliased Tracebacks_Array
642                   (1 .. Integer (Pool.Stack_Trace_Depth) +
643                      Max_Ignored_Levels);
644
645      begin
646         Disable := True;
647         Call_Chain (Trace, Len);
648         Skip_Levels
649           (Depth               => Pool.Stack_Trace_Depth,
650            Trace               => Trace,
651            Start               => Start,
652            Len                 => Len,
653            Ignored_Frame_Start => Ignored_Frame_Start,
654            Ignored_Frame_End   => Ignored_Frame_End);
655
656         --  Check if the traceback is already in the table
657
658         Elem :=
659           Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
660
661         --  If not, insert it
662
663         if Elem = null then
664            Elem :=
665              new Traceback_Htable_Elem'
666                    (Traceback   =>
667                       new Tracebacks_Array'(Trace (Start .. Len)),
668                     Count       => 1,
669                     Kind        => Kind,
670                     Total       => Byte_Count (Size),
671                     Frees       => 0,
672                     Total_Frees => 0,
673                     Next        => null);
674            Traceback_Count := Traceback_Count + 1;
675            Backtrace_Htable.Set (Elem);
676
677         else
678            Elem.Count := Elem.Count + 1;
679            Elem.Total := Elem.Total + Byte_Count (Size);
680         end if;
681
682         Disable := Disable_Exit_Value;
683         return Elem;
684      exception
685         when others =>
686            Disable := Disable_Exit_Value;
687            raise;
688      end;
689   end Find_Or_Create_Traceback;
690
691   --------------
692   -- Validity --
693   --------------
694
695   package body Validity is
696
697      --  The validity bits of the allocated blocks are kept in a has table.
698      --  Each component of the hash table contains the validity bits for a
699      --  16 Mbyte memory chunk.
700
701      --  The reason the validity bits are kept for chunks of memory rather
702      --  than in a big array is that on some 64 bit platforms, it may happen
703      --  that two chunk of allocated data are very far from each other.
704
705      Memory_Chunk_Size : constant Integer_Address := 2 ** 24; --  16 MB
706      Validity_Divisor  : constant := Storage_Alignment * System.Storage_Unit;
707
708      Max_Validity_Byte_Index : constant :=
709                                  Memory_Chunk_Size / Validity_Divisor;
710
711      subtype Validity_Byte_Index is
712        Integer_Address range 0 .. Max_Validity_Byte_Index - 1;
713
714      type Byte is mod 2 ** System.Storage_Unit;
715
716      type Validity_Bits_Part is array (Validity_Byte_Index) of Byte;
717      type Validity_Bits_Part_Ref is access all Validity_Bits_Part;
718      No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null;
719
720      type Validity_Bits is record
721         Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part;
722         --  True if chunk of memory at this address is currently allocated
723
724         Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part;
725         --  True if chunk of memory at this address was allocated once after
726         --  Allow_Unhandled_Memory was set to True. Used to know on Deallocate
727         --  if chunk of memory should be handled a block allocated by this
728         --  package.
729
730      end record;
731
732      type Validity_Bits_Ref is access all Validity_Bits;
733      No_Validity_Bits : constant Validity_Bits_Ref := null;
734
735      Max_Header_Num : constant := 1023;
736
737      type Header_Num is range 0 .. Max_Header_Num - 1;
738
739      function Hash (F : Integer_Address) return Header_Num;
740
741      function Is_Valid_Or_Handled
742        (Storage : System.Address;
743         Valid   : Boolean) return Boolean;
744      pragma Inline (Is_Valid_Or_Handled);
745      --  Internal implementation of Is_Valid and Is_Handled.
746      --  Valid is used to select Valid or Handled arrays.
747
748      package Validy_Htable is new GNAT.HTable.Simple_HTable
749        (Header_Num => Header_Num,
750         Element    => Validity_Bits_Ref,
751         No_Element => No_Validity_Bits,
752         Key        => Integer_Address,
753         Hash       => Hash,
754         Equal      => "=");
755      --  Table to keep the validity and handled bit blocks for the allocated
756      --  data.
757
758      function To_Pointer is new Ada.Unchecked_Conversion
759        (System.Address, Validity_Bits_Part_Ref);
760
761      procedure Memset (A : Address; C : Integer; N : size_t);
762      pragma Import (C, Memset, "memset");
763
764      ----------
765      -- Hash --
766      ----------
767
768      function Hash (F : Integer_Address) return Header_Num is
769      begin
770         return Header_Num (F mod Max_Header_Num);
771      end Hash;
772
773      -------------------------
774      -- Is_Valid_Or_Handled --
775      -------------------------
776
777      function Is_Valid_Or_Handled
778        (Storage : System.Address;
779         Valid   : Boolean) return Boolean is
780         Int_Storage  : constant Integer_Address := To_Integer (Storage);
781
782      begin
783         --  The pool only returns addresses aligned on Storage_Alignment so
784         --  anything off cannot be a valid block address and we can return
785         --  early in this case. We actually have to since our data structures
786         --  map validity bits for such aligned addresses only.
787
788         if Int_Storage mod Storage_Alignment /= 0 then
789            return False;
790         end if;
791
792         declare
793            Block_Number : constant Integer_Address :=
794                             Int_Storage /  Memory_Chunk_Size;
795            Ptr          : constant Validity_Bits_Ref :=
796                             Validy_Htable.Get (Block_Number);
797            Offset       : constant Integer_Address :=
798                             (Int_Storage -
799                               (Block_Number * Memory_Chunk_Size)) /
800                                  Storage_Alignment;
801            Bit          : constant Byte :=
802                             2 ** Natural (Offset mod System.Storage_Unit);
803         begin
804            if Ptr = No_Validity_Bits then
805               return False;
806            else
807               if Valid then
808                  return (Ptr.Valid (Offset / System.Storage_Unit)
809                             and Bit) /= 0;
810               else
811                  if Ptr.Handled = No_Validity_Bits_Part then
812                     return False;
813                  else
814                     return (Ptr.Handled (Offset / System.Storage_Unit)
815                                and Bit) /= 0;
816                  end if;
817               end if;
818            end if;
819         end;
820      end Is_Valid_Or_Handled;
821
822      --------------
823      -- Is_Valid --
824      --------------
825
826      function Is_Valid (Storage : System.Address) return Boolean is
827      begin
828         return Is_Valid_Or_Handled (Storage => Storage, Valid => True);
829      end Is_Valid;
830
831      -----------------
832      -- Is_Handled --
833      -----------------
834
835      function Is_Handled (Storage : System.Address) return Boolean is
836      begin
837         return Is_Valid_Or_Handled (Storage => Storage, Valid => False);
838      end Is_Handled;
839
840      ---------------
841      -- Set_Valid --
842      ---------------
843
844      procedure Set_Valid (Storage : System.Address; Value : Boolean) is
845         Int_Storage  : constant Integer_Address := To_Integer (Storage);
846         Block_Number : constant Integer_Address :=
847                          Int_Storage /  Memory_Chunk_Size;
848         Ptr          : Validity_Bits_Ref := Validy_Htable.Get (Block_Number);
849         Offset       : constant Integer_Address :=
850                          (Int_Storage - (Block_Number * Memory_Chunk_Size)) /
851                             Storage_Alignment;
852         Bit          : constant Byte :=
853                          2 ** Natural (Offset mod System.Storage_Unit);
854
855         procedure Set_Handled;
856         pragma Inline (Set_Handled);
857         --  if Allow_Unhandled_Memory set Handled bit in table.
858
859         -----------------
860         -- Set_Handled --
861         -----------------
862
863         procedure Set_Handled is
864         begin
865            if Allow_Unhandled_Memory then
866               if Ptr.Handled = No_Validity_Bits_Part then
867                  Ptr.Handled :=
868                    To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
869                  Memset
870                    (A => Ptr.Handled.all'Address,
871                     C => 0,
872                     N => size_t (Max_Validity_Byte_Index));
873               end if;
874
875               Ptr.Handled (Offset / System.Storage_Unit) :=
876                 Ptr.Handled (Offset / System.Storage_Unit) or Bit;
877            end if;
878         end Set_Handled;
879
880      --  Start of processing for Set_Valid
881
882      begin
883         if Ptr = No_Validity_Bits then
884
885            --  First time in this memory area: allocate a new block and put
886            --  it in the table.
887
888            if Value then
889               Ptr := new Validity_Bits;
890               Validity_Count := Validity_Count + 1;
891               Ptr.Valid :=
892                 To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
893               Validy_Htable.Set (Block_Number, Ptr);
894               Memset
895                 (A => Ptr.Valid.all'Address,
896                  C => 0,
897                  N => size_t (Max_Validity_Byte_Index));
898               Ptr.Valid (Offset / System.Storage_Unit) := Bit;
899               Set_Handled;
900            end if;
901
902         else
903            if Value then
904               Ptr.Valid (Offset / System.Storage_Unit) :=
905                 Ptr.Valid (Offset / System.Storage_Unit) or Bit;
906               Set_Handled;
907            else
908               Ptr.Valid (Offset / System.Storage_Unit) :=
909                 Ptr.Valid (Offset / System.Storage_Unit) and (not Bit);
910            end if;
911         end if;
912      end Set_Valid;
913   end Validity;
914
915   --------------
916   -- Allocate --
917   --------------
918
919   procedure Allocate
920     (Pool                     : in out Debug_Pool;
921      Storage_Address          : out Address;
922      Size_In_Storage_Elements : Storage_Count;
923      Alignment                : Storage_Count)
924   is
925      pragma Unreferenced (Alignment);
926      --  Ignored, we always force Storage_Alignment
927
928      type Local_Storage_Array is new Storage_Array
929        (1 .. Size_In_Storage_Elements + Extra_Allocation);
930
931      type Ptr is access Local_Storage_Array;
932      --  On some systems, we might want to physically protect pages against
933      --  writing when they have been freed (of course, this is expensive in
934      --  terms of wasted memory). To do that, all we should have to do it to
935      --  set the size of this array to the page size. See mprotect().
936
937      Current : Byte_Count;
938      P       : Ptr;
939      Trace   : Traceback_Htable_Elem_Ptr;
940
941      Reset_Disable_At_Exit : Boolean := False;
942
943      Lock : Scope_Lock;
944      pragma Unreferenced (Lock);
945
946   begin
947      <<Allocate_Label>>
948
949      if Disable then
950         Storage_Address :=
951           System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements));
952         return;
953      end if;
954
955      Reset_Disable_At_Exit := True;
956      Disable := True;
957
958      Pool.Alloc_Count := Pool.Alloc_Count + 1;
959
960      --  If necessary, start physically releasing memory. The reason this is
961      --  done here, although Pool.Logically_Deallocated has not changed above,
962      --  is so that we do this only after a series of deallocations (e.g loop
963      --  that deallocates a big array). If we were doing that in Deallocate,
964      --  we might be physically freeing memory several times during the loop,
965      --  which is expensive.
966
967      if Pool.Logically_Deallocated >
968           Byte_Count (Pool.Maximum_Logically_Freed_Memory)
969      then
970         Free_Physically (Pool);
971      end if;
972
973      --  Use standard (i.e. through malloc) allocations. This automatically
974      --  raises Storage_Error if needed. We also try once more to physically
975      --  release memory, so that even marked blocks, in the advanced scanning,
976      --  are freed. Note that we do not initialize the storage array since it
977      --  is not necessary to do so (however this will cause bogus valgrind
978      --  warnings, which should simply be ignored).
979
980      begin
981         P := new Local_Storage_Array;
982
983      exception
984         when Storage_Error =>
985            Free_Physically (Pool);
986            P := new Local_Storage_Array;
987      end;
988
989      --  Compute Storage_Address, aimed at receiving user data. We need room
990      --  for the allocation header just ahead of the user data space plus
991      --  alignment padding so Storage_Address is aligned on Storage_Alignment,
992      --  like so:
993      --
994      --                         Storage_Address, aligned
995      --                         on Storage_Alignment
996      --                           v
997      --          | ~~~~ | Header | User data ... |
998      --                  ^........^
999      --                  Header_Offset
1000      --
1001      --  Header_Offset is fixed so moving back and forth between user data
1002      --  and allocation header is straightforward. The value is also such
1003      --  that the header type alignment is honored when starting from
1004      --  Default_alignment.
1005
1006      --  For the purpose of computing Storage_Address, we just do as if the
1007      --  header was located first, followed by the alignment padding:
1008
1009      Storage_Address :=
1010        To_Address (Align (To_Integer (P.all'Address) +
1011                      Integer_Address (Header_Offset)));
1012      --  Computation is done in Integer_Address, not Storage_Offset, because
1013      --  the range of Storage_Offset may not be large enough.
1014
1015      pragma Assert ((Storage_Address - System.Null_Address)
1016                     mod Storage_Alignment = 0);
1017      pragma Assert (Storage_Address + Size_In_Storage_Elements
1018                     <= P.all'Address + P'Length);
1019
1020      Trace :=
1021        Find_Or_Create_Traceback
1022          (Pool                => Pool,
1023           Kind                => Alloc,
1024           Size                => Size_In_Storage_Elements,
1025           Ignored_Frame_Start => Allocate_Label'Address,
1026           Ignored_Frame_End   => Code_Address_For_Allocate_End);
1027
1028      pragma Warnings (Off);
1029      --  Turn warning on alignment for convert call off. We know that in fact
1030      --  this conversion is safe since P itself is always aligned on
1031      --  Storage_Alignment.
1032
1033      Header_Of (Storage_Address).all :=
1034        (Allocation_Address => P.all'Address,
1035         Alloc_Traceback    => Trace,
1036         Dealloc_Traceback  => To_Traceback (null),
1037         Next               => Pool.First_Used_Block,
1038         Block_Size         => Size_In_Storage_Elements);
1039
1040      pragma Warnings (On);
1041
1042      --  Link this block in the list of used blocks. This will be used to list
1043      --  memory leaks in Print_Info, and for the advanced schemes of
1044      --  Physical_Free, where we want to traverse all allocated blocks and
1045      --  search for possible references.
1046
1047      --  We insert in front, since most likely we'll be freeing the most
1048      --  recently allocated blocks first (the older one might stay allocated
1049      --  for the whole life of the application).
1050
1051      if Pool.First_Used_Block /= System.Null_Address then
1052         Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
1053           To_Address (Storage_Address);
1054      end if;
1055
1056      Pool.First_Used_Block := Storage_Address;
1057
1058      --  Mark the new address as valid
1059
1060      Set_Valid (Storage_Address, True);
1061
1062      if Pool.Low_Level_Traces then
1063         Put (Output_File (Pool),
1064              "info: Allocated"
1065              & Storage_Count'Image (Size_In_Storage_Elements)
1066              & " bytes at ");
1067         Print_Address (Output_File (Pool), Storage_Address);
1068         Put (Output_File (Pool),
1069              " (physically:"
1070              & Storage_Count'Image (Local_Storage_Array'Length)
1071              & " bytes at ");
1072         Print_Address (Output_File (Pool), P.all'Address);
1073         Put (Output_File (Pool),
1074              "), at ");
1075         Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1076                   Allocate_Label'Address,
1077                   Code_Address_For_Deallocate_End);
1078      end if;
1079
1080      --  Update internal data
1081
1082      Pool.Allocated :=
1083        Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
1084
1085      Current := Pool.Current_Water_Mark;
1086
1087      if Current > Pool.High_Water then
1088         Pool.High_Water := Current;
1089      end if;
1090
1091      Disable := False;
1092
1093   exception
1094      when others =>
1095         if Reset_Disable_At_Exit then
1096            Disable := False;
1097         end if;
1098         raise;
1099   end Allocate;
1100
1101   ------------------
1102   -- Allocate_End --
1103   ------------------
1104
1105   --  DO NOT MOVE, this must be right after Allocate. This is similar to what
1106   --  is done in a-except, so that we can hide the traceback frames internal
1107   --  to this package
1108
1109   procedure Allocate_End is
1110   begin
1111      <<Allocate_End_Label>>
1112      Code_Address_For_Allocate_End := Allocate_End_Label'Address;
1113   end Allocate_End;
1114
1115   -------------------
1116   -- Set_Dead_Beef --
1117   -------------------
1118
1119   procedure Set_Dead_Beef
1120     (Storage_Address          : System.Address;
1121      Size_In_Storage_Elements : Storage_Count)
1122   is
1123      Dead_Bytes : constant := 4;
1124
1125      type Data is mod 2 ** (Dead_Bytes * 8);
1126      for Data'Size use Dead_Bytes * 8;
1127
1128      Dead : constant Data := 16#DEAD_BEEF#;
1129
1130      type Dead_Memory is array
1131        (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
1132      type Mem_Ptr is access Dead_Memory;
1133
1134      type Byte is mod 2 ** 8;
1135      for Byte'Size use 8;
1136
1137      type Dead_Memory_Bytes is array (0 .. 2) of Byte;
1138      type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
1139
1140      function From_Ptr is new Ada.Unchecked_Conversion
1141        (System.Address, Mem_Ptr);
1142
1143      function From_Ptr is new Ada.Unchecked_Conversion
1144        (System.Address, Dead_Memory_Bytes_Ptr);
1145
1146      M      : constant Mem_Ptr := From_Ptr (Storage_Address);
1147      M2     : Dead_Memory_Bytes_Ptr;
1148      Modulo : constant Storage_Count :=
1149                 Size_In_Storage_Elements mod Dead_Bytes;
1150   begin
1151      M.all := [others => Dead];
1152
1153      --  Any bytes left (up to three of them)
1154
1155      if Modulo /= 0 then
1156         M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
1157
1158         M2 (0) := 16#DE#;
1159         if Modulo >= 2 then
1160            M2 (1) := 16#AD#;
1161
1162            if Modulo >= 3 then
1163               M2 (2) := 16#BE#;
1164            end if;
1165         end if;
1166      end if;
1167   end Set_Dead_Beef;
1168
1169   ---------------------
1170   -- Free_Physically --
1171   ---------------------
1172
1173   procedure Free_Physically (Pool : in out Debug_Pool) is
1174      type Byte is mod 256;
1175      type Byte_Access is access Byte;
1176
1177      function To_Byte is new Ada.Unchecked_Conversion
1178        (System.Address, Byte_Access);
1179
1180      type Address_Access is access System.Address;
1181
1182      function To_Address_Access is new Ada.Unchecked_Conversion
1183        (System.Address, Address_Access);
1184
1185      In_Use_Mark : constant Byte := 16#D#;
1186      Free_Mark   : constant Byte := 16#F#;
1187
1188      Total_Freed : Storage_Count := 0;
1189
1190      procedure Reset_Marks;
1191      --  Unmark all the logically freed blocks, so that they are considered
1192      --  for physical deallocation
1193
1194      procedure Mark
1195        (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
1196      --  Mark the user data block starting at A. For a block of size zero,
1197      --  nothing is done. For a block with a different size, the first byte
1198      --  is set to either "D" (in use) or "F" (free).
1199
1200      function Marked (A : System.Address) return Boolean;
1201      --  Return true if the user data block starting at A might be in use
1202      --  somewhere else
1203
1204      procedure Mark_Blocks;
1205      --  Traverse all allocated blocks, and search for possible references
1206      --  to logically freed blocks. Mark them appropriately
1207
1208      procedure Free_Blocks (Ignore_Marks : Boolean);
1209      --  Physically release blocks. Only the blocks that haven't been marked
1210      --  will be released, unless Ignore_Marks is true.
1211
1212      -----------------
1213      -- Free_Blocks --
1214      -----------------
1215
1216      procedure Free_Blocks (Ignore_Marks : Boolean) is
1217         Header   : Allocation_Header_Access;
1218         Tmp      : System.Address := Pool.First_Free_Block;
1219         Next     : System.Address;
1220         Previous : System.Address := System.Null_Address;
1221
1222      begin
1223         while Tmp /= System.Null_Address
1224           and then
1225             not (Total_Freed > Pool.Minimum_To_Free
1226                   and Pool.Logically_Deallocated <
1227                         Byte_Count (Pool.Maximum_Logically_Freed_Memory))
1228         loop
1229            Header := Header_Of (Tmp);
1230
1231            --  If we know, or at least assume, the block is no longer
1232            --  referenced anywhere, we can free it physically.
1233
1234            if Ignore_Marks or else not Marked (Tmp) then
1235               declare
1236                  pragma Suppress (All_Checks);
1237                  --  Suppress the checks on this section. If they are overflow
1238                  --  errors, it isn't critical, and we'd rather avoid a
1239                  --  Constraint_Error in that case.
1240
1241               begin
1242                  --  Note that block_size < zero for freed blocks
1243
1244                  Pool.Physically_Deallocated :=
1245                    Pool.Physically_Deallocated -
1246                      Byte_Count (Header.Block_Size);
1247
1248                  Pool.Logically_Deallocated :=
1249                    Pool.Logically_Deallocated +
1250                      Byte_Count (Header.Block_Size);
1251
1252                  Total_Freed := Total_Freed - Header.Block_Size;
1253               end;
1254
1255               Next := Header.Next;
1256
1257               if Pool.Low_Level_Traces then
1258                  Put
1259                    (Output_File (Pool),
1260                     "info: Freeing physical memory "
1261                     & Storage_Count'Image
1262                       ((abs Header.Block_Size) + Extra_Allocation)
1263                     & " bytes at ");
1264                  Print_Address (Output_File (Pool),
1265                                 Header.Allocation_Address);
1266                  Put_Line (Output_File (Pool), "");
1267               end if;
1268
1269               if System_Memory_Debug_Pool_Enabled then
1270                  System.CRTL.free (Header.Allocation_Address);
1271               else
1272                  System.Memory.Free (Header.Allocation_Address);
1273               end if;
1274
1275               Set_Valid (Tmp, False);
1276
1277               --  Remove this block from the list
1278
1279               if Previous = System.Null_Address then
1280                  Pool.First_Free_Block := Next;
1281               else
1282                  Header_Of (Previous).Next := Next;
1283               end if;
1284
1285               Tmp := Next;
1286
1287            else
1288               Previous := Tmp;
1289               Tmp := Header.Next;
1290            end if;
1291         end loop;
1292      end Free_Blocks;
1293
1294      ----------
1295      -- Mark --
1296      ----------
1297
1298      procedure Mark
1299        (H      : Allocation_Header_Access;
1300         A      : System.Address;
1301         In_Use : Boolean)
1302      is
1303      begin
1304         if H.Block_Size /= 0 then
1305            To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark);
1306         end if;
1307      end Mark;
1308
1309      -----------------
1310      -- Mark_Blocks --
1311      -----------------
1312
1313      procedure Mark_Blocks is
1314         Tmp      : System.Address := Pool.First_Used_Block;
1315         Previous : System.Address;
1316         Last     : System.Address;
1317         Pointed  : System.Address;
1318         Header   : Allocation_Header_Access;
1319
1320      begin
1321         --  For each allocated block, check its contents. Things that look
1322         --  like a possible address are used to mark the blocks so that we try
1323         --  and keep them, for better detection in case of invalid access.
1324         --  This mechanism is far from being fool-proof: it doesn't check the
1325         --  stacks of the threads, doesn't check possible memory allocated not
1326         --  under control of this debug pool. But it should allow us to catch
1327         --  more cases.
1328
1329         while Tmp /= System.Null_Address loop
1330            Previous := Tmp;
1331            Last     := Tmp + Header_Of (Tmp).Block_Size;
1332            while Previous < Last loop
1333               --  ??? Should we move byte-per-byte, or consider that addresses
1334               --  are always aligned on 4-bytes boundaries ? Let's use the
1335               --  fastest for now.
1336
1337               Pointed := To_Address_Access (Previous).all;
1338               if Is_Valid (Pointed) then
1339                  Header := Header_Of (Pointed);
1340
1341                  --  Do not even attempt to mark blocks in use. That would
1342                  --  screw up the whole application, of course.
1343
1344                  if Header.Block_Size < 0 then
1345                     Mark (Header, Pointed, In_Use => True);
1346                  end if;
1347               end if;
1348
1349               Previous := Previous + System.Address'Size;
1350            end loop;
1351
1352            Tmp := Header_Of (Tmp).Next;
1353         end loop;
1354      end Mark_Blocks;
1355
1356      ------------
1357      -- Marked --
1358      ------------
1359
1360      function Marked (A : System.Address) return Boolean is
1361      begin
1362         return To_Byte (A).all = In_Use_Mark;
1363      end Marked;
1364
1365      -----------------
1366      -- Reset_Marks --
1367      -----------------
1368
1369      procedure Reset_Marks is
1370         Current : System.Address := Pool.First_Free_Block;
1371         Header  : Allocation_Header_Access;
1372
1373      begin
1374         while Current /= System.Null_Address loop
1375            Header := Header_Of (Current);
1376            Mark (Header, Current, False);
1377            Current := Header.Next;
1378         end loop;
1379      end Reset_Marks;
1380
1381      Lock : Scope_Lock;
1382      pragma Unreferenced (Lock);
1383
1384   --  Start of processing for Free_Physically
1385
1386   begin
1387      if Pool.Advanced_Scanning then
1388
1389         --  Reset the mark for each freed block
1390
1391         Reset_Marks;
1392
1393         Mark_Blocks;
1394      end if;
1395
1396      Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
1397
1398      --  The contract is that we need to free at least Minimum_To_Free bytes,
1399      --  even if this means freeing marked blocks in the advanced scheme.
1400
1401      if Total_Freed < Pool.Minimum_To_Free
1402        and then Pool.Advanced_Scanning
1403      then
1404         Pool.Marked_Blocks_Deallocated := True;
1405         Free_Blocks (Ignore_Marks => True);
1406      end if;
1407   end Free_Physically;
1408
1409   --------------
1410   -- Get_Size --
1411   --------------
1412
1413   procedure Get_Size
1414     (Storage_Address          : Address;
1415      Size_In_Storage_Elements : out Storage_Count;
1416      Valid                    : out Boolean)
1417   is
1418      Lock : Scope_Lock;
1419      pragma Unreferenced (Lock);
1420
1421   begin
1422      Valid := Is_Valid (Storage_Address);
1423      Size_In_Storage_Elements := Storage_Count'First;
1424
1425      if Is_Valid (Storage_Address) then
1426         declare
1427            Header : constant Allocation_Header_Access :=
1428                       Header_Of (Storage_Address);
1429
1430         begin
1431            if Header.Block_Size >= 0 then
1432               Valid := True;
1433               Size_In_Storage_Elements := Header.Block_Size;
1434            else
1435               Valid := False;
1436            end if;
1437         end;
1438      else
1439         Valid := False;
1440      end if;
1441   end Get_Size;
1442
1443   ---------------------
1444   -- Print_Traceback --
1445   ---------------------
1446
1447   procedure Print_Traceback
1448     (Output_File : File_Type;
1449      Prefix      : String;
1450      Traceback   : Traceback_Htable_Elem_Ptr)
1451   is
1452   begin
1453      if Traceback /= null then
1454         Put (Output_File, Prefix);
1455         Put_Line (Output_File, 0, Traceback.Traceback);
1456      end if;
1457   end Print_Traceback;
1458
1459   ----------------
1460   -- Deallocate --
1461   ----------------
1462
1463   procedure Deallocate
1464     (Pool                     : in out Debug_Pool;
1465      Storage_Address          : Address;
1466      Size_In_Storage_Elements : Storage_Count;
1467      Alignment                : Storage_Count)
1468   is
1469      pragma Unreferenced (Alignment);
1470
1471      Header   : constant Allocation_Header_Access :=
1472                   Header_Of (Storage_Address);
1473      Previous : System.Address;
1474      Valid    : Boolean;
1475
1476      Header_Block_Size_Was_Less_Than_0 : Boolean := True;
1477
1478   begin
1479      <<Deallocate_Label>>
1480
1481      declare
1482         Lock : Scope_Lock;
1483         pragma Unreferenced (Lock);
1484
1485      begin
1486         Valid := Is_Valid (Storage_Address);
1487
1488         if Valid and then not (Header.Block_Size < 0) then
1489            Header_Block_Size_Was_Less_Than_0 := False;
1490
1491            --  Some sort of codegen problem or heap corruption caused the
1492            --  Size_In_Storage_Elements to be wrongly computed. The code
1493            --  below is all based on the assumption that Header.all is not
1494            --  corrupted, such that the error is non-fatal.
1495
1496            if Header.Block_Size /= Size_In_Storage_Elements and then
1497              Size_In_Storage_Elements /= Storage_Count'Last
1498            then
1499               Put_Line (Output_File (Pool),
1500                         "error: Deallocate size "
1501                         & Storage_Count'Image (Size_In_Storage_Elements)
1502                         & " does not match allocate size "
1503                         & Storage_Count'Image (Header.Block_Size));
1504            end if;
1505
1506            if Pool.Low_Level_Traces then
1507               Put (Output_File (Pool),
1508                    "info: Deallocated"
1509                    & Storage_Count'Image (Header.Block_Size)
1510                    & " bytes at ");
1511               Print_Address (Output_File (Pool), Storage_Address);
1512               Put (Output_File (Pool),
1513                    " (physically"
1514                    & Storage_Count'Image
1515                      (Header.Block_Size + Extra_Allocation)
1516                    & " bytes at ");
1517               Print_Address (Output_File (Pool), Header.Allocation_Address);
1518               Put (Output_File (Pool), "), at ");
1519
1520               Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1521                         Deallocate_Label'Address,
1522                         Code_Address_For_Deallocate_End);
1523               Print_Traceback (Output_File (Pool),
1524                                "   Memory was allocated at ",
1525                                Header.Alloc_Traceback);
1526            end if;
1527
1528            --  Remove this block from the list of used blocks
1529
1530            Previous :=
1531              To_Address (Header.Dealloc_Traceback);
1532
1533            if Previous = System.Null_Address then
1534               Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
1535
1536               if Pool.First_Used_Block /= System.Null_Address then
1537                  Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
1538                    To_Traceback (null);
1539               end if;
1540
1541            else
1542               Header_Of (Previous).Next := Header.Next;
1543
1544               if Header.Next /= System.Null_Address then
1545                  Header_Of
1546                    (Header.Next).Dealloc_Traceback := To_Address (Previous);
1547               end if;
1548            end if;
1549
1550            --  Update the Alloc_Traceback Frees/Total_Frees members
1551            --  (if present)
1552
1553            if Header.Alloc_Traceback /= null then
1554               Header.Alloc_Traceback.Frees :=
1555                 Header.Alloc_Traceback.Frees + 1;
1556               Header.Alloc_Traceback.Total_Frees :=
1557                 Header.Alloc_Traceback.Total_Frees +
1558                   Byte_Count (Header.Block_Size);
1559            end if;
1560
1561            Pool.Free_Count := Pool.Free_Count + 1;
1562
1563            --  Update the header
1564
1565            Header.all :=
1566              (Allocation_Address => Header.Allocation_Address,
1567               Alloc_Traceback    => Header.Alloc_Traceback,
1568               Dealloc_Traceback  => To_Traceback
1569                 (Find_Or_Create_Traceback
1570                      (Pool, Dealloc,
1571                       Header.Block_Size,
1572                       Deallocate_Label'Address,
1573                       Code_Address_For_Deallocate_End)),
1574               Next               => System.Null_Address,
1575               Block_Size         => -Header.Block_Size);
1576
1577            if Pool.Reset_Content_On_Free then
1578               Set_Dead_Beef (Storage_Address, -Header.Block_Size);
1579            end if;
1580
1581            Pool.Logically_Deallocated :=
1582              Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size);
1583
1584            --  Link this free block with the others (at the end of the list,
1585            --  so that we can start releasing the older blocks first later on)
1586
1587            if Pool.First_Free_Block = System.Null_Address then
1588               Pool.First_Free_Block := Storage_Address;
1589               Pool.Last_Free_Block := Storage_Address;
1590
1591            else
1592               Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
1593               Pool.Last_Free_Block := Storage_Address;
1594            end if;
1595
1596            --  Do not physically release the memory here, but in Alloc.
1597            --  See comment there for details.
1598         end if;
1599      end;
1600
1601      if not Valid then
1602         if Storage_Address = System.Null_Address then
1603            if Pool.Raise_Exceptions and then
1604              Size_In_Storage_Elements /= Storage_Count'Last
1605            then
1606               raise Freeing_Not_Allocated_Storage;
1607            else
1608               Put (Output_File (Pool),
1609                    "error: Freeing Null_Address, at ");
1610               Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1611                         Deallocate_Label'Address,
1612                         Code_Address_For_Deallocate_End);
1613               return;
1614            end if;
1615         end if;
1616
1617         if Allow_Unhandled_Memory
1618           and then not Is_Handled (Storage_Address)
1619         then
1620            System.CRTL.free (Storage_Address);
1621            return;
1622         end if;
1623
1624         if Pool.Raise_Exceptions
1625           and then Size_In_Storage_Elements /= Storage_Count'Last
1626         then
1627            raise Freeing_Not_Allocated_Storage;
1628         else
1629            Put (Output_File (Pool),
1630                 "error: Freeing not allocated storage, at ");
1631            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1632                      Deallocate_Label'Address,
1633                      Code_Address_For_Deallocate_End);
1634         end if;
1635
1636      elsif Header_Block_Size_Was_Less_Than_0 then
1637         if Pool.Raise_Exceptions then
1638            raise Freeing_Deallocated_Storage;
1639         else
1640            Put (Output_File (Pool),
1641                 "error: Freeing already deallocated storage, at ");
1642            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1643                      Deallocate_Label'Address,
1644                      Code_Address_For_Deallocate_End);
1645            Print_Traceback (Output_File (Pool),
1646                             "   Memory already deallocated at ",
1647                            To_Traceback (Header.Dealloc_Traceback));
1648            Print_Traceback (Output_File (Pool), "   Memory was allocated at ",
1649                             Header.Alloc_Traceback);
1650         end if;
1651      end if;
1652   end Deallocate;
1653
1654   --------------------
1655   -- Deallocate_End --
1656   --------------------
1657
1658   --  DO NOT MOVE, this must be right after Deallocate
1659
1660   --  See Allocate_End
1661
1662   --  This is making assumptions about code order that may be invalid ???
1663
1664   procedure Deallocate_End is
1665   begin
1666      <<Deallocate_End_Label>>
1667      Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
1668   end Deallocate_End;
1669
1670   -----------------
1671   -- Dereference --
1672   -----------------
1673
1674   procedure Dereference
1675     (Pool                     : in out Debug_Pool;
1676      Storage_Address          : Address;
1677      Size_In_Storage_Elements : Storage_Count;
1678      Alignment                : Storage_Count)
1679   is
1680      pragma Unreferenced (Alignment, Size_In_Storage_Elements);
1681
1682      Valid   : constant Boolean := Is_Valid (Storage_Address);
1683      Header  : Allocation_Header_Access;
1684
1685   begin
1686      --  Locking policy: we do not do any locking in this procedure. The
1687      --  tables are only read, not written to, and although a problem might
1688      --  appear if someone else is modifying the tables at the same time, this
1689      --  race condition is not intended to be detected by this storage_pool (a
1690      --  now invalid pointer would appear as valid). Instead, we prefer
1691      --  optimum performance for dereferences.
1692
1693      <<Dereference_Label>>
1694
1695      if not Valid then
1696         if Pool.Raise_Exceptions then
1697            raise Accessing_Not_Allocated_Storage;
1698         else
1699            Put (Output_File (Pool),
1700                 "error: Accessing not allocated storage, at ");
1701            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1702                      Dereference_Label'Address,
1703                      Code_Address_For_Dereference_End);
1704         end if;
1705
1706      else
1707         Header := Header_Of (Storage_Address);
1708
1709         if Header.Block_Size < 0 then
1710            if Pool.Raise_Exceptions then
1711               raise Accessing_Deallocated_Storage;
1712            else
1713               Put (Output_File (Pool),
1714                    "error: Accessing deallocated storage, at ");
1715               Put_Line
1716                 (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1717                  Dereference_Label'Address,
1718                  Code_Address_For_Dereference_End);
1719               Print_Traceback (Output_File (Pool), "  First deallocation at ",
1720                                To_Traceback (Header.Dealloc_Traceback));
1721               Print_Traceback (Output_File (Pool), "  Initial allocation at ",
1722                                Header.Alloc_Traceback);
1723            end if;
1724         end if;
1725      end if;
1726   end Dereference;
1727
1728   ---------------------
1729   -- Dereference_End --
1730   ---------------------
1731
1732   --  DO NOT MOVE: this must be right after Dereference
1733
1734   --  See Allocate_End
1735
1736   --  This is making assumptions about code order that may be invalid ???
1737
1738   procedure Dereference_End is
1739   begin
1740      <<Dereference_End_Label>>
1741      Code_Address_For_Dereference_End := Dereference_End_Label'Address;
1742   end Dereference_End;
1743
1744   ----------------
1745   -- Print_Info --
1746   ----------------
1747
1748   procedure Print_Info
1749     (Pool          : Debug_Pool;
1750      Cumulate      : Boolean := False;
1751      Display_Slots : Boolean := False;
1752      Display_Leaks : Boolean := False)
1753   is
1754      package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
1755        (Header_Num => Header,
1756         Element    => Traceback_Htable_Elem,
1757         Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
1758         Null_Ptr   => null,
1759         Set_Next   => Set_Next,
1760         Next       => Next,
1761         Key        => Tracebacks_Array_Access,
1762         Get_Key    => Get_Key,
1763         Hash       => Hash,
1764         Equal      => Equal);
1765      --  This needs a comment ??? probably some of the ones below do too???
1766
1767      Current : System.Address;
1768      Data    : Traceback_Htable_Elem_Ptr;
1769      Elem    : Traceback_Htable_Elem_Ptr;
1770      Header  : Allocation_Header_Access;
1771      K       : Traceback_Kind;
1772
1773   begin
1774      Put_Line
1775        ("Total allocated bytes : " &
1776         Byte_Count'Image (Pool.Allocated));
1777
1778      Put_Line
1779        ("Total logically deallocated bytes : " &
1780         Byte_Count'Image (Pool.Logically_Deallocated));
1781
1782      Put_Line
1783        ("Total physically deallocated bytes : " &
1784         Byte_Count'Image (Pool.Physically_Deallocated));
1785
1786      if Pool.Marked_Blocks_Deallocated then
1787         Put_Line ("Marked blocks were physically deallocated. This is");
1788         Put_Line ("potentially dangerous, and you might want to run");
1789         Put_Line ("again with a lower value of Minimum_To_Free");
1790      end if;
1791
1792      Put_Line
1793        ("Current Water Mark: " &
1794         Byte_Count'Image (Pool.Current_Water_Mark));
1795
1796      Put_Line
1797        ("High Water Mark: " &
1798          Byte_Count'Image (Pool.High_Water));
1799
1800      Put_Line ("");
1801
1802      if Display_Slots then
1803         Data := Backtrace_Htable.Get_First;
1804         while Data /= null loop
1805            if Data.Kind in Alloc .. Dealloc then
1806               Elem :=
1807                 new Traceback_Htable_Elem'
1808                       (Traceback => new Tracebacks_Array'(Data.Traceback.all),
1809                        Count       => Data.Count,
1810                        Kind        => Data.Kind,
1811                        Total       => Data.Total,
1812                        Frees       => Data.Frees,
1813                        Total_Frees => Data.Total_Frees,
1814                        Next        => null);
1815               Backtrace_Htable_Cumulate.Set (Elem);
1816
1817               if Cumulate then
1818                  K := (if Data.Kind = Alloc then Indirect_Alloc
1819                                             else Indirect_Dealloc);
1820
1821                  --  Propagate the direct call to all its parents
1822
1823                  for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
1824                     Elem := Backtrace_Htable_Cumulate.Get
1825                       (Data.Traceback
1826                          (T .. Data.Traceback'Last)'Unrestricted_Access);
1827
1828                     --  If not, insert it
1829
1830                     if Elem = null then
1831                        Elem :=
1832                          new Traceback_Htable_Elem'
1833                                (Traceback =>
1834                                   new Tracebacks_Array'
1835                                         (Data.Traceback
1836                                           (T .. Data.Traceback'Last)),
1837                                 Count       => Data.Count,
1838                                 Kind        => K,
1839                                 Total       => Data.Total,
1840                                 Frees       => Data.Frees,
1841                                 Total_Frees => Data.Total_Frees,
1842                                 Next        => null);
1843                        Backtrace_Htable_Cumulate.Set (Elem);
1844
1845                        --  Properly take into account that the subprograms
1846                        --  indirectly called might be doing either allocations
1847                        --  or deallocations. This needs to be reflected in the
1848                        --  counts.
1849
1850                     else
1851                        Elem.Count := Elem.Count + Data.Count;
1852
1853                        if K = Elem.Kind then
1854                           Elem.Total := Elem.Total + Data.Total;
1855
1856                        elsif Elem.Total > Data.Total then
1857                           Elem.Total := Elem.Total - Data.Total;
1858
1859                        else
1860                           Elem.Kind  := K;
1861                           Elem.Total := Data.Total - Elem.Total;
1862                        end if;
1863                     end if;
1864                  end loop;
1865               end if;
1866
1867               Data := Backtrace_Htable.Get_Next;
1868            end if;
1869         end loop;
1870
1871         Put_Line ("List of allocations/deallocations: ");
1872
1873         Data := Backtrace_Htable_Cumulate.Get_First;
1874         while Data /= null loop
1875            case Data.Kind is
1876               when Alloc            => Put ("alloc (count:");
1877               when Indirect_Alloc   => Put ("indirect alloc (count:");
1878               when Dealloc          => Put ("free  (count:");
1879               when Indirect_Dealloc => Put ("indirect free  (count:");
1880            end case;
1881
1882            Put (Natural'Image (Data.Count) & ", total:" &
1883                 Byte_Count'Image (Data.Total) & ") ");
1884
1885            for T in Data.Traceback'Range loop
1886               Put (Image_C (PC_For (Data.Traceback (T))) & ' ');
1887            end loop;
1888
1889            Put_Line ("");
1890
1891            Data := Backtrace_Htable_Cumulate.Get_Next;
1892         end loop;
1893
1894         Backtrace_Htable_Cumulate.Reset;
1895      end if;
1896
1897      if Display_Leaks then
1898         Put_Line ("");
1899         Put_Line ("List of not deallocated blocks:");
1900
1901         --  Do not try to group the blocks with the same stack traces
1902         --  together. This is done by the gnatmem output.
1903
1904         Current := Pool.First_Used_Block;
1905         while Current /= System.Null_Address loop
1906            Header := Header_Of (Current);
1907
1908            Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
1909
1910            if Header.Alloc_Traceback /= null then
1911               for T in Header.Alloc_Traceback.Traceback'Range loop
1912                  Put (Image_C
1913                       (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
1914               end loop;
1915            end if;
1916
1917            Put_Line ("");
1918            Current := Header.Next;
1919         end loop;
1920      end if;
1921   end Print_Info;
1922
1923   ----------
1924   -- Dump --
1925   ----------
1926
1927   procedure Dump
1928     (Pool   : Debug_Pool;
1929      Size   : Positive;
1930      Report : Report_Type := All_Reports)
1931   is
1932      procedure Do_Report (Sort : Report_Type);
1933      --  Do a specific type of report
1934
1935      ---------------
1936      -- Do_Report --
1937      ---------------
1938
1939      procedure Do_Report (Sort : Report_Type) is
1940         Elem        : Traceback_Htable_Elem_Ptr;
1941         Bigger      : Boolean;
1942         Grand_Total : Float;
1943
1944         Max  : array (1 .. Size) of Traceback_Htable_Elem_Ptr :=
1945           [others => null];
1946         --  Sorted array for the biggest memory users
1947
1948         Allocated_In_Pool : Byte_Count;
1949         --  safe thread Pool.Allocated
1950
1951         Elem_Safe : Traceback_Htable_Elem;
1952         --  safe thread current elem.all;
1953
1954         Max_M_Safe : Traceback_Htable_Elem;
1955         --  safe thread Max(M).all
1956
1957      begin
1958         Put_Line ("");
1959
1960         case Sort is
1961            when All_Reports
1962               | Memory_Usage
1963            =>
1964               Put_Line (Size'Img & " biggest memory users at this time:");
1965               Put_Line ("Results include bytes and chunks still allocated");
1966               Grand_Total := Float (Pool.Current_Water_Mark);
1967
1968            when Allocations_Count =>
1969               Put_Line (Size'Img & " biggest number of live allocations:");
1970               Put_Line ("Results include bytes and chunks still allocated");
1971               Grand_Total := Float (Pool.Current_Water_Mark);
1972
1973            when Sort_Total_Allocs =>
1974               Put_Line (Size'Img & " biggest number of allocations:");
1975               Put_Line ("Results include total bytes and chunks allocated,");
1976               Put_Line ("even if no longer allocated - Deallocations are"
1977                         & " ignored");
1978
1979               declare
1980                  Lock : Scope_Lock;
1981                  pragma Unreferenced (Lock);
1982               begin
1983                  Allocated_In_Pool := Pool.Allocated;
1984               end;
1985
1986               Grand_Total := Float (Allocated_In_Pool);
1987
1988            when Marked_Blocks =>
1989               Put_Line ("Special blocks marked by Mark_Traceback");
1990               Grand_Total := 0.0;
1991         end case;
1992
1993         declare
1994            Lock : Scope_Lock;
1995            pragma Unreferenced (Lock);
1996         begin
1997            Elem := Backtrace_Htable.Get_First;
1998         end;
1999
2000         while Elem /= null loop
2001            declare
2002               Lock : Scope_Lock;
2003               pragma Unreferenced (Lock);
2004            begin
2005               Elem_Safe := Elem.all;
2006            end;
2007
2008            --  Handle only alloc elememts
2009            if Elem_Safe.Kind = Alloc then
2010               --  Ignore small blocks (depending on the sorting criteria) to
2011               --  gain speed.
2012
2013               if (Sort = Memory_Usage
2014                    and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000)
2015                 or else (Sort = Allocations_Count
2016                           and then Elem_Safe.Count - Elem_Safe.Frees >= 1)
2017                 or else (Sort = Sort_Total_Allocs
2018                           and then Elem_Safe.Count > 1)
2019                 or else (Sort = Marked_Blocks
2020                           and then Elem_Safe.Total = 0)
2021               then
2022                  if Sort = Marked_Blocks then
2023                     Grand_Total := Grand_Total + Float (Elem_Safe.Count);
2024                  end if;
2025
2026                  for M in Max'Range loop
2027                     Bigger := Max (M) = null;
2028                     if not Bigger then
2029                        declare
2030                           Lock : Scope_Lock;
2031                           pragma Unreferenced (Lock);
2032                        begin
2033                           Max_M_Safe := Max (M).all;
2034                        end;
2035
2036                        case Sort is
2037                           when All_Reports
2038                              | Memory_Usage
2039                           =>
2040                              Bigger :=
2041                                Max_M_Safe.Total - Max_M_Safe.Total_Frees
2042                                  < Elem_Safe.Total - Elem_Safe.Total_Frees;
2043
2044                           when Allocations_Count =>
2045                              Bigger :=
2046                                Max_M_Safe.Count - Max_M_Safe.Frees
2047                                  < Elem_Safe.Count - Elem_Safe.Frees;
2048
2049                           when Marked_Blocks
2050                              | Sort_Total_Allocs
2051                           =>
2052                              Bigger := Max_M_Safe.Count < Elem_Safe.Count;
2053                        end case;
2054                     end if;
2055
2056                     if Bigger then
2057                        Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1);
2058                        Max (M) := Elem;
2059                        exit;
2060                     end if;
2061                  end loop;
2062               end if;
2063            end if;
2064
2065            declare
2066               Lock : Scope_Lock;
2067               pragma Unreferenced (Lock);
2068            begin
2069               Elem := Backtrace_Htable.Get_Next;
2070            end;
2071         end loop;
2072
2073         if Grand_Total = 0.0 then
2074            Grand_Total := 1.0;
2075         end if;
2076
2077         for M in Max'Range loop
2078            exit when Max (M) = null;
2079            declare
2080               type Percent is delta 0.1 range 0.0 .. 100.0;
2081
2082               P     : Percent;
2083               Total : Byte_Count;
2084
2085            begin
2086               declare
2087                  Lock : Scope_Lock;
2088                  pragma Unreferenced (Lock);
2089               begin
2090                  Max_M_Safe := Max (M).all;
2091               end;
2092
2093               case Sort is
2094                  when All_Reports
2095                     | Allocations_Count
2096                     | Memory_Usage
2097                  =>
2098                     Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees;
2099
2100                  when Sort_Total_Allocs =>
2101                     Total := Max_M_Safe.Total;
2102
2103                  when Marked_Blocks =>
2104                     Total := Byte_Count (Max_M_Safe.Count);
2105               end case;
2106
2107               declare
2108                  Normalized_Total : constant Float := Float (Total);
2109                  --  In multi tasking configuration, memory deallocations
2110                  --  during Do_Report processing can lead to Total >
2111                  --  Grand_Total. As Percent requires Total <= Grand_Total
2112
2113               begin
2114                  if Normalized_Total > Grand_Total then
2115                     P := 100.0;
2116                  else
2117                     P := Percent (100.0 * Normalized_Total / Grand_Total);
2118                  end if;
2119               end;
2120
2121               case Sort is
2122                  when All_Reports
2123                     | Allocations_Count
2124                     | Memory_Usage
2125                  =>
2126                     declare
2127                        Count : constant Natural :=
2128                          Max_M_Safe.Count - Max_M_Safe.Frees;
2129                     begin
2130                        Put (P'Img & "%:" & Total'Img & " bytes in"
2131                             & Count'Img & " chunks at");
2132                     end;
2133
2134                  when Sort_Total_Allocs =>
2135                     Put (P'Img & "%:" & Total'Img & " bytes in"
2136                          & Max_M_Safe.Count'Img & " chunks at");
2137
2138                  when Marked_Blocks =>
2139                     Put (P'Img & "%:"
2140                          & Max_M_Safe.Count'Img & " chunks /"
2141                          & Integer (Grand_Total)'Img & " at");
2142               end case;
2143            end;
2144
2145            for J in Max (M).Traceback'Range loop
2146               Put (" " & Image_C (PC_For (Max (M).Traceback (J))));
2147            end loop;
2148
2149            Put_Line ("");
2150         end loop;
2151      end Do_Report;
2152
2153      --  Local variables
2154
2155      Total_Freed : Byte_Count;
2156      --  safe thread pool logically & physically deallocated
2157
2158      Traceback_Elements_Allocated : Byte_Count;
2159      --  safe thread Traceback_Count
2160
2161      Validity_Elements_Allocated : Byte_Count;
2162      --  safe thread Validity_Count
2163
2164      Ada_Allocs_Bytes : Byte_Count;
2165      --  safe thread pool Allocated
2166
2167      Ada_Allocs_Chunks : Byte_Count;
2168      --  safe thread pool Alloc_Count
2169
2170      Ada_Free_Chunks : Byte_Count;
2171      --  safe thread pool Free_Count
2172
2173   --  Start of processing for Dump
2174
2175   begin
2176      declare
2177         Lock : Scope_Lock;
2178         pragma Unreferenced (Lock);
2179      begin
2180         Total_Freed :=
2181           Pool.Logically_Deallocated + Pool.Physically_Deallocated;
2182         Traceback_Elements_Allocated := Traceback_Count;
2183         Validity_Elements_Allocated := Validity_Count;
2184         Ada_Allocs_Bytes := Pool.Allocated;
2185         Ada_Allocs_Chunks := Pool.Alloc_Count;
2186         Ada_Free_Chunks := Pool.Free_Count;
2187      end;
2188
2189      Put_Line
2190        ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img);
2191      Put_Line
2192        ("Validity elements allocated: " & Validity_Elements_Allocated'Img);
2193      Put_Line ("");
2194
2195      Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img
2196                & " bytes in" & Ada_Allocs_Chunks'Img & " chunks");
2197      Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" &
2198                  Ada_Free_Chunks'Img
2199                & " chunks");
2200      Put_Line ("Ada Current watermark: "
2201                & Byte_Count'Image (Pool.Current_Water_Mark)
2202                & " in" & Byte_Count'Image (Ada_Allocs_Chunks -
2203                    Ada_Free_Chunks) & " chunks");
2204      Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img);
2205
2206      case Report is
2207         when All_Reports =>
2208            for Sort in Report_Type loop
2209               if Sort /= All_Reports then
2210                  Do_Report (Sort);
2211               end if;
2212            end loop;
2213
2214         when others =>
2215            Do_Report (Report);
2216      end case;
2217   end Dump;
2218
2219   -----------------
2220   -- Dump_Stdout --
2221   -----------------
2222
2223   procedure Dump_Stdout
2224     (Pool   : Debug_Pool;
2225      Size   : Positive;
2226      Report : Report_Type := All_Reports)
2227   is
2228      procedure Internal is new Dump
2229        (Put_Line => Stdout_Put_Line,
2230         Put      => Stdout_Put);
2231
2232   --  Start of processing for Dump_Stdout
2233
2234   begin
2235      Internal (Pool, Size, Report);
2236   end Dump_Stdout;
2237
2238   -----------
2239   -- Reset --
2240   -----------
2241
2242   procedure Reset is
2243      Elem : Traceback_Htable_Elem_Ptr;
2244      Lock : Scope_Lock;
2245      pragma Unreferenced (Lock);
2246   begin
2247      Elem := Backtrace_Htable.Get_First;
2248      while Elem /= null loop
2249         Elem.Count := 0;
2250         Elem.Frees := 0;
2251         Elem.Total := 0;
2252         Elem.Total_Frees := 0;
2253         Elem := Backtrace_Htable.Get_Next;
2254      end loop;
2255   end Reset;
2256
2257   ------------------
2258   -- Storage_Size --
2259   ------------------
2260
2261   function Storage_Size (Pool : Debug_Pool) return Storage_Count is
2262      pragma Unreferenced (Pool);
2263   begin
2264      return Storage_Count'Last;
2265   end Storage_Size;
2266
2267   ---------------------
2268   -- High_Water_Mark --
2269   ---------------------
2270
2271   function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is
2272      Lock : Scope_Lock;
2273      pragma Unreferenced (Lock);
2274   begin
2275      return Pool.High_Water;
2276   end High_Water_Mark;
2277
2278   ------------------------
2279   -- Current_Water_Mark --
2280   ------------------------
2281
2282   function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is
2283      Lock : Scope_Lock;
2284      pragma Unreferenced (Lock);
2285   begin
2286      return Pool.Allocated - Pool.Logically_Deallocated -
2287        Pool.Physically_Deallocated;
2288   end Current_Water_Mark;
2289
2290   ------------------------------
2291   -- System_Memory_Debug_Pool --
2292   ------------------------------
2293
2294   procedure System_Memory_Debug_Pool
2295     (Has_Unhandled_Memory : Boolean := True)
2296   is
2297      Lock : Scope_Lock;
2298      pragma Unreferenced (Lock);
2299   begin
2300      System_Memory_Debug_Pool_Enabled := True;
2301      Allow_Unhandled_Memory := Has_Unhandled_Memory;
2302   end System_Memory_Debug_Pool;
2303
2304   ---------------
2305   -- Configure --
2306   ---------------
2307
2308   procedure Configure
2309     (Pool                           : in out Debug_Pool;
2310      Stack_Trace_Depth              : Natural := Default_Stack_Trace_Depth;
2311      Maximum_Logically_Freed_Memory : SSC     := Default_Max_Freed;
2312      Minimum_To_Free                : SSC     := Default_Min_Freed;
2313      Reset_Content_On_Free          : Boolean := Default_Reset_Content;
2314      Raise_Exceptions               : Boolean := Default_Raise_Exceptions;
2315      Advanced_Scanning              : Boolean := Default_Advanced_Scanning;
2316      Errors_To_Stdout               : Boolean := Default_Errors_To_Stdout;
2317      Low_Level_Traces               : Boolean := Default_Low_Level_Traces)
2318   is
2319      Lock : Scope_Lock;
2320      pragma Unreferenced (Lock);
2321   begin
2322      Pool.Stack_Trace_Depth              := Stack_Trace_Depth;
2323      Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
2324      Pool.Reset_Content_On_Free          := Reset_Content_On_Free;
2325      Pool.Raise_Exceptions               := Raise_Exceptions;
2326      Pool.Minimum_To_Free                := Minimum_To_Free;
2327      Pool.Advanced_Scanning              := Advanced_Scanning;
2328      Pool.Errors_To_Stdout               := Errors_To_Stdout;
2329      Pool.Low_Level_Traces               := Low_Level_Traces;
2330   end Configure;
2331
2332   ----------------
2333   -- Print_Pool --
2334   ----------------
2335
2336   procedure Print_Pool (A : System.Address) is
2337      Storage : constant Address := A;
2338      Valid   : constant Boolean := Is_Valid (Storage);
2339      Header  : Allocation_Header_Access;
2340
2341   begin
2342      --  We might get Null_Address if the call from gdb was done incorrectly.
2343      --  For instance, doing a "print_pool(my_var)" passes 0x0, instead of
2344      --  passing the value of my_var.
2345
2346      if A = System.Null_Address then
2347         Put_Line
2348            (Standard_Output, "Memory not under control of the storage pool");
2349         return;
2350      end if;
2351
2352      if not Valid then
2353         Put_Line
2354            (Standard_Output, "Memory not under control of the storage pool");
2355
2356      else
2357         Header := Header_Of (Storage);
2358         Print_Address (Standard_Output, A);
2359         Put_Line (Standard_Output, " allocated at:");
2360         Print_Traceback (Standard_Output, "", Header.Alloc_Traceback);
2361
2362         if To_Traceback (Header.Dealloc_Traceback) /= null then
2363            Print_Address (Standard_Output, A);
2364            Put_Line (Standard_Output,
2365                      " logically freed memory, deallocated at:");
2366            Print_Traceback (Standard_Output, "",
2367                             To_Traceback (Header.Dealloc_Traceback));
2368         end if;
2369      end if;
2370   end Print_Pool;
2371
2372   -----------------------
2373   -- Print_Info_Stdout --
2374   -----------------------
2375
2376   procedure Print_Info_Stdout
2377     (Pool          : Debug_Pool;
2378      Cumulate      : Boolean := False;
2379      Display_Slots : Boolean := False;
2380      Display_Leaks : Boolean := False)
2381   is
2382      procedure Internal is new Print_Info
2383        (Put_Line => Stdout_Put_Line,
2384         Put      => Stdout_Put);
2385
2386   --  Start of processing for Print_Info_Stdout
2387
2388   begin
2389      Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
2390   end Print_Info_Stdout;
2391
2392   ------------------
2393   -- Dump_Gnatmem --
2394   ------------------
2395
2396   procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
2397      type File_Ptr is new System.Address;
2398
2399      function fopen (Path : String; Mode : String) return File_Ptr;
2400      pragma Import (C, fopen);
2401
2402      procedure fwrite
2403        (Ptr    : System.Address;
2404         Size   : size_t;
2405         Nmemb  : size_t;
2406         Stream : File_Ptr);
2407
2408      procedure fwrite
2409        (Str    : String;
2410         Size   : size_t;
2411         Nmemb  : size_t;
2412         Stream : File_Ptr);
2413      pragma Import (C, fwrite);
2414
2415      procedure fputc (C : Integer; Stream : File_Ptr);
2416      pragma Import (C, fputc);
2417
2418      procedure fclose (Stream : File_Ptr);
2419      pragma Import (C, fclose);
2420
2421      Address_Size : constant size_t :=
2422                       System.Address'Max_Size_In_Storage_Elements;
2423      --  Size in bytes of a pointer
2424
2425      File        : File_Ptr;
2426      Current     : System.Address;
2427      Header      : Allocation_Header_Access;
2428      Actual_Size : size_t;
2429      Num_Calls   : Integer;
2430      Tracebk     : Tracebacks_Array_Access;
2431      Dummy_Time  : Duration := 1.0;
2432
2433   begin
2434      File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
2435      fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
2436
2437      fwrite
2438        (Ptr    => Dummy_Time'Address,
2439         Size   => Duration'Max_Size_In_Storage_Elements,
2440         Nmemb  => 1,
2441         Stream => File);
2442
2443      --  List of not deallocated blocks (see Print_Info)
2444
2445      Current := Pool.First_Used_Block;
2446      while Current /= System.Null_Address loop
2447         Header := Header_Of (Current);
2448
2449         Actual_Size := size_t (Header.Block_Size);
2450
2451         if Header.Alloc_Traceback /= null then
2452            Tracebk   := Header.Alloc_Traceback.Traceback;
2453            Num_Calls := Tracebk'Length;
2454
2455            --  (Code taken from memtrack.adb in GNAT's sources)
2456
2457            --  Logs allocation call using the format:
2458
2459            --  'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
2460
2461            fputc (Character'Pos ('A'), File);
2462            fwrite (Current'Address, Address_Size, 1, File);
2463
2464            fwrite
2465              (Ptr    => Actual_Size'Address,
2466               Size   => size_t'Max_Size_In_Storage_Elements,
2467               Nmemb  => 1,
2468               Stream => File);
2469
2470            fwrite
2471              (Ptr    => Dummy_Time'Address,
2472               Size   => Duration'Max_Size_In_Storage_Elements,
2473               Nmemb  => 1,
2474               Stream => File);
2475
2476            fwrite
2477              (Ptr    => Num_Calls'Address,
2478               Size   => Integer'Max_Size_In_Storage_Elements,
2479               Nmemb  => 1,
2480               Stream => File);
2481
2482            for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
2483               declare
2484                  Ptr : System.Address := PC_For (Tracebk (J));
2485               begin
2486                  fwrite (Ptr'Address, Address_Size, 1, File);
2487               end;
2488            end loop;
2489         end if;
2490
2491         Current := Header.Next;
2492      end loop;
2493
2494      fclose (File);
2495   end Dump_Gnatmem;
2496
2497   ----------------
2498   -- Stdout_Put --
2499   ----------------
2500
2501   procedure Stdout_Put (S : String) is
2502   begin
2503      Put (Standard_Output, S);
2504   end Stdout_Put;
2505
2506   ---------------------
2507   -- Stdout_Put_Line --
2508   ---------------------
2509
2510   procedure Stdout_Put_Line (S : String) is
2511   begin
2512      Put_Line (Standard_Output, S);
2513   end Stdout_Put_Line;
2514
2515--  Package initialization
2516
2517begin
2518   Allocate_End;
2519   Deallocate_End;
2520   Dereference_End;
2521end GNAT.Debug_Pools;
2522