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