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