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-2019, 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;
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
1424      if Is_Valid (Storage_Address) then
1425         declare
1426            Header : constant Allocation_Header_Access :=
1427                       Header_Of (Storage_Address);
1428
1429         begin
1430            if Header.Block_Size >= 0 then
1431               Valid := True;
1432               Size_In_Storage_Elements := Header.Block_Size;
1433            else
1434               Valid := False;
1435            end if;
1436         end;
1437      else
1438         Valid := False;
1439      end if;
1440   end Get_Size;
1441
1442   ---------------------
1443   -- Print_Traceback --
1444   ---------------------
1445
1446   procedure Print_Traceback
1447     (Output_File : File_Type;
1448      Prefix      : String;
1449      Traceback   : Traceback_Htable_Elem_Ptr)
1450   is
1451   begin
1452      if Traceback /= null then
1453         Put (Output_File, Prefix);
1454         Put_Line (Output_File, 0, Traceback.Traceback);
1455      end if;
1456   end Print_Traceback;
1457
1458   ----------------
1459   -- Deallocate --
1460   ----------------
1461
1462   procedure Deallocate
1463     (Pool                     : in out Debug_Pool;
1464      Storage_Address          : Address;
1465      Size_In_Storage_Elements : Storage_Count;
1466      Alignment                : Storage_Count)
1467   is
1468      pragma Unreferenced (Alignment);
1469
1470      Header   : constant Allocation_Header_Access :=
1471                   Header_Of (Storage_Address);
1472      Previous : System.Address;
1473      Valid    : Boolean;
1474
1475      Header_Block_Size_Was_Less_Than_0 : Boolean := True;
1476
1477   begin
1478      <<Deallocate_Label>>
1479
1480      declare
1481         Lock : Scope_Lock;
1482         pragma Unreferenced (Lock);
1483
1484      begin
1485         Valid := Is_Valid (Storage_Address);
1486
1487         if Valid and then not (Header.Block_Size < 0) then
1488            Header_Block_Size_Was_Less_Than_0 := False;
1489
1490            --  Some sort of codegen problem or heap corruption caused the
1491            --  Size_In_Storage_Elements to be wrongly computed. The code
1492            --  below is all based on the assumption that Header.all is not
1493            --  corrupted, such that the error is non-fatal.
1494
1495            if Header.Block_Size /= Size_In_Storage_Elements and then
1496              Size_In_Storage_Elements /= Storage_Count'Last
1497            then
1498               Put_Line (Output_File (Pool),
1499                         "error: Deallocate size "
1500                         & Storage_Count'Image (Size_In_Storage_Elements)
1501                         & " does not match allocate size "
1502                         & Storage_Count'Image (Header.Block_Size));
1503            end if;
1504
1505            if Pool.Low_Level_Traces then
1506               Put (Output_File (Pool),
1507                    "info: Deallocated"
1508                    & Storage_Count'Image (Header.Block_Size)
1509                    & " bytes at ");
1510               Print_Address (Output_File (Pool), Storage_Address);
1511               Put (Output_File (Pool),
1512                    " (physically"
1513                    & Storage_Count'Image
1514                      (Header.Block_Size + Extra_Allocation)
1515                    & " bytes at ");
1516               Print_Address (Output_File (Pool), Header.Allocation_Address);
1517               Put (Output_File (Pool), "), at ");
1518
1519               Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1520                         Deallocate_Label'Address,
1521                         Code_Address_For_Deallocate_End);
1522               Print_Traceback (Output_File (Pool),
1523                                "   Memory was allocated at ",
1524                                Header.Alloc_Traceback);
1525            end if;
1526
1527            --  Remove this block from the list of used blocks
1528
1529            Previous :=
1530              To_Address (Header.Dealloc_Traceback);
1531
1532            if Previous = System.Null_Address then
1533               Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
1534
1535               if Pool.First_Used_Block /= System.Null_Address then
1536                  Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
1537                    To_Traceback (null);
1538               end if;
1539
1540            else
1541               Header_Of (Previous).Next := Header.Next;
1542
1543               if Header.Next /= System.Null_Address then
1544                  Header_Of
1545                    (Header.Next).Dealloc_Traceback := To_Address (Previous);
1546               end if;
1547            end if;
1548
1549            --  Update the Alloc_Traceback Frees/Total_Frees members
1550            --  (if present)
1551
1552            if Header.Alloc_Traceback /= null then
1553               Header.Alloc_Traceback.Frees :=
1554                 Header.Alloc_Traceback.Frees + 1;
1555               Header.Alloc_Traceback.Total_Frees :=
1556                 Header.Alloc_Traceback.Total_Frees +
1557                   Byte_Count (Header.Block_Size);
1558            end if;
1559
1560            Pool.Free_Count := Pool.Free_Count + 1;
1561
1562            --  Update the header
1563
1564            Header.all :=
1565              (Allocation_Address => Header.Allocation_Address,
1566               Alloc_Traceback    => Header.Alloc_Traceback,
1567               Dealloc_Traceback  => To_Traceback
1568                 (Find_Or_Create_Traceback
1569                      (Pool, Dealloc,
1570                       Header.Block_Size,
1571                       Deallocate_Label'Address,
1572                       Code_Address_For_Deallocate_End)),
1573               Next               => System.Null_Address,
1574               Block_Size         => -Header.Block_Size);
1575
1576            if Pool.Reset_Content_On_Free then
1577               Set_Dead_Beef (Storage_Address, -Header.Block_Size);
1578            end if;
1579
1580            Pool.Logically_Deallocated :=
1581              Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size);
1582
1583            --  Link this free block with the others (at the end of the list,
1584            --  so that we can start releasing the older blocks first later on)
1585
1586            if Pool.First_Free_Block = System.Null_Address then
1587               Pool.First_Free_Block := Storage_Address;
1588               Pool.Last_Free_Block := Storage_Address;
1589
1590            else
1591               Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
1592               Pool.Last_Free_Block := Storage_Address;
1593            end if;
1594
1595            --  Do not physically release the memory here, but in Alloc.
1596            --  See comment there for details.
1597         end if;
1598      end;
1599
1600      if not Valid then
1601         if Storage_Address = System.Null_Address then
1602            if Pool.Raise_Exceptions and then
1603              Size_In_Storage_Elements /= Storage_Count'Last
1604            then
1605               raise Freeing_Not_Allocated_Storage;
1606            else
1607               Put (Output_File (Pool),
1608                    "error: Freeing Null_Address, at ");
1609               Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1610                         Deallocate_Label'Address,
1611                         Code_Address_For_Deallocate_End);
1612               return;
1613            end if;
1614         end if;
1615
1616         if Allow_Unhandled_Memory
1617           and then not Is_Handled (Storage_Address)
1618         then
1619            System.CRTL.free (Storage_Address);
1620            return;
1621         end if;
1622
1623         if Pool.Raise_Exceptions
1624           and then Size_In_Storage_Elements /= Storage_Count'Last
1625         then
1626            raise Freeing_Not_Allocated_Storage;
1627         else
1628            Put (Output_File (Pool),
1629                 "error: Freeing not allocated storage, at ");
1630            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1631                      Deallocate_Label'Address,
1632                      Code_Address_For_Deallocate_End);
1633         end if;
1634
1635      elsif Header_Block_Size_Was_Less_Than_0 then
1636         if Pool.Raise_Exceptions then
1637            raise Freeing_Deallocated_Storage;
1638         else
1639            Put (Output_File (Pool),
1640                 "error: Freeing already deallocated storage, at ");
1641            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1642                      Deallocate_Label'Address,
1643                      Code_Address_For_Deallocate_End);
1644            Print_Traceback (Output_File (Pool),
1645                             "   Memory already deallocated at ",
1646                            To_Traceback (Header.Dealloc_Traceback));
1647            Print_Traceback (Output_File (Pool), "   Memory was allocated at ",
1648                             Header.Alloc_Traceback);
1649         end if;
1650      end if;
1651   end Deallocate;
1652
1653   --------------------
1654   -- Deallocate_End --
1655   --------------------
1656
1657   --  DO NOT MOVE, this must be right after Deallocate
1658
1659   --  See Allocate_End
1660
1661   --  This is making assumptions about code order that may be invalid ???
1662
1663   procedure Deallocate_End is
1664   begin
1665      <<Deallocate_End_Label>>
1666      Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
1667   end Deallocate_End;
1668
1669   -----------------
1670   -- Dereference --
1671   -----------------
1672
1673   procedure Dereference
1674     (Pool                     : in out Debug_Pool;
1675      Storage_Address          : Address;
1676      Size_In_Storage_Elements : Storage_Count;
1677      Alignment                : Storage_Count)
1678   is
1679      pragma Unreferenced (Alignment, Size_In_Storage_Elements);
1680
1681      Valid   : constant Boolean := Is_Valid (Storage_Address);
1682      Header  : Allocation_Header_Access;
1683
1684   begin
1685      --  Locking policy: we do not do any locking in this procedure. The
1686      --  tables are only read, not written to, and although a problem might
1687      --  appear if someone else is modifying the tables at the same time, this
1688      --  race condition is not intended to be detected by this storage_pool (a
1689      --  now invalid pointer would appear as valid). Instead, we prefer
1690      --  optimum performance for dereferences.
1691
1692      <<Dereference_Label>>
1693
1694      if not Valid then
1695         if Pool.Raise_Exceptions then
1696            raise Accessing_Not_Allocated_Storage;
1697         else
1698            Put (Output_File (Pool),
1699                 "error: Accessing not allocated storage, at ");
1700            Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1701                      Dereference_Label'Address,
1702                      Code_Address_For_Dereference_End);
1703         end if;
1704
1705      else
1706         Header := Header_Of (Storage_Address);
1707
1708         if Header.Block_Size < 0 then
1709            if Pool.Raise_Exceptions then
1710               raise Accessing_Deallocated_Storage;
1711            else
1712               Put (Output_File (Pool),
1713                    "error: Accessing deallocated storage, at ");
1714               Put_Line
1715                 (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1716                  Dereference_Label'Address,
1717                  Code_Address_For_Dereference_End);
1718               Print_Traceback (Output_File (Pool), "  First deallocation at ",
1719                                To_Traceback (Header.Dealloc_Traceback));
1720               Print_Traceback (Output_File (Pool), "  Initial allocation at ",
1721                                Header.Alloc_Traceback);
1722            end if;
1723         end if;
1724      end if;
1725   end Dereference;
1726
1727   ---------------------
1728   -- Dereference_End --
1729   ---------------------
1730
1731   --  DO NOT MOVE: this must be right after Dereference
1732
1733   --  See Allocate_End
1734
1735   --  This is making assumptions about code order that may be invalid ???
1736
1737   procedure Dereference_End is
1738   begin
1739      <<Dereference_End_Label>>
1740      Code_Address_For_Dereference_End := Dereference_End_Label'Address;
1741   end Dereference_End;
1742
1743   ----------------
1744   -- Print_Info --
1745   ----------------
1746
1747   procedure Print_Info
1748     (Pool          : Debug_Pool;
1749      Cumulate      : Boolean := False;
1750      Display_Slots : Boolean := False;
1751      Display_Leaks : Boolean := False)
1752   is
1753      package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
1754        (Header_Num => Header,
1755         Element    => Traceback_Htable_Elem,
1756         Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
1757         Null_Ptr   => null,
1758         Set_Next   => Set_Next,
1759         Next       => Next,
1760         Key        => Tracebacks_Array_Access,
1761         Get_Key    => Get_Key,
1762         Hash       => Hash,
1763         Equal      => Equal);
1764      --  This needs a comment ??? probably some of the ones below do too???
1765
1766      Current : System.Address;
1767      Data    : Traceback_Htable_Elem_Ptr;
1768      Elem    : Traceback_Htable_Elem_Ptr;
1769      Header  : Allocation_Header_Access;
1770      K       : Traceback_Kind;
1771
1772   begin
1773      Put_Line
1774        ("Total allocated bytes : " &
1775         Byte_Count'Image (Pool.Allocated));
1776
1777      Put_Line
1778        ("Total logically deallocated bytes : " &
1779         Byte_Count'Image (Pool.Logically_Deallocated));
1780
1781      Put_Line
1782        ("Total physically deallocated bytes : " &
1783         Byte_Count'Image (Pool.Physically_Deallocated));
1784
1785      if Pool.Marked_Blocks_Deallocated then
1786         Put_Line ("Marked blocks were physically deallocated. This is");
1787         Put_Line ("potentially dangerous, and you might want to run");
1788         Put_Line ("again with a lower value of Minimum_To_Free");
1789      end if;
1790
1791      Put_Line
1792        ("Current Water Mark: " &
1793         Byte_Count'Image (Pool.Current_Water_Mark));
1794
1795      Put_Line
1796        ("High Water Mark: " &
1797          Byte_Count'Image (Pool.High_Water));
1798
1799      Put_Line ("");
1800
1801      if Display_Slots then
1802         Data := Backtrace_Htable.Get_First;
1803         while Data /= null loop
1804            if Data.Kind in Alloc .. Dealloc then
1805               Elem :=
1806                 new Traceback_Htable_Elem'
1807                       (Traceback => new Tracebacks_Array'(Data.Traceback.all),
1808                        Count       => Data.Count,
1809                        Kind        => Data.Kind,
1810                        Total       => Data.Total,
1811                        Frees       => Data.Frees,
1812                        Total_Frees => Data.Total_Frees,
1813                        Next        => null);
1814               Backtrace_Htable_Cumulate.Set (Elem);
1815
1816               if Cumulate then
1817                  K := (if Data.Kind = Alloc then Indirect_Alloc
1818                                             else Indirect_Dealloc);
1819
1820                  --  Propagate the direct call to all its parents
1821
1822                  for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
1823                     Elem := Backtrace_Htable_Cumulate.Get
1824                       (Data.Traceback
1825                          (T .. Data.Traceback'Last)'Unrestricted_Access);
1826
1827                     --  If not, insert it
1828
1829                     if Elem = null then
1830                        Elem :=
1831                          new Traceback_Htable_Elem'
1832                                (Traceback =>
1833                                   new Tracebacks_Array'
1834                                         (Data.Traceback
1835                                           (T .. Data.Traceback'Last)),
1836                                 Count       => Data.Count,
1837                                 Kind        => K,
1838                                 Total       => Data.Total,
1839                                 Frees       => Data.Frees,
1840                                 Total_Frees => Data.Total_Frees,
1841                                 Next        => null);
1842                        Backtrace_Htable_Cumulate.Set (Elem);
1843
1844                        --  Properly take into account that the subprograms
1845                        --  indirectly called might be doing either allocations
1846                        --  or deallocations. This needs to be reflected in the
1847                        --  counts.
1848
1849                     else
1850                        Elem.Count := Elem.Count + Data.Count;
1851
1852                        if K = Elem.Kind then
1853                           Elem.Total := Elem.Total + Data.Total;
1854
1855                        elsif Elem.Total > Data.Total then
1856                           Elem.Total := Elem.Total - Data.Total;
1857
1858                        else
1859                           Elem.Kind  := K;
1860                           Elem.Total := Data.Total - Elem.Total;
1861                        end if;
1862                     end if;
1863                  end loop;
1864               end if;
1865
1866               Data := Backtrace_Htable.Get_Next;
1867            end if;
1868         end loop;
1869
1870         Put_Line ("List of allocations/deallocations: ");
1871
1872         Data := Backtrace_Htable_Cumulate.Get_First;
1873         while Data /= null loop
1874            case Data.Kind is
1875               when Alloc            => Put ("alloc (count:");
1876               when Indirect_Alloc   => Put ("indirect alloc (count:");
1877               when Dealloc          => Put ("free  (count:");
1878               when Indirect_Dealloc => Put ("indirect free  (count:");
1879            end case;
1880
1881            Put (Natural'Image (Data.Count) & ", total:" &
1882                 Byte_Count'Image (Data.Total) & ") ");
1883
1884            for T in Data.Traceback'Range loop
1885               Put (Image_C (PC_For (Data.Traceback (T))) & ' ');
1886            end loop;
1887
1888            Put_Line ("");
1889
1890            Data := Backtrace_Htable_Cumulate.Get_Next;
1891         end loop;
1892
1893         Backtrace_Htable_Cumulate.Reset;
1894      end if;
1895
1896      if Display_Leaks then
1897         Put_Line ("");
1898         Put_Line ("List of not deallocated blocks:");
1899
1900         --  Do not try to group the blocks with the same stack traces
1901         --  together. This is done by the gnatmem output.
1902
1903         Current := Pool.First_Used_Block;
1904         while Current /= System.Null_Address loop
1905            Header := Header_Of (Current);
1906
1907            Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
1908
1909            if Header.Alloc_Traceback /= null then
1910               for T in Header.Alloc_Traceback.Traceback'Range loop
1911                  Put (Image_C
1912                       (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
1913               end loop;
1914            end if;
1915
1916            Put_Line ("");
1917            Current := Header.Next;
1918         end loop;
1919      end if;
1920   end Print_Info;
1921
1922   ----------
1923   -- Dump --
1924   ----------
1925
1926   procedure Dump
1927     (Pool   : Debug_Pool;
1928      Size   : Positive;
1929      Report : Report_Type := All_Reports)
1930   is
1931      procedure Do_Report (Sort : Report_Type);
1932      --  Do a specific type of report
1933
1934      ---------------
1935      -- Do_Report --
1936      ---------------
1937
1938      procedure Do_Report (Sort : Report_Type) is
1939         Elem        : Traceback_Htable_Elem_Ptr;
1940         Bigger      : Boolean;
1941         Grand_Total : Float;
1942
1943         Max  : array (1 .. Size) of Traceback_Htable_Elem_Ptr :=
1944           (others => null);
1945         --  Sorted array for the biggest memory users
1946
1947         Allocated_In_Pool : Byte_Count;
1948         --  safe thread Pool.Allocated
1949
1950         Elem_Safe : Traceback_Htable_Elem;
1951         --  safe thread current elem.all;
1952
1953         Max_M_Safe : Traceback_Htable_Elem;
1954         --  safe thread Max(M).all
1955
1956      begin
1957         Put_Line ("");
1958
1959         case Sort is
1960            when All_Reports
1961               | Memory_Usage
1962            =>
1963               Put_Line (Size'Img & " biggest memory users at this time:");
1964               Put_Line ("Results include bytes and chunks still allocated");
1965               Grand_Total := Float (Pool.Current_Water_Mark);
1966
1967            when Allocations_Count =>
1968               Put_Line (Size'Img & " biggest number of live allocations:");
1969               Put_Line ("Results include bytes and chunks still allocated");
1970               Grand_Total := Float (Pool.Current_Water_Mark);
1971
1972            when Sort_Total_Allocs =>
1973               Put_Line (Size'Img & " biggest number of allocations:");
1974               Put_Line ("Results include total bytes and chunks allocated,");
1975               Put_Line ("even if no longer allocated - Deallocations are"
1976                         & " ignored");
1977
1978               declare
1979                  Lock : Scope_Lock;
1980                  pragma Unreferenced (Lock);
1981               begin
1982                  Allocated_In_Pool := Pool.Allocated;
1983               end;
1984
1985               Grand_Total := Float (Allocated_In_Pool);
1986
1987            when Marked_Blocks =>
1988               Put_Line ("Special blocks marked by Mark_Traceback");
1989               Grand_Total := 0.0;
1990         end case;
1991
1992         declare
1993            Lock : Scope_Lock;
1994            pragma Unreferenced (Lock);
1995         begin
1996            Elem := Backtrace_Htable.Get_First;
1997         end;
1998
1999         while Elem /= null loop
2000            declare
2001               Lock : Scope_Lock;
2002               pragma Unreferenced (Lock);
2003            begin
2004               Elem_Safe := Elem.all;
2005            end;
2006
2007            --  Handle only alloc elememts
2008            if Elem_Safe.Kind = Alloc then
2009               --  Ignore small blocks (depending on the sorting criteria) to
2010               --  gain speed.
2011
2012               if (Sort = Memory_Usage
2013                    and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000)
2014                 or else (Sort = Allocations_Count
2015                           and then Elem_Safe.Count - Elem_Safe.Frees >= 1)
2016                 or else (Sort = Sort_Total_Allocs
2017                           and then Elem_Safe.Count > 1)
2018                 or else (Sort = Marked_Blocks
2019                           and then Elem_Safe.Total = 0)
2020               then
2021                  if Sort = Marked_Blocks then
2022                     Grand_Total := Grand_Total + Float (Elem_Safe.Count);
2023                  end if;
2024
2025                  for M in Max'Range loop
2026                     Bigger := Max (M) = null;
2027                     if not Bigger then
2028                        declare
2029                           Lock : Scope_Lock;
2030                           pragma Unreferenced (Lock);
2031                        begin
2032                           Max_M_Safe := Max (M).all;
2033                        end;
2034
2035                        case Sort is
2036                           when All_Reports
2037                              | Memory_Usage
2038                           =>
2039                              Bigger :=
2040                                Max_M_Safe.Total - Max_M_Safe.Total_Frees
2041                                  < Elem_Safe.Total - Elem_Safe.Total_Frees;
2042
2043                           when Allocations_Count =>
2044                              Bigger :=
2045                                Max_M_Safe.Count - Max_M_Safe.Frees
2046                                  < Elem_Safe.Count - Elem_Safe.Frees;
2047
2048                           when Marked_Blocks
2049                              | Sort_Total_Allocs
2050                           =>
2051                              Bigger := Max_M_Safe.Count < Elem_Safe.Count;
2052                        end case;
2053                     end if;
2054
2055                     if Bigger then
2056                        Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1);
2057                        Max (M) := Elem;
2058                        exit;
2059                     end if;
2060                  end loop;
2061               end if;
2062            end if;
2063
2064            declare
2065               Lock : Scope_Lock;
2066               pragma Unreferenced (Lock);
2067            begin
2068               Elem := Backtrace_Htable.Get_Next;
2069            end;
2070         end loop;
2071
2072         if Grand_Total = 0.0 then
2073            Grand_Total := 1.0;
2074         end if;
2075
2076         for M in Max'Range loop
2077            exit when Max (M) = null;
2078            declare
2079               type Percent is delta 0.1 range 0.0 .. 100.0;
2080
2081               P     : Percent;
2082               Total : Byte_Count;
2083
2084            begin
2085               declare
2086                  Lock : Scope_Lock;
2087                  pragma Unreferenced (Lock);
2088               begin
2089                  Max_M_Safe := Max (M).all;
2090               end;
2091
2092               case Sort is
2093                  when All_Reports
2094                     | Allocations_Count
2095                     | Memory_Usage
2096                  =>
2097                     Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees;
2098
2099                  when Sort_Total_Allocs =>
2100                     Total := Max_M_Safe.Total;
2101
2102                  when Marked_Blocks =>
2103                     Total := Byte_Count (Max_M_Safe.Count);
2104               end case;
2105
2106               declare
2107                  Normalized_Total : constant Float := Float (Total);
2108                  --  In multi tasking configuration, memory deallocations
2109                  --  during Do_Report processing can lead to Total >
2110                  --  Grand_Total. As Percent requires Total <= Grand_Total
2111
2112               begin
2113                  if Normalized_Total > Grand_Total then
2114                     P := 100.0;
2115                  else
2116                     P := Percent (100.0 * Normalized_Total / Grand_Total);
2117                  end if;
2118               end;
2119
2120               case Sort is
2121                  when All_Reports
2122                     | Allocations_Count
2123                     | Memory_Usage
2124                  =>
2125                     declare
2126                        Count : constant Natural :=
2127                          Max_M_Safe.Count - Max_M_Safe.Frees;
2128                     begin
2129                        Put (P'Img & "%:" & Total'Img & " bytes in"
2130                             & Count'Img & " chunks at");
2131                     end;
2132
2133                  when Sort_Total_Allocs =>
2134                     Put (P'Img & "%:" & Total'Img & " bytes in"
2135                          & Max_M_Safe.Count'Img & " chunks at");
2136
2137                  when Marked_Blocks =>
2138                     Put (P'Img & "%:"
2139                          & Max_M_Safe.Count'Img & " chunks /"
2140                          & Integer (Grand_Total)'Img & " at");
2141               end case;
2142            end;
2143
2144            for J in Max (M).Traceback'Range loop
2145               Put (" " & Image_C (PC_For (Max (M).Traceback (J))));
2146            end loop;
2147
2148            Put_Line ("");
2149         end loop;
2150      end Do_Report;
2151
2152      --  Local variables
2153
2154      Total_Freed : Byte_Count;
2155      --  safe thread pool logically & physically deallocated
2156
2157      Traceback_Elements_Allocated : Byte_Count;
2158      --  safe thread Traceback_Count
2159
2160      Validity_Elements_Allocated : Byte_Count;
2161      --  safe thread Validity_Count
2162
2163      Ada_Allocs_Bytes : Byte_Count;
2164      --  safe thread pool Allocated
2165
2166      Ada_Allocs_Chunks : Byte_Count;
2167      --  safe thread pool Alloc_Count
2168
2169      Ada_Free_Chunks : Byte_Count;
2170      --  safe thread pool Free_Count
2171
2172   --  Start of processing for Dump
2173
2174   begin
2175      declare
2176         Lock : Scope_Lock;
2177         pragma Unreferenced (Lock);
2178      begin
2179         Total_Freed :=
2180           Pool.Logically_Deallocated + Pool.Physically_Deallocated;
2181         Traceback_Elements_Allocated := Traceback_Count;
2182         Validity_Elements_Allocated := Validity_Count;
2183         Ada_Allocs_Bytes := Pool.Allocated;
2184         Ada_Allocs_Chunks := Pool.Alloc_Count;
2185         Ada_Free_Chunks := Pool.Free_Count;
2186      end;
2187
2188      Put_Line
2189        ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img);
2190      Put_Line
2191        ("Validity elements allocated: " & Validity_Elements_Allocated'Img);
2192      Put_Line ("");
2193
2194      Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img
2195                & " bytes in" & Ada_Allocs_Chunks'Img & " chunks");
2196      Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" &
2197                  Ada_Free_Chunks'Img
2198                & " chunks");
2199      Put_Line ("Ada Current watermark: "
2200                & Byte_Count'Image (Pool.Current_Water_Mark)
2201                & " in" & Byte_Count'Image (Ada_Allocs_Chunks -
2202                    Ada_Free_Chunks) & " chunks");
2203      Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img);
2204
2205      case Report is
2206         when All_Reports =>
2207            for Sort in Report_Type loop
2208               if Sort /= All_Reports then
2209                  Do_Report (Sort);
2210               end if;
2211            end loop;
2212
2213         when others =>
2214            Do_Report (Report);
2215      end case;
2216   end Dump;
2217
2218   -----------------
2219   -- Dump_Stdout --
2220   -----------------
2221
2222   procedure Dump_Stdout
2223     (Pool   : Debug_Pool;
2224      Size   : Positive;
2225      Report : Report_Type := All_Reports)
2226   is
2227      procedure Internal is new Dump
2228        (Put_Line => Stdout_Put_Line,
2229         Put      => Stdout_Put);
2230
2231   --  Start of processing for Dump_Stdout
2232
2233   begin
2234      Internal (Pool, Size, Report);
2235   end Dump_Stdout;
2236
2237   -----------
2238   -- Reset --
2239   -----------
2240
2241   procedure Reset is
2242      Elem : Traceback_Htable_Elem_Ptr;
2243      Lock : Scope_Lock;
2244      pragma Unreferenced (Lock);
2245   begin
2246      Elem := Backtrace_Htable.Get_First;
2247      while Elem /= null loop
2248         Elem.Count := 0;
2249         Elem.Frees := 0;
2250         Elem.Total := 0;
2251         Elem.Total_Frees := 0;
2252         Elem := Backtrace_Htable.Get_Next;
2253      end loop;
2254   end Reset;
2255
2256   ------------------
2257   -- Storage_Size --
2258   ------------------
2259
2260   function Storage_Size (Pool : Debug_Pool) return Storage_Count is
2261      pragma Unreferenced (Pool);
2262   begin
2263      return Storage_Count'Last;
2264   end Storage_Size;
2265
2266   ---------------------
2267   -- High_Water_Mark --
2268   ---------------------
2269
2270   function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is
2271      Lock : Scope_Lock;
2272      pragma Unreferenced (Lock);
2273   begin
2274      return Pool.High_Water;
2275   end High_Water_Mark;
2276
2277   ------------------------
2278   -- Current_Water_Mark --
2279   ------------------------
2280
2281   function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is
2282      Lock : Scope_Lock;
2283      pragma Unreferenced (Lock);
2284   begin
2285      return Pool.Allocated - Pool.Logically_Deallocated -
2286        Pool.Physically_Deallocated;
2287   end Current_Water_Mark;
2288
2289   ------------------------------
2290   -- System_Memory_Debug_Pool --
2291   ------------------------------
2292
2293   procedure System_Memory_Debug_Pool
2294     (Has_Unhandled_Memory : Boolean := True)
2295   is
2296      Lock : Scope_Lock;
2297      pragma Unreferenced (Lock);
2298   begin
2299      System_Memory_Debug_Pool_Enabled := True;
2300      Allow_Unhandled_Memory := Has_Unhandled_Memory;
2301   end System_Memory_Debug_Pool;
2302
2303   ---------------
2304   -- Configure --
2305   ---------------
2306
2307   procedure Configure
2308     (Pool                           : in out Debug_Pool;
2309      Stack_Trace_Depth              : Natural := Default_Stack_Trace_Depth;
2310      Maximum_Logically_Freed_Memory : SSC     := Default_Max_Freed;
2311      Minimum_To_Free                : SSC     := Default_Min_Freed;
2312      Reset_Content_On_Free          : Boolean := Default_Reset_Content;
2313      Raise_Exceptions               : Boolean := Default_Raise_Exceptions;
2314      Advanced_Scanning              : Boolean := Default_Advanced_Scanning;
2315      Errors_To_Stdout               : Boolean := Default_Errors_To_Stdout;
2316      Low_Level_Traces               : Boolean := Default_Low_Level_Traces)
2317   is
2318      Lock : Scope_Lock;
2319      pragma Unreferenced (Lock);
2320   begin
2321      Pool.Stack_Trace_Depth              := Stack_Trace_Depth;
2322      Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
2323      Pool.Reset_Content_On_Free          := Reset_Content_On_Free;
2324      Pool.Raise_Exceptions               := Raise_Exceptions;
2325      Pool.Minimum_To_Free                := Minimum_To_Free;
2326      Pool.Advanced_Scanning              := Advanced_Scanning;
2327      Pool.Errors_To_Stdout               := Errors_To_Stdout;
2328      Pool.Low_Level_Traces               := Low_Level_Traces;
2329   end Configure;
2330
2331   ----------------
2332   -- Print_Pool --
2333   ----------------
2334
2335   procedure Print_Pool (A : System.Address) is
2336      Storage : constant Address := A;
2337      Valid   : constant Boolean := Is_Valid (Storage);
2338      Header  : Allocation_Header_Access;
2339
2340   begin
2341      --  We might get Null_Address if the call from gdb was done incorrectly.
2342      --  For instance, doing a "print_pool(my_var)" passes 0x0, instead of
2343      --  passing the value of my_var.
2344
2345      if A = System.Null_Address then
2346         Put_Line
2347            (Standard_Output, "Memory not under control of the storage pool");
2348         return;
2349      end if;
2350
2351      if not Valid then
2352         Put_Line
2353            (Standard_Output, "Memory not under control of the storage pool");
2354
2355      else
2356         Header := Header_Of (Storage);
2357         Print_Address (Standard_Output, A);
2358         Put_Line (Standard_Output, " allocated at:");
2359         Print_Traceback (Standard_Output, "", Header.Alloc_Traceback);
2360
2361         if To_Traceback (Header.Dealloc_Traceback) /= null then
2362            Print_Address (Standard_Output, A);
2363            Put_Line (Standard_Output,
2364                      " logically freed memory, deallocated at:");
2365            Print_Traceback (Standard_Output, "",
2366                             To_Traceback (Header.Dealloc_Traceback));
2367         end if;
2368      end if;
2369   end Print_Pool;
2370
2371   -----------------------
2372   -- Print_Info_Stdout --
2373   -----------------------
2374
2375   procedure Print_Info_Stdout
2376     (Pool          : Debug_Pool;
2377      Cumulate      : Boolean := False;
2378      Display_Slots : Boolean := False;
2379      Display_Leaks : Boolean := False)
2380   is
2381      procedure Internal is new Print_Info
2382        (Put_Line => Stdout_Put_Line,
2383         Put      => Stdout_Put);
2384
2385   --  Start of processing for Print_Info_Stdout
2386
2387   begin
2388      Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
2389   end Print_Info_Stdout;
2390
2391   ------------------
2392   -- Dump_Gnatmem --
2393   ------------------
2394
2395   procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
2396      type File_Ptr is new System.Address;
2397
2398      function fopen (Path : String; Mode : String) return File_Ptr;
2399      pragma Import (C, fopen);
2400
2401      procedure fwrite
2402        (Ptr    : System.Address;
2403         Size   : size_t;
2404         Nmemb  : size_t;
2405         Stream : File_Ptr);
2406
2407      procedure fwrite
2408        (Str    : String;
2409         Size   : size_t;
2410         Nmemb  : size_t;
2411         Stream : File_Ptr);
2412      pragma Import (C, fwrite);
2413
2414      procedure fputc (C : Integer; Stream : File_Ptr);
2415      pragma Import (C, fputc);
2416
2417      procedure fclose (Stream : File_Ptr);
2418      pragma Import (C, fclose);
2419
2420      Address_Size : constant size_t :=
2421                       System.Address'Max_Size_In_Storage_Elements;
2422      --  Size in bytes of a pointer
2423
2424      File        : File_Ptr;
2425      Current     : System.Address;
2426      Header      : Allocation_Header_Access;
2427      Actual_Size : size_t;
2428      Num_Calls   : Integer;
2429      Tracebk     : Tracebacks_Array_Access;
2430      Dummy_Time  : Duration := 1.0;
2431
2432   begin
2433      File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
2434      fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
2435
2436      fwrite
2437        (Ptr    => Dummy_Time'Address,
2438         Size   => Duration'Max_Size_In_Storage_Elements,
2439         Nmemb  => 1,
2440         Stream => File);
2441
2442      --  List of not deallocated blocks (see Print_Info)
2443
2444      Current := Pool.First_Used_Block;
2445      while Current /= System.Null_Address loop
2446         Header := Header_Of (Current);
2447
2448         Actual_Size := size_t (Header.Block_Size);
2449
2450         if Header.Alloc_Traceback /= null then
2451            Tracebk   := Header.Alloc_Traceback.Traceback;
2452            Num_Calls := Tracebk'Length;
2453
2454            --  (Code taken from memtrack.adb in GNAT's sources)
2455
2456            --  Logs allocation call using the format:
2457
2458            --  'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
2459
2460            fputc (Character'Pos ('A'), File);
2461            fwrite (Current'Address, Address_Size, 1, File);
2462
2463            fwrite
2464              (Ptr    => Actual_Size'Address,
2465               Size   => size_t'Max_Size_In_Storage_Elements,
2466               Nmemb  => 1,
2467               Stream => File);
2468
2469            fwrite
2470              (Ptr    => Dummy_Time'Address,
2471               Size   => Duration'Max_Size_In_Storage_Elements,
2472               Nmemb  => 1,
2473               Stream => File);
2474
2475            fwrite
2476              (Ptr    => Num_Calls'Address,
2477               Size   => Integer'Max_Size_In_Storage_Elements,
2478               Nmemb  => 1,
2479               Stream => File);
2480
2481            for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
2482               declare
2483                  Ptr : System.Address := PC_For (Tracebk (J));
2484               begin
2485                  fwrite (Ptr'Address, Address_Size, 1, File);
2486               end;
2487            end loop;
2488         end if;
2489
2490         Current := Header.Next;
2491      end loop;
2492
2493      fclose (File);
2494   end Dump_Gnatmem;
2495
2496   ----------------
2497   -- Stdout_Put --
2498   ----------------
2499
2500   procedure Stdout_Put (S : String) is
2501   begin
2502      Put (Standard_Output, S);
2503   end Stdout_Put;
2504
2505   ---------------------
2506   -- Stdout_Put_Line --
2507   ---------------------
2508
2509   procedure Stdout_Put_Line (S : String) is
2510   begin
2511      Put_Line (Standard_Output, S);
2512   end Stdout_Put_Line;
2513
2514--  Package initialization
2515
2516begin
2517   Allocate_End;
2518   Deallocate_End;
2519   Dereference_End;
2520end GNAT.Debug_Pools;
2521