?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* xcoffout.c (xcoff_tls_data_section_name): Define.
[official-gcc.git] / gcc / ada / g-debpoo.adb
blob5ee63d9896f140ad64f5e50db37aeca1ac91758d
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-2012, 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 Current : Byte_Count;
672 P : Ptr;
673 Trace : Traceback_Htable_Elem_Ptr;
674
675 begin
676 <<Allocate_Label>>
677 Lock_Task.all;
678
679 -- If necessary, start physically releasing memory. The reason this is
680 -- done here, although Pool.Logically_Deallocated has not changed above,
681 -- is so that we do this only after a series of deallocations (e.g loop
682 -- that deallocates a big array). If we were doing that in Deallocate,
683 -- we might be physically freeing memory several times during the loop,
684 -- which is expensive.
685
686 if Pool.Logically_Deallocated >
687 Byte_Count (Pool.Maximum_Logically_Freed_Memory)
688 then
689 Free_Physically (Pool);
690 end if;
691
692 -- Use standard (i.e. through malloc) allocations. This automatically
693 -- raises Storage_Error if needed. We also try once more to physically
694 -- release memory, so that even marked blocks, in the advanced scanning,
695 -- are freed. Note that we do not initialize the storage array since it
696 -- is not necessary to do so (however this will cause bogus valgrind
697 -- warnings, which should simply be ignored).
698
699 begin
700 P := new Local_Storage_Array;
701
702 exception
703 when Storage_Error =>
704 Free_Physically (Pool);
705 P := new Local_Storage_Array;
706 end;
707
708 Storage_Address :=
709 To_Address
710 (Default_Alignment *
711 ((To_Integer (P.all'Address) + Default_Alignment - 1)
712 / Default_Alignment)
713 + Integer_Address (Header_Offset));
714 -- Computation is done in Integer_Address, not Storage_Offset, because
715 -- the range of Storage_Offset may not be large enough.
716
717 pragma Assert ((Storage_Address - System.Null_Address)
718 mod Default_Alignment = 0);
719 pragma Assert (Storage_Address + Size_In_Storage_Elements
720 <= P.all'Address + P'Length);
721
722 Trace := Find_Or_Create_Traceback
723 (Pool, Alloc, Size_In_Storage_Elements,
724 Allocate_Label'Address, Code_Address_For_Allocate_End);
725
726 pragma Warnings (Off);
727 -- Turn warning on alignment for convert call off. We know that in fact
728 -- this conversion is safe since P itself is always aligned on
729 -- Default_Alignment.
730
731 Header_Of (Storage_Address).all :=
732 (Allocation_Address => P.all'Address,
733 Alloc_Traceback => Trace,
734 Dealloc_Traceback => To_Traceback (null),
735 Next => Pool.First_Used_Block,
736 Block_Size => Size_In_Storage_Elements);
737
738 pragma Warnings (On);
739
740 -- Link this block in the list of used blocks. This will be used to list
741 -- memory leaks in Print_Info, and for the advanced schemes of
742 -- Physical_Free, where we want to traverse all allocated blocks and
743 -- search for possible references.
744
745 -- We insert in front, since most likely we'll be freeing the most
746 -- recently allocated blocks first (the older one might stay allocated
747 -- for the whole life of the application).
748
749 if Pool.First_Used_Block /= System.Null_Address then
750 Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
751 To_Address (Storage_Address);
752 end if;
753
754 Pool.First_Used_Block := Storage_Address;
755
756 -- Mark the new address as valid
757
758 Set_Valid (Storage_Address, True);
759
760 if Pool.Low_Level_Traces then
761 Put (Output_File (Pool),
762 "info: Allocated"
763 & Storage_Count'Image (Size_In_Storage_Elements)
764 & " bytes at 0x" & Address_Image (Storage_Address)
765 & " (physically:"
766 & Storage_Count'Image (Local_Storage_Array'Length)
767 & " bytes at 0x" & Address_Image (P.all'Address)
768 & "), at ");
769 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
770 Allocate_Label'Address,
771 Code_Address_For_Deallocate_End);
772 end if;
773
774 -- Update internal data
775
776 Pool.Allocated :=
777 Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
778
779 Current := Pool.Allocated -
780 Pool.Logically_Deallocated -
781 Pool.Physically_Deallocated;
782
783 if Current > Pool.High_Water then
784 Pool.High_Water := Current;
785 end if;
786
787 Unlock_Task.all;
788
789 exception
790 when others =>
791 Unlock_Task.all;
792 raise;
793 end Allocate;
794
795 ------------------
796 -- Allocate_End --
797 ------------------
798
799 -- DO NOT MOVE, this must be right after Allocate. This is similar to what
800 -- is done in a-except, so that we can hide the traceback frames internal
801 -- to this package
802
803 procedure Allocate_End is
804 begin
805 <<Allocate_End_Label>>
806 Code_Address_For_Allocate_End := Allocate_End_Label'Address;
807 end Allocate_End;
808
809 -------------------
810 -- Set_Dead_Beef --
811 -------------------
812
813 procedure Set_Dead_Beef
814 (Storage_Address : System.Address;
815 Size_In_Storage_Elements : Storage_Count)
816 is
817 Dead_Bytes : constant := 4;
818
819 type Data is mod 2 ** (Dead_Bytes * 8);
820 for Data'Size use Dead_Bytes * 8;
821
822 Dead : constant Data := 16#DEAD_BEEF#;
823
824 type Dead_Memory is array
825 (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
826 type Mem_Ptr is access Dead_Memory;
827
828 type Byte is mod 2 ** 8;
829 for Byte'Size use 8;
830
831 type Dead_Memory_Bytes is array (0 .. 2) of Byte;
832 type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
833
834 function From_Ptr is new Ada.Unchecked_Conversion
835 (System.Address, Mem_Ptr);
836
837 function From_Ptr is new Ada.Unchecked_Conversion
838 (System.Address, Dead_Memory_Bytes_Ptr);
839
840 M : constant Mem_Ptr := From_Ptr (Storage_Address);
841 M2 : Dead_Memory_Bytes_Ptr;
842 Modulo : constant Storage_Count :=
843 Size_In_Storage_Elements mod Dead_Bytes;
844 begin
845 M.all := (others => Dead);
846
847 -- Any bytes left (up to three of them)
848
849 if Modulo /= 0 then
850 M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
851
852 M2 (0) := 16#DE#;
853 if Modulo >= 2 then
854 M2 (1) := 16#AD#;
855
856 if Modulo >= 3 then
857 M2 (2) := 16#BE#;
858 end if;
859 end if;
860 end if;
861 end Set_Dead_Beef;
862
863 ---------------------
864 -- Free_Physically --
865 ---------------------
866
867 procedure Free_Physically (Pool : in out Debug_Pool) is
868 type Byte is mod 256;
869 type Byte_Access is access Byte;
870
871 function To_Byte is new Ada.Unchecked_Conversion
872 (System.Address, Byte_Access);
873
874 type Address_Access is access System.Address;
875
876 function To_Address_Access is new Ada.Unchecked_Conversion
877 (System.Address, Address_Access);
878
879 In_Use_Mark : constant Byte := 16#D#;
880 Free_Mark : constant Byte := 16#F#;
881
882 Total_Freed : Storage_Count := 0;
883
884 procedure Reset_Marks;
885 -- Unmark all the logically freed blocks, so that they are considered
886 -- for physical deallocation
887
888 procedure Mark
889 (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
890 -- Mark the user data block starting at A. For a block of size zero,
891 -- nothing is done. For a block with a different size, the first byte
892 -- is set to either "D" (in use) or "F" (free).
893
894 function Marked (A : System.Address) return Boolean;
895 -- Return true if the user data block starting at A might be in use
896 -- somewhere else
897
898 procedure Mark_Blocks;
899 -- Traverse all allocated blocks, and search for possible references
900 -- to logically freed blocks. Mark them appropriately
901
902 procedure Free_Blocks (Ignore_Marks : Boolean);
903 -- Physically release blocks. Only the blocks that haven't been marked
904 -- will be released, unless Ignore_Marks is true.
905
906 -----------------
907 -- Free_Blocks --
908 -----------------
909
910 procedure Free_Blocks (Ignore_Marks : Boolean) is
911 Header : Allocation_Header_Access;
912 Tmp : System.Address := Pool.First_Free_Block;
913 Next : System.Address;
914 Previous : System.Address := System.Null_Address;
915
916 begin
917 while Tmp /= System.Null_Address
918 and then Total_Freed < Pool.Minimum_To_Free
919 loop
920 Header := Header_Of (Tmp);
921
922 -- If we know, or at least assume, the block is no longer
923 -- referenced anywhere, we can free it physically.
924
925 if Ignore_Marks or else not Marked (Tmp) then
926
927 declare
928 pragma Suppress (All_Checks);
929 -- Suppress the checks on this section. If they are overflow
930 -- errors, it isn't critical, and we'd rather avoid a
931 -- Constraint_Error in that case.
932 begin
933 -- Note that block_size < zero for freed blocks
934
935 Pool.Physically_Deallocated :=
936 Pool.Physically_Deallocated -
937 Byte_Count (Header.Block_Size);
938
939 Pool.Logically_Deallocated :=
940 Pool.Logically_Deallocated +
941 Byte_Count (Header.Block_Size);
942
943 Total_Freed := Total_Freed - Header.Block_Size;
944 end;
945
946 Next := Header.Next;
947
948 if Pool.Low_Level_Traces then
949 Put_Line
950 (Output_File (Pool),
951 "info: Freeing physical memory "
952 & Storage_Count'Image
953 ((abs Header.Block_Size) + Minimum_Allocation)
954 & " bytes at 0x"
955 & Address_Image (Header.Allocation_Address));
956 end if;
957
958 System.Memory.Free (Header.Allocation_Address);
959 Set_Valid (Tmp, False);
960
961 -- Remove this block from the list
962
963 if Previous = System.Null_Address then
964 Pool.First_Free_Block := Next;
965 else
966 Header_Of (Previous).Next := Next;
967 end if;
968
969 Tmp := Next;
970
971 else
972 Previous := Tmp;
973 Tmp := Header.Next;
974 end if;
975 end loop;
976 end Free_Blocks;
977
978 ----------
979 -- Mark --
980 ----------
981
982 procedure Mark
983 (H : Allocation_Header_Access;
984 A : System.Address;
985 In_Use : Boolean)
986 is
987 begin
988 if H.Block_Size /= 0 then
989 To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark);
990 end if;
991 end Mark;
992
993 -----------------
994 -- Mark_Blocks --
995 -----------------
996
997 procedure Mark_Blocks is
998 Tmp : System.Address := Pool.First_Used_Block;
999 Previous : System.Address;
1000 Last : System.Address;
1001 Pointed : System.Address;
1002 Header : Allocation_Header_Access;
1003
1004 begin
1005 -- For each allocated block, check its contents. Things that look
1006 -- like a possible address are used to mark the blocks so that we try
1007 -- and keep them, for better detection in case of invalid access.
1008 -- This mechanism is far from being fool-proof: it doesn't check the
1009 -- stacks of the threads, doesn't check possible memory allocated not
1010 -- under control of this debug pool. But it should allow us to catch
1011 -- more cases.
1012
1013 while Tmp /= System.Null_Address loop
1014 Previous := Tmp;
1015 Last := Tmp + Header_Of (Tmp).Block_Size;
1016 while Previous < Last loop
1017 -- ??? Should we move byte-per-byte, or consider that addresses
1018 -- are always aligned on 4-bytes boundaries ? Let's use the
1019 -- fastest for now.
1020
1021 Pointed := To_Address_Access (Previous).all;
1022 if Is_Valid (Pointed) then
1023 Header := Header_Of (Pointed);
1024
1025 -- Do not even attempt to mark blocks in use. That would
1026 -- screw up the whole application, of course.
1027
1028 if Header.Block_Size < 0 then
1029 Mark (Header, Pointed, In_Use => True);
1030 end if;
1031 end if;
1032
1033 Previous := Previous + System.Address'Size;
1034 end loop;
1035
1036 Tmp := Header_Of (Tmp).Next;
1037 end loop;
1038 end Mark_Blocks;
1039
1040 ------------
1041 -- Marked --
1042 ------------
1043
1044 function Marked (A : System.Address) return Boolean is
1045 begin
1046 return To_Byte (A).all = In_Use_Mark;
1047 end Marked;
1048
1049 -----------------
1050 -- Reset_Marks --
1051 -----------------
1052
1053 procedure Reset_Marks is
1054 Current : System.Address := Pool.First_Free_Block;
1055 Header : Allocation_Header_Access;
1056 begin
1057 while Current /= System.Null_Address loop
1058 Header := Header_Of (Current);
1059 Mark (Header, Current, False);
1060 Current := Header.Next;
1061 end loop;
1062 end Reset_Marks;
1063
1064 -- Start of processing for Free_Physically
1065
1066 begin
1067 Lock_Task.all;
1068
1069 if Pool.Advanced_Scanning then
1070
1071 -- Reset the mark for each freed block
1072
1073 Reset_Marks;
1074
1075 Mark_Blocks;
1076 end if;
1077
1078 Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
1079
1080 -- The contract is that we need to free at least Minimum_To_Free bytes,
1081 -- even if this means freeing marked blocks in the advanced scheme
1082
1083 if Total_Freed < Pool.Minimum_To_Free
1084 and then Pool.Advanced_Scanning
1085 then
1086 Pool.Marked_Blocks_Deallocated := True;
1087 Free_Blocks (Ignore_Marks => True);
1088 end if;
1089
1090 Unlock_Task.all;
1091
1092 exception
1093 when others =>
1094 Unlock_Task.all;
1095 raise;
1096 end Free_Physically;
1097
1098 ----------------
1099 -- Deallocate --
1100 ----------------
1101
1102 procedure Deallocate
1103 (Pool : in out Debug_Pool;
1104 Storage_Address : Address;
1105 Size_In_Storage_Elements : Storage_Count;
1106 Alignment : Storage_Count)
1107 is
1108 pragma Unreferenced (Alignment);
1109
1110 Header : constant Allocation_Header_Access :=
1111 Header_Of (Storage_Address);
1112 Valid : Boolean;
1113 Previous : System.Address;
1114
1115 begin
1116 <<Deallocate_Label>>
1117 Lock_Task.all;
1118 Valid := Is_Valid (Storage_Address);
1119
1120 if not Valid then
1121 Unlock_Task.all;
1122 if Pool.Raise_Exceptions then
1123 raise Freeing_Not_Allocated_Storage;
1124 else
1125 Put (Output_File (Pool),
1126 "error: Freeing not allocated storage, at ");
1127 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1128 Deallocate_Label'Address,
1129 Code_Address_For_Deallocate_End);
1130 end if;
1131
1132 elsif Header.Block_Size < 0 then
1133 Unlock_Task.all;
1134 if Pool.Raise_Exceptions then
1135 raise Freeing_Deallocated_Storage;
1136 else
1137 Put (Output_File (Pool),
1138 "error: Freeing already deallocated storage, at ");
1139 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1140 Deallocate_Label'Address,
1141 Code_Address_For_Deallocate_End);
1142 Put (Output_File (Pool), " Memory already deallocated at ");
1143 Put_Line
1144 (Output_File (Pool), 0,
1145 To_Traceback (Header.Dealloc_Traceback).Traceback);
1146 Put (Output_File (Pool), " Memory was allocated at ");
1147 Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
1148 end if;
1149
1150 else
1151 -- Some sort of codegen problem or heap corruption caused the
1152 -- Size_In_Storage_Elements to be wrongly computed.
1153 -- The code below is all based on the assumption that Header.all
1154 -- is not corrupted, such that the error is non-fatal.
1155
1156 if Header.Block_Size /= Size_In_Storage_Elements then
1157 Put_Line (Output_File (Pool),
1158 "error: Deallocate size "
1159 & Storage_Count'Image (Size_In_Storage_Elements)
1160 & " does not match allocate size "
1161 & Storage_Count'Image (Header.Block_Size));
1162 end if;
1163
1164 if Pool.Low_Level_Traces then
1165 Put (Output_File (Pool),
1166 "info: Deallocated"
1167 & Storage_Count'Image (Size_In_Storage_Elements)
1168 & " bytes at 0x" & Address_Image (Storage_Address)
1169 & " (physically"
1170 & Storage_Count'Image (Header.Block_Size + Minimum_Allocation)
1171 & " bytes at 0x" & Address_Image (Header.Allocation_Address)
1172 & "), at ");
1173 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1174 Deallocate_Label'Address,
1175 Code_Address_For_Deallocate_End);
1176 Put (Output_File (Pool), " Memory was allocated at ");
1177 Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
1178 end if;
1179
1180 -- Remove this block from the list of used blocks
1181
1182 Previous :=
1183 To_Address (Header.Dealloc_Traceback);
1184
1185 if Previous = System.Null_Address then
1186 Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
1187
1188 if Pool.First_Used_Block /= System.Null_Address then
1189 Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
1190 To_Traceback (null);
1191 end if;
1192
1193 else
1194 Header_Of (Previous).Next := Header.Next;
1195
1196 if Header.Next /= System.Null_Address then
1197 Header_Of
1198 (Header.Next).Dealloc_Traceback := To_Address (Previous);
1199 end if;
1200 end if;
1201
1202 -- Update the header
1203
1204 Header.all :=
1205 (Allocation_Address => Header.Allocation_Address,
1206 Alloc_Traceback => Header.Alloc_Traceback,
1207 Dealloc_Traceback => To_Traceback
1208 (Find_Or_Create_Traceback
1209 (Pool, Dealloc,
1210 Size_In_Storage_Elements,
1211 Deallocate_Label'Address,
1212 Code_Address_For_Deallocate_End)),
1213 Next => System.Null_Address,
1214 Block_Size => -Header.Block_Size);
1215
1216 if Pool.Reset_Content_On_Free then
1217 Set_Dead_Beef (Storage_Address, -Header.Block_Size);
1218 end if;
1219
1220 Pool.Logically_Deallocated :=
1221 Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size);
1222
1223 -- Link this free block with the others (at the end of the list, so
1224 -- that we can start releasing the older blocks first later on).
1225
1226 if Pool.First_Free_Block = System.Null_Address then
1227 Pool.First_Free_Block := Storage_Address;
1228 Pool.Last_Free_Block := Storage_Address;
1229
1230 else
1231 Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
1232 Pool.Last_Free_Block := Storage_Address;
1233 end if;
1234
1235 -- Do not physically release the memory here, but in Alloc.
1236 -- See comment there for details.
1237
1238 Unlock_Task.all;
1239 end if;
1240
1241 exception
1242 when others =>
1243 Unlock_Task.all;
1244 raise;
1245 end Deallocate;
1246
1247 --------------------
1248 -- Deallocate_End --
1249 --------------------
1250
1251 -- DO NOT MOVE, this must be right after Deallocate
1252
1253 -- See Allocate_End
1254
1255 -- This is making assumptions about code order that may be invalid ???
1256
1257 procedure Deallocate_End is
1258 begin
1259 <<Deallocate_End_Label>>
1260 Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
1261 end Deallocate_End;
1262
1263 -----------------
1264 -- Dereference --
1265 -----------------
1266
1267 procedure Dereference
1268 (Pool : in out Debug_Pool;
1269 Storage_Address : Address;
1270 Size_In_Storage_Elements : Storage_Count;
1271 Alignment : Storage_Count)
1272 is
1273 pragma Unreferenced (Alignment, Size_In_Storage_Elements);
1274
1275 Valid : constant Boolean := Is_Valid (Storage_Address);
1276 Header : Allocation_Header_Access;
1277
1278 begin
1279 -- Locking policy: we do not do any locking in this procedure. The
1280 -- tables are only read, not written to, and although a problem might
1281 -- appear if someone else is modifying the tables at the same time, this
1282 -- race condition is not intended to be detected by this storage_pool (a
1283 -- now invalid pointer would appear as valid). Instead, we prefer
1284 -- optimum performance for dereferences.
1285
1286 <<Dereference_Label>>
1287
1288 if not Valid then
1289 if Pool.Raise_Exceptions then
1290 raise Accessing_Not_Allocated_Storage;
1291 else
1292 Put (Output_File (Pool),
1293 "error: Accessing not allocated storage, at ");
1294 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1295 Dereference_Label'Address,
1296 Code_Address_For_Dereference_End);
1297 end if;
1298
1299 else
1300 Header := Header_Of (Storage_Address);
1301
1302 if Header.Block_Size < 0 then
1303 if Pool.Raise_Exceptions then
1304 raise Accessing_Deallocated_Storage;
1305 else
1306 Put (Output_File (Pool),
1307 "error: Accessing deallocated storage, at ");
1308 Put_Line
1309 (Output_File (Pool), Pool.Stack_Trace_Depth, null,
1310 Dereference_Label'Address,
1311 Code_Address_For_Dereference_End);
1312 Put (Output_File (Pool), " First deallocation at ");
1313 Put_Line
1314 (Output_File (Pool),
1315 0, To_Traceback (Header.Dealloc_Traceback).Traceback);
1316 Put (Output_File (Pool), " Initial allocation at ");
1317 Put_Line
1318 (Output_File (Pool),
1319 0, Header.Alloc_Traceback.Traceback);
1320 end if;
1321 end if;
1322 end if;
1323 end Dereference;
1324
1325 ---------------------
1326 -- Dereference_End --
1327 ---------------------
1328
1329 -- DO NOT MOVE: this must be right after Dereference
1330
1331 -- See Allocate_End
1332
1333 -- This is making assumptions about code order that may be invalid ???
1334
1335 procedure Dereference_End is
1336 begin
1337 <<Dereference_End_Label>>
1338 Code_Address_For_Dereference_End := Dereference_End_Label'Address;
1339 end Dereference_End;
1340
1341 ----------------
1342 -- Print_Info --
1343 ----------------
1344
1345 procedure Print_Info
1346 (Pool : Debug_Pool;
1347 Cumulate : Boolean := False;
1348 Display_Slots : Boolean := False;
1349 Display_Leaks : Boolean := False)
1350 is
1351
1352 package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
1353 (Header_Num => Header,
1354 Element => Traceback_Htable_Elem,
1355 Elmt_Ptr => Traceback_Htable_Elem_Ptr,
1356 Null_Ptr => null,
1357 Set_Next => Set_Next,
1358 Next => Next,
1359 Key => Tracebacks_Array_Access,
1360 Get_Key => Get_Key,
1361 Hash => Hash,
1362 Equal => Equal);
1363 -- This needs a comment ??? probably some of the ones below do too???
1364
1365 Data : Traceback_Htable_Elem_Ptr;
1366 Elem : Traceback_Htable_Elem_Ptr;
1367 Current : System.Address;
1368 Header : Allocation_Header_Access;
1369 K : Traceback_Kind;
1370
1371 begin
1372 Put_Line
1373 ("Total allocated bytes : " &
1374 Byte_Count'Image (Pool.Allocated));
1375
1376 Put_Line
1377 ("Total logically deallocated bytes : " &
1378 Byte_Count'Image (Pool.Logically_Deallocated));
1379
1380 Put_Line
1381 ("Total physically deallocated bytes : " &
1382 Byte_Count'Image (Pool.Physically_Deallocated));
1383
1384 if Pool.Marked_Blocks_Deallocated then
1385 Put_Line ("Marked blocks were physically deallocated. This is");
1386 Put_Line ("potentially dangerous, and you might want to run");
1387 Put_Line ("again with a lower value of Minimum_To_Free");
1388 end if;
1389
1390 Put_Line
1391 ("Current Water Mark: " &
1392 Byte_Count'Image
1393 (Pool.Allocated - Pool.Logically_Deallocated
1394 - Pool.Physically_Deallocated));
1395
1396 Put_Line
1397 ("High Water Mark: " &
1398 Byte_Count'Image (Pool.High_Water));
1399
1400 Put_Line ("");
1401
1402 if Display_Slots then
1403 Data := Backtrace_Htable.Get_First;
1404 while Data /= null loop
1405 if Data.Kind in Alloc .. Dealloc then
1406 Elem :=
1407 new Traceback_Htable_Elem'
1408 (Traceback => new Tracebacks_Array'(Data.Traceback.all),
1409 Count => Data.Count,
1410 Kind => Data.Kind,
1411 Total => Data.Total,
1412 Next => null);
1413 Backtrace_Htable_Cumulate.Set (Elem);
1414
1415 if Cumulate then
1416 K := (if Data.Kind = Alloc then Indirect_Alloc
1417 else Indirect_Dealloc);
1418
1419 -- Propagate the direct call to all its parents
1420
1421 for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
1422 Elem := Backtrace_Htable_Cumulate.Get
1423 (Data.Traceback
1424 (T .. Data.Traceback'Last)'Unrestricted_Access);
1425
1426 -- If not, insert it
1427
1428 if Elem = null then
1429 Elem := new Traceback_Htable_Elem'
1430 (Traceback => new Tracebacks_Array'
1431 (Data.Traceback (T .. Data.Traceback'Last)),
1432 Count => Data.Count,
1433 Kind => K,
1434 Total => Data.Total,
1435 Next => null);
1436 Backtrace_Htable_Cumulate.Set (Elem);
1437
1438 -- Properly take into account that the subprograms
1439 -- indirectly called might be doing either allocations
1440 -- or deallocations. This needs to be reflected in the
1441 -- counts.
1442
1443 else
1444 Elem.Count := Elem.Count + Data.Count;
1445
1446 if K = Elem.Kind then
1447 Elem.Total := Elem.Total + Data.Total;
1448
1449 elsif Elem.Total > Data.Total then
1450 Elem.Total := Elem.Total - Data.Total;
1451
1452 else
1453 Elem.Kind := K;
1454 Elem.Total := Data.Total - Elem.Total;
1455 end if;
1456 end if;
1457 end loop;
1458 end if;
1459
1460 Data := Backtrace_Htable.Get_Next;
1461 end if;
1462 end loop;
1463
1464 Put_Line ("List of allocations/deallocations: ");
1465
1466 Data := Backtrace_Htable_Cumulate.Get_First;
1467 while Data /= null loop
1468 case Data.Kind is
1469 when Alloc => Put ("alloc (count:");
1470 when Indirect_Alloc => Put ("indirect alloc (count:");
1471 when Dealloc => Put ("free (count:");
1472 when Indirect_Dealloc => Put ("indirect free (count:");
1473 end case;
1474
1475 Put (Natural'Image (Data.Count) & ", total:" &
1476 Byte_Count'Image (Data.Total) & ") ");
1477
1478 for T in Data.Traceback'Range loop
1479 Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
1480 end loop;
1481
1482 Put_Line ("");
1483
1484 Data := Backtrace_Htable_Cumulate.Get_Next;
1485 end loop;
1486
1487 Backtrace_Htable_Cumulate.Reset;
1488 end if;
1489
1490 if Display_Leaks then
1491 Put_Line ("");
1492 Put_Line ("List of not deallocated blocks:");
1493
1494 -- Do not try to group the blocks with the same stack traces
1495 -- together. This is done by the gnatmem output.
1496
1497 Current := Pool.First_Used_Block;
1498 while Current /= System.Null_Address loop
1499 Header := Header_Of (Current);
1500
1501 Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
1502
1503 for T in Header.Alloc_Traceback.Traceback'Range loop
1504 Put ("0x" & Address_Image
1505 (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
1506 end loop;
1507
1508 Put_Line ("");
1509 Current := Header.Next;
1510 end loop;
1511 end if;
1512 end Print_Info;
1513
1514 ------------------
1515 -- Storage_Size --
1516 ------------------
1517
1518 function Storage_Size (Pool : Debug_Pool) return Storage_Count is
1519 pragma Unreferenced (Pool);
1520 begin
1521 return Storage_Count'Last;
1522 end Storage_Size;
1523
1524 ---------------
1525 -- Configure --
1526 ---------------
1527
1528 procedure Configure
1529 (Pool : in out Debug_Pool;
1530 Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
1531 Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
1532 Minimum_To_Free : SSC := Default_Min_Freed;
1533 Reset_Content_On_Free : Boolean := Default_Reset_Content;
1534 Raise_Exceptions : Boolean := Default_Raise_Exceptions;
1535 Advanced_Scanning : Boolean := Default_Advanced_Scanning;
1536 Errors_To_Stdout : Boolean := Default_Errors_To_Stdout;
1537 Low_Level_Traces : Boolean := Default_Low_Level_Traces)
1538 is
1539 begin
1540 Pool.Stack_Trace_Depth := Stack_Trace_Depth;
1541 Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
1542 Pool.Reset_Content_On_Free := Reset_Content_On_Free;
1543 Pool.Raise_Exceptions := Raise_Exceptions;
1544 Pool.Minimum_To_Free := Minimum_To_Free;
1545 Pool.Advanced_Scanning := Advanced_Scanning;
1546 Pool.Errors_To_Stdout := Errors_To_Stdout;
1547 Pool.Low_Level_Traces := Low_Level_Traces;
1548 end Configure;
1549
1550 ----------------
1551 -- Print_Pool --
1552 ----------------
1553
1554 procedure Print_Pool (A : System.Address) is
1555 Storage : constant Address := A;
1556 Valid : constant Boolean := Is_Valid (Storage);
1557 Header : Allocation_Header_Access;
1558
1559 begin
1560 -- We might get Null_Address if the call from gdb was done
1561 -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
1562 -- instead of passing the value of my_var
1563
1564 if A = System.Null_Address then
1565 Put_Line
1566 (Standard_Output, "Memory not under control of the storage pool");
1567 return;
1568 end if;
1569
1570 if not Valid then
1571 Put_Line
1572 (Standard_Output, "Memory not under control of the storage pool");
1573
1574 else
1575 Header := Header_Of (Storage);
1576 Put_Line (Standard_Output, "0x" & Address_Image (A)
1577 & " allocated at:");
1578 Put_Line (Standard_Output, 0, Header.Alloc_Traceback.Traceback);
1579
1580 if To_Traceback (Header.Dealloc_Traceback) /= null then
1581 Put_Line (Standard_Output, "0x" & Address_Image (A)
1582 & " logically freed memory, deallocated at:");
1583 Put_Line
1584 (Standard_Output, 0,
1585 To_Traceback (Header.Dealloc_Traceback).Traceback);
1586 end if;
1587 end if;
1588 end Print_Pool;
1589
1590 -----------------------
1591 -- Print_Info_Stdout --
1592 -----------------------
1593
1594 procedure Print_Info_Stdout
1595 (Pool : Debug_Pool;
1596 Cumulate : Boolean := False;
1597 Display_Slots : Boolean := False;
1598 Display_Leaks : Boolean := False)
1599 is
1600 procedure Stdout_Put (S : String);
1601 procedure Stdout_Put_Line (S : String);
1602 -- Wrappers for Put and Put_Line that ensure we always write to stdout
1603 -- instead of the current output file defined in GNAT.IO.
1604
1605 procedure Internal is new Print_Info
1606 (Put_Line => Stdout_Put_Line,
1607 Put => Stdout_Put);
1608
1609 ----------------
1610 -- Stdout_Put --
1611 ----------------
1612
1613 procedure Stdout_Put (S : String) is
1614 begin
1615 Put_Line (Standard_Output, S);
1616 end Stdout_Put;
1617
1618 ---------------------
1619 -- Stdout_Put_Line --
1620 ---------------------
1621
1622 procedure Stdout_Put_Line (S : String) is
1623 begin
1624 Put_Line (Standard_Output, S);
1625 end Stdout_Put_Line;
1626
1627 -- Start of processing for Print_Info_Stdout
1628
1629 begin
1630 Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
1631 end Print_Info_Stdout;
1632
1633 ------------------
1634 -- Dump_Gnatmem --
1635 ------------------
1636
1637 procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
1638 type File_Ptr is new System.Address;
1639
1640 function fopen (Path : String; Mode : String) return File_Ptr;
1641 pragma Import (C, fopen);
1642
1643 procedure fwrite
1644 (Ptr : System.Address;
1645 Size : size_t;
1646 Nmemb : size_t;
1647 Stream : File_Ptr);
1648
1649 procedure fwrite
1650 (Str : String;
1651 Size : size_t;
1652 Nmemb : size_t;
1653 Stream : File_Ptr);
1654 pragma Import (C, fwrite);
1655
1656 procedure fputc (C : Integer; Stream : File_Ptr);
1657 pragma Import (C, fputc);
1658
1659 procedure fclose (Stream : File_Ptr);
1660 pragma Import (C, fclose);
1661
1662 Address_Size : constant size_t :=
1663 System.Address'Max_Size_In_Storage_Elements;
1664 -- Size in bytes of a pointer
1665
1666 File : File_Ptr;
1667 Current : System.Address;
1668 Header : Allocation_Header_Access;
1669 Actual_Size : size_t;
1670 Num_Calls : Integer;
1671 Tracebk : Tracebacks_Array_Access;
1672 Dummy_Time : Duration := 1.0;
1673
1674 begin
1675 File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
1676 fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
1677 fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1,
1678 File);
1679
1680 -- List of not deallocated blocks (see Print_Info)
1681
1682 Current := Pool.First_Used_Block;
1683 while Current /= System.Null_Address loop
1684 Header := Header_Of (Current);
1685
1686 Actual_Size := size_t (Header.Block_Size);
1687 Tracebk := Header.Alloc_Traceback.Traceback;
1688 Num_Calls := Tracebk'Length;
1689
1690 -- (Code taken from memtrack.adb in GNAT's sources)
1691
1692 -- Logs allocation call using the format:
1693
1694 -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
1695
1696 fputc (Character'Pos ('A'), File);
1697 fwrite (Current'Address, Address_Size, 1, File);
1698 fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
1699 File);
1700 fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1,
1701 File);
1702 fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
1703 File);
1704
1705 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
1706 declare
1707 Ptr : System.Address := PC_For (Tracebk (J));
1708 begin
1709 fwrite (Ptr'Address, Address_Size, 1, File);
1710 end;
1711 end loop;
1712
1713 Current := Header.Next;
1714 end loop;
1715
1716 fclose (File);
1717 end Dump_Gnatmem;
1718
1719 -- Package initialization
1720
1721 begin
1722 Allocate_End;
1723 Deallocate_End;
1724 Dereference_End;
1725 end GNAT.Debug_Pools;
Mirror of the offical gcc git repository hosted at gcc.gnu.org