projects / gcc.git / blob
? search:


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