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