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