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