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