1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . D E B U G _ P O O L S --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with GNAT
.IO
; use GNAT
.IO
;
35 with System
.Memory
; use System
.Memory
;
36 with System
.Soft_Links
; use System
.Soft_Links
;
38 with System
.Traceback_Entries
;
40 with GNAT
.Debug_Utilities
; use GNAT
.Debug_Utilities
;
42 with GNAT
.Traceback
; use GNAT
.Traceback
;
44 with Ada
.Unchecked_Conversion
;
46 package body GNAT
.Debug_Pools
is
48 Storage_Alignment
: constant := Standard
'Maximum_Alignment;
49 -- Alignment enforced for all the memory chunks returned by Allocate,
50 -- maximized to make sure that it will be compatible with all types.
52 -- The addresses returned by the underlying low-level allocator (be it
53 -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned
54 -- on some targets, so we manage the needed alignment padding ourselves
55 -- systematically. Use of a common value for every allocation allows
56 -- significant simplifications in the code, nevertheless, for improved
57 -- robustness and efficiency overall.
59 -- We combine a few internal devices to offer the pool services:
61 -- * A management header attached to each allocated memory block, located
62 -- right ahead of it, like so:
64 -- Storage Address returned by the pool,
65 -- aligned on Storage_Alignment
67 -- +------+--------+---------------------
68 -- | ~~~~ | HEADER | USER DATA ... |
69 -- +------+--------+---------------------
74 -- The alignment padding is required
76 -- * A validity bitmap, which holds a validity bit for blocks managed by
77 -- the pool. Enforcing Storage_Alignment on those blocks allows efficient
78 -- validity management.
80 -- * A list of currently used blocks.
82 Max_Ignored_Levels
: constant Natural := 10;
83 -- Maximum number of levels that will be ignored in backtraces. This is so
84 -- that we still have enough significant levels in the tracebacks returned
87 -- The value 10 is chosen as being greater than the maximum callgraph
88 -- in this package. Its actual value is not really relevant, as long as it
89 -- is high enough to make sure we still have enough frames to return to
90 -- the user after we have hidden the frames internal to this package.
92 Disable
: Boolean := False;
93 -- This variable is used to avoid infinite loops, where this package would
94 -- itself allocate memory and then call itself recursively, forever. Useful
95 -- when System_Memory_Debug_Pool_Enabled is True.
97 System_Memory_Debug_Pool_Enabled
: Boolean := False;
98 -- If True, System.Memory allocation uses Debug_Pool
100 Allow_Unhandled_Memory
: Boolean := False;
101 -- If True, protects Deallocate against releasing memory allocated before
102 -- System_Memory_Debug_Pool_Enabled was set.
104 ---------------------------
105 -- Back Trace Hash Table --
106 ---------------------------
108 -- This package needs to store one set of tracebacks for each allocation
109 -- point (when was it allocated or deallocated). This would use too much
110 -- memory, so the tracebacks are actually stored in a hash table, and
111 -- we reference elements in this hash table instead.
113 -- This hash-table will remain empty if the discriminant Stack_Trace_Depth
114 -- for the pools is set to 0.
116 -- This table is a global table, that can be shared among all debug pools
119 type Header
is range 1 .. 1023;
120 -- Number of elements in the hash-table
122 type Tracebacks_Array_Access
is access Tracebacks_Array
;
124 type Traceback_Kind
is (Alloc
, Dealloc
, Indirect_Alloc
, Indirect_Dealloc
);
126 type Traceback_Htable_Elem
;
127 type Traceback_Htable_Elem_Ptr
128 is access Traceback_Htable_Elem
;
130 type Traceback_Htable_Elem
is record
131 Traceback
: Tracebacks_Array_Access
;
132 Kind
: Traceback_Kind
;
134 -- Size of the memory allocated/freed at Traceback since last Reset call
137 -- Number of chunk of memory allocated/freed at Traceback since last
141 -- Number of chunk of memory allocated at Traceback, currently freed
142 -- since last Reset call. (only for Alloc & Indirect_Alloc elements)
144 Total_Frees
: Byte_Count
;
145 -- Size of the memory allocated at Traceback, currently freed since last
146 -- Reset call. (only for Alloc & Indirect_Alloc elements)
148 Next
: Traceback_Htable_Elem_Ptr
;
151 -- Subprograms used for the Backtrace_Htable instantiation
154 (E
: Traceback_Htable_Elem_Ptr
;
155 Next
: Traceback_Htable_Elem_Ptr
);
156 pragma Inline
(Set_Next
);
159 (E
: Traceback_Htable_Elem_Ptr
) return Traceback_Htable_Elem_Ptr
;
160 pragma Inline
(Next
);
163 (E
: Traceback_Htable_Elem_Ptr
) return Tracebacks_Array_Access
;
164 pragma Inline
(Get_Key
);
166 function Hash
(T
: Tracebacks_Array_Access
) return Header
;
167 pragma Inline
(Hash
);
169 function Equal
(K1
, K2
: Tracebacks_Array_Access
) return Boolean;
170 -- Why is this not inlined???
172 -- The hash table for back traces
174 package Backtrace_Htable
is new GNAT
.HTable
.Static_HTable
175 (Header_Num
=> Header
,
176 Element
=> Traceback_Htable_Elem
,
177 Elmt_Ptr
=> Traceback_Htable_Elem_Ptr
,
179 Set_Next
=> Set_Next
,
181 Key
=> Tracebacks_Array_Access
,
186 -----------------------
187 -- Allocations table --
188 -----------------------
190 type Allocation_Header
;
191 type Allocation_Header_Access
is access Allocation_Header
;
193 type Traceback_Ptr_Or_Address
is new System
.Address
;
194 -- A type that acts as a C union, and is either a System.Address or a
195 -- Traceback_Htable_Elem_Ptr.
197 -- The following record stores extra information that needs to be
198 -- memorized for each block allocated with the special debug pool.
200 type Allocation_Header
is record
201 Allocation_Address
: System
.Address
;
202 -- Address of the block returned by malloc, possibly unaligned
204 Block_Size
: Storage_Offset
;
205 -- Needed only for advanced freeing algorithms (traverse all allocated
206 -- blocks for potential references). This value is negated when the
207 -- chunk of memory has been logically freed by the application. This
208 -- chunk has not been physically released yet.
210 Alloc_Traceback
: Traceback_Htable_Elem_Ptr
;
211 -- ??? comment required
213 Dealloc_Traceback
: Traceback_Ptr_Or_Address
;
214 -- Pointer to the traceback for the allocation (if the memory chunk is
215 -- still valid), or to the first deallocation otherwise. Make sure this
216 -- is a thin pointer to save space.
218 -- Dealloc_Traceback is also for blocks that are still allocated to
219 -- point to the previous block in the list. This saves space in this
220 -- header, and make manipulation of the lists of allocated pointers
223 Next
: System
.Address
;
224 -- Point to the next block of the same type (either allocated or
225 -- logically freed) in memory. This points to the beginning of the user
226 -- data, and does not include the header of that block.
230 (Address
: System
.Address
) return Allocation_Header_Access
;
231 pragma Inline
(Header_Of
);
232 -- Return the header corresponding to a previously allocated address
234 function To_Address
is new Ada
.Unchecked_Conversion
235 (Traceback_Ptr_Or_Address
, System
.Address
);
237 function To_Address
is new Ada
.Unchecked_Conversion
238 (System
.Address
, Traceback_Ptr_Or_Address
);
240 function To_Traceback
is new Ada
.Unchecked_Conversion
241 (Traceback_Ptr_Or_Address
, Traceback_Htable_Elem_Ptr
);
243 function To_Traceback
is new Ada
.Unchecked_Conversion
244 (Traceback_Htable_Elem_Ptr
, Traceback_Ptr_Or_Address
);
246 Header_Offset
: constant Storage_Count
:=
247 (Allocation_Header
'Object_Size / System
.Storage_Unit
);
248 -- Offset, in bytes, from start of allocation Header to start of User
249 -- data. The start of user data is assumed to be aligned at least as much
250 -- as what the header type requires, so applying this offset yields a
251 -- suitably aligned address as well.
253 Extra_Allocation
: constant Storage_Count
:=
254 (Storage_Alignment
- 1 + Header_Offset
);
255 -- Amount we need to secure in addition to the user data for a given
256 -- allocation request: room for the allocation header plus worst-case
257 -- alignment padding.
259 -----------------------
260 -- Local subprograms --
261 -----------------------
263 function Align
(Addr
: Integer_Address
) return Integer_Address
;
264 pragma Inline
(Align
);
265 -- Return the next address aligned on Storage_Alignment from Addr.
267 function Find_Or_Create_Traceback
269 Kind
: Traceback_Kind
;
270 Size
: Storage_Count
;
271 Ignored_Frame_Start
: System
.Address
;
272 Ignored_Frame_End
: System
.Address
) return Traceback_Htable_Elem_Ptr
;
273 -- Return an element matching the current traceback (omitting the frames
274 -- that are in the current package). If this traceback already existed in
275 -- the htable, a pointer to this is returned to spare memory. Null is
276 -- returned if the pool is set not to store tracebacks. If the traceback
277 -- already existed in the table, the count is incremented so that
278 -- Dump_Tracebacks returns useful results. All addresses up to, and
279 -- including, an address between Ignored_Frame_Start .. Ignored_Frame_End
282 function Output_File
(Pool
: Debug_Pool
) return File_Type
;
283 pragma Inline
(Output_File
);
284 -- Returns file_type on which error messages have to be generated for Pool
289 Traceback
: Tracebacks_Array_Access
;
290 Ignored_Frame_Start
: System
.Address
:= System
.Null_Address
;
291 Ignored_Frame_End
: System
.Address
:= System
.Null_Address
);
292 -- Print Traceback to File. If Traceback is null, print the call_chain
293 -- at the current location, up to Depth levels, ignoring all addresses
294 -- up to the first one in the range:
295 -- Ignored_Frame_Start .. Ignored_Frame_End
297 procedure Stdout_Put
(S
: String);
298 -- Wrapper for Put that ensures we always write to stdout instead of the
299 -- current output file defined in GNAT.IO.
301 procedure Stdout_Put_Line
(S
: String);
302 -- Wrapper for Put_Line that ensures we always write to stdout instead of
303 -- the current output file defined in GNAT.IO.
305 procedure Print_Traceback
306 (Output_File
: File_Type
;
308 Traceback
: Traceback_Htable_Elem_Ptr
);
309 -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null.
311 procedure Print_Address
(File
: File_Type
; Addr
: Address
);
312 -- Output System.Address without using secondary stack.
313 -- When System.Memory uses Debug_Pool, secondary stack cannot be used
314 -- during Allocate calls, as some Allocate calls are done to
315 -- register/initialize a secondary stack for a foreign thread.
316 -- During these calls, the secondary stack is not available yet.
319 function Is_Handled
(Storage
: System
.Address
) return Boolean;
320 pragma Inline
(Is_Handled
);
321 -- Return True if Storage is the address of a block that the debug pool
322 -- already had under its control. Used to allow System.Memory to use
325 function Is_Valid
(Storage
: System
.Address
) return Boolean;
326 pragma Inline
(Is_Valid
);
327 -- Return True if Storage is the address of a block that the debug pool
328 -- has under its control, in which case Header_Of may be used to access
329 -- the associated allocation header.
331 procedure Set_Valid
(Storage
: System
.Address
; Value
: Boolean);
332 pragma Inline
(Set_Valid
);
333 -- Mark the address Storage as being under control of the memory pool
334 -- (if Value is True), or not (if Value is False).
339 procedure Set_Dead_Beef
340 (Storage_Address
: System
.Address
;
341 Size_In_Storage_Elements
: Storage_Count
);
342 -- Set the contents of the memory block pointed to by Storage_Address to
343 -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
344 -- of the length of this pattern, the last instance may be partial.
346 procedure Free_Physically
(Pool
: in out Debug_Pool
);
347 -- Start to physically release some memory to the system, until the amount
348 -- of logically (but not physically) freed memory is lower than the
349 -- expected amount in Pool.
351 procedure Allocate_End
;
352 procedure Deallocate_End
;
353 procedure Dereference_End
;
354 -- These procedures are used as markers when computing the stacktraces,
355 -- so that addresses in the debug pool itself are not reported to the user.
357 Code_Address_For_Allocate_End
: System
.Address
;
358 Code_Address_For_Deallocate_End
: System
.Address
;
359 Code_Address_For_Dereference_End
: System
.Address
;
360 -- Taking the address of the above procedures will not work on some
361 -- architectures (HPUX for instance). Thus we do the same thing that
362 -- is done in a-except.adb, and get the address of labels instead.
364 procedure Skip_Levels
366 Trace
: Tracebacks_Array
;
368 Len
: in out Natural;
369 Ignored_Frame_Start
: System
.Address
;
370 Ignored_Frame_End
: System
.Address
);
371 -- Set Start .. Len to the range of values from Trace that should be output
372 -- to the user. This range of values excludes any address prior to the
373 -- first one in Ignored_Frame_Start .. Ignored_Frame_End (basically
374 -- addresses internal to this package). Depth is the number of levels that
375 -- the user is interested in.
377 package STBE
renames System
.Traceback_Entries
;
379 function PC_For
(TB_Entry
: STBE
.Traceback_Entry
) return System
.Address
386 function Align
(Addr
: Integer_Address
) return Integer_Address
is
387 Factor
: constant Integer_Address
:= Storage_Alignment
;
389 return ((Addr
+ Factor
- 1) / Factor
) * Factor
;
396 function Header_Of
(Address
: System
.Address
)
397 return Allocation_Header_Access
399 function Convert
is new Ada
.Unchecked_Conversion
400 (System
.Address
, Allocation_Header_Access
);
402 return Convert
(Address
- Header_Offset
);
410 (E
: Traceback_Htable_Elem_Ptr
;
411 Next
: Traceback_Htable_Elem_Ptr
)
422 (E
: Traceback_Htable_Elem_Ptr
) return Traceback_Htable_Elem_Ptr
is
431 function Equal
(K1
, K2
: Tracebacks_Array_Access
) return Boolean is
432 use type Tracebacks_Array
;
434 return K1
.all = K2
.all;
442 (E
: Traceback_Htable_Elem_Ptr
) return Tracebacks_Array_Access
452 function Hash
(T
: Tracebacks_Array_Access
) return Header
is
453 Result
: Integer_Address
:= 0;
456 for X
in T
'Range loop
457 Result
:= Result
+ To_Integer
(PC_For
(T
(X
)));
460 return Header
(1 + Result
mod Integer_Address
(Header
'Last));
467 function Output_File
(Pool
: Debug_Pool
) return File_Type
is
469 if Pool
.Errors_To_Stdout
then
470 return Standard_Output
;
472 return Standard_Error
;
480 procedure Print_Address
(File
: File_Type
; Addr
: Address
) is
482 -- Warning: secondary stack cannot be used here. When System.Memory
483 -- implementation uses Debug_Pool, Print_Address can be called during
484 -- secondary stack creation for foreign threads.
486 Put
(File
, Image_C
(Addr
));
496 Traceback
: Tracebacks_Array_Access
;
497 Ignored_Frame_Start
: System
.Address
:= System
.Null_Address
;
498 Ignored_Frame_End
: System
.Address
:= System
.Null_Address
)
500 procedure Print
(Tr
: Tracebacks_Array
);
501 -- Print the traceback to standard_output
507 procedure Print
(Tr
: Tracebacks_Array
) is
509 for J
in Tr
'Range loop
510 Print_Address
(File
, PC_For
(Tr
(J
)));
513 Put
(File
, ASCII
.LF
);
516 -- Start of processing for Put_Line
519 if Traceback
= null then
523 Trace
: aliased Tracebacks_Array
(1 .. Depth
+ Max_Ignored_Levels
);
526 Call_Chain
(Trace
, Len
);
532 Ignored_Frame_Start
=> Ignored_Frame_Start
,
533 Ignored_Frame_End
=> Ignored_Frame_End
);
534 Print
(Trace
(Start
.. Len
));
538 Print
(Traceback
.all);
546 procedure Skip_Levels
548 Trace
: Tracebacks_Array
;
550 Len
: in out Natural;
551 Ignored_Frame_Start
: System
.Address
;
552 Ignored_Frame_End
: System
.Address
)
555 Start
:= Trace
'First;
558 and then (PC_For
(Trace
(Start
)) < Ignored_Frame_Start
559 or else PC_For
(Trace
(Start
)) > Ignored_Frame_End
)
566 -- Just in case: make sure we have a traceback even if Ignore_Till
573 if Len
- Start
+ 1 > Depth
then
574 Len
:= Depth
+ Start
- 1;
578 ------------------------------
579 -- Find_Or_Create_Traceback --
580 ------------------------------
582 function Find_Or_Create_Traceback
584 Kind
: Traceback_Kind
;
585 Size
: Storage_Count
;
586 Ignored_Frame_Start
: System
.Address
;
587 Ignored_Frame_End
: System
.Address
) return Traceback_Htable_Elem_Ptr
590 if Pool
.Stack_Trace_Depth
= 0 then
595 Disable_Exit_Value
: constant Boolean := Disable
;
597 Elem
: Traceback_Htable_Elem_Ptr
;
600 Trace
: aliased Tracebacks_Array
601 (1 .. Integer (Pool
.Stack_Trace_Depth
) +
606 Call_Chain
(Trace
, Len
);
608 (Depth
=> Pool
.Stack_Trace_Depth
,
612 Ignored_Frame_Start
=> Ignored_Frame_Start
,
613 Ignored_Frame_End
=> Ignored_Frame_End
);
615 -- Check if the traceback is already in the table
618 Backtrace_Htable
.Get
(Trace
(Start
.. Len
)'Unrestricted_Access);
624 new Traceback_Htable_Elem
'
626 new Tracebacks_Array'(Trace
(Start
.. Len
)),
629 Total
=> Byte_Count
(Size
),
633 Backtrace_Htable
.Set
(Elem
);
636 Elem
.Count
:= Elem
.Count
+ 1;
637 Elem
.Total
:= Elem
.Total
+ Byte_Count
(Size
);
640 Disable
:= Disable_Exit_Value
;
644 Disable
:= Disable_Exit_Value
;
647 end Find_Or_Create_Traceback
;
653 package body Validity
is
655 -- The validity bits of the allocated blocks are kept in a has table.
656 -- Each component of the hash table contains the validity bits for a
657 -- 16 Mbyte memory chunk.
659 -- The reason the validity bits are kept for chunks of memory rather
660 -- than in a big array is that on some 64 bit platforms, it may happen
661 -- that two chunk of allocated data are very far from each other.
663 Memory_Chunk_Size
: constant Integer_Address
:= 2 ** 24; -- 16 MB
664 Validity_Divisor
: constant := Storage_Alignment
* System
.Storage_Unit
;
666 Max_Validity_Byte_Index
: constant :=
667 Memory_Chunk_Size
/ Validity_Divisor
;
669 subtype Validity_Byte_Index
is
670 Integer_Address
range 0 .. Max_Validity_Byte_Index
- 1;
672 type Byte
is mod 2 ** System
.Storage_Unit
;
674 type Validity_Bits_Part
is array (Validity_Byte_Index
) of Byte
;
675 type Validity_Bits_Part_Ref
is access all Validity_Bits_Part
;
676 No_Validity_Bits_Part
: constant Validity_Bits_Part_Ref
:= null;
678 type Validity_Bits
is record
679 Valid
: Validity_Bits_Part_Ref
:= No_Validity_Bits_Part
;
680 -- True if chunk of memory at this address is currently allocated
682 Handled
: Validity_Bits_Part_Ref
:= No_Validity_Bits_Part
;
683 -- True if chunk of memory at this address was allocated once after
684 -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate
685 -- if chunk of memory should be handled a block allocated by this
690 type Validity_Bits_Ref
is access all Validity_Bits
;
691 No_Validity_Bits
: constant Validity_Bits_Ref
:= null;
693 Max_Header_Num
: constant := 1023;
695 type Header_Num
is range 0 .. Max_Header_Num
- 1;
697 function Hash
(F
: Integer_Address
) return Header_Num
;
699 function Is_Valid_Or_Handled
700 (Storage
: System
.Address
;
701 Valid
: Boolean) return Boolean;
702 pragma Inline
(Is_Valid_Or_Handled
);
703 -- Internal implementation of Is_Valid and Is_Handled.
704 -- Valid is used to select Valid or Handled arrays.
706 package Validy_Htable
is new GNAT
.HTable
.Simple_HTable
707 (Header_Num
=> Header_Num
,
708 Element
=> Validity_Bits_Ref
,
709 No_Element
=> No_Validity_Bits
,
710 Key
=> Integer_Address
,
713 -- Table to keep the validity and handled bit blocks for the allocated
716 function To_Pointer
is new Ada
.Unchecked_Conversion
717 (System
.Address
, Validity_Bits_Part_Ref
);
719 procedure Memset
(A
: Address
; C
: Integer; N
: size_t
);
720 pragma Import
(C
, Memset
, "memset");
726 function Hash
(F
: Integer_Address
) return Header_Num
is
728 return Header_Num
(F
mod Max_Header_Num
);
731 -------------------------
732 -- Is_Valid_Or_Handled --
733 -------------------------
735 function Is_Valid_Or_Handled
736 (Storage
: System
.Address
;
737 Valid
: Boolean) return Boolean is
738 Int_Storage
: constant Integer_Address
:= To_Integer
(Storage
);
741 -- The pool only returns addresses aligned on Storage_Alignment so
742 -- anything off cannot be a valid block address and we can return
743 -- early in this case. We actually have to since our data structures
744 -- map validity bits for such aligned addresses only.
746 if Int_Storage
mod Storage_Alignment
/= 0 then
751 Block_Number
: constant Integer_Address
:=
752 Int_Storage
/ Memory_Chunk_Size
;
753 Ptr
: constant Validity_Bits_Ref
:=
754 Validy_Htable
.Get
(Block_Number
);
755 Offset
: constant Integer_Address
:=
757 (Block_Number
* Memory_Chunk_Size
)) /
759 Bit
: constant Byte
:=
760 2 ** Natural (Offset
mod System
.Storage_Unit
);
762 if Ptr
= No_Validity_Bits
then
766 return (Ptr
.Valid
(Offset
/ System
.Storage_Unit
)
769 if Ptr
.Handled
= No_Validity_Bits_Part
then
772 return (Ptr
.Handled
(Offset
/ System
.Storage_Unit
)
778 end Is_Valid_Or_Handled
;
784 function Is_Valid
(Storage
: System
.Address
) return Boolean is
786 return Is_Valid_Or_Handled
(Storage
=> Storage
, Valid
=> True);
793 function Is_Handled
(Storage
: System
.Address
) return Boolean is
795 return Is_Valid_Or_Handled
(Storage
=> Storage
, Valid
=> False);
802 procedure Set_Valid
(Storage
: System
.Address
; Value
: Boolean) is
803 Int_Storage
: constant Integer_Address
:= To_Integer
(Storage
);
804 Block_Number
: constant Integer_Address
:=
805 Int_Storage
/ Memory_Chunk_Size
;
806 Ptr
: Validity_Bits_Ref
:= Validy_Htable
.Get
(Block_Number
);
807 Offset
: constant Integer_Address
:=
808 (Int_Storage
- (Block_Number
* Memory_Chunk_Size
)) /
810 Bit
: constant Byte
:=
811 2 ** Natural (Offset
mod System
.Storage_Unit
);
813 procedure Set_Handled
;
814 pragma Inline
(Set_Handled
);
815 -- if Allow_Unhandled_Memory set Handled bit in table.
821 procedure Set_Handled
is
823 if Allow_Unhandled_Memory
then
824 if Ptr
.Handled
= No_Validity_Bits_Part
then
826 To_Pointer
(Alloc
(size_t
(Max_Validity_Byte_Index
)));
828 (A
=> Ptr
.Handled
.all'Address,
830 N
=> size_t
(Max_Validity_Byte_Index
));
833 Ptr
.Handled
(Offset
/ System
.Storage_Unit
) :=
834 Ptr
.Handled
(Offset
/ System
.Storage_Unit
) or Bit
;
838 -- Start of processing for Set_Valid
841 if Ptr
= No_Validity_Bits
then
843 -- First time in this memory area: allocate a new block and put
847 Ptr
:= new Validity_Bits
;
849 To_Pointer
(Alloc
(size_t
(Max_Validity_Byte_Index
)));
850 Validy_Htable
.Set
(Block_Number
, Ptr
);
852 (A
=> Ptr
.Valid
.all'Address,
854 N
=> size_t
(Max_Validity_Byte_Index
));
855 Ptr
.Valid
(Offset
/ System
.Storage_Unit
) := Bit
;
861 Ptr
.Valid
(Offset
/ System
.Storage_Unit
) :=
862 Ptr
.Valid
(Offset
/ System
.Storage_Unit
) or Bit
;
865 Ptr
.Valid
(Offset
/ System
.Storage_Unit
) :=
866 Ptr
.Valid
(Offset
/ System
.Storage_Unit
) and (not Bit
);
877 (Pool
: in out Debug_Pool
;
878 Storage_Address
: out Address
;
879 Size_In_Storage_Elements
: Storage_Count
;
880 Alignment
: Storage_Count
)
882 pragma Unreferenced
(Alignment
);
883 -- Ignored, we always force Storage_Alignment
885 type Local_Storage_Array
is new Storage_Array
886 (1 .. Size_In_Storage_Elements
+ Extra_Allocation
);
888 type Ptr
is access Local_Storage_Array
;
889 -- On some systems, we might want to physically protect pages against
890 -- writing when they have been freed (of course, this is expensive in
891 -- terms of wasted memory). To do that, all we should have to do it to
892 -- set the size of this array to the page size. See mprotect().
894 Current
: Byte_Count
;
896 Trace
: Traceback_Htable_Elem_Ptr
;
898 Reset_Disable_At_Exit
: Boolean := False;
906 System
.CRTL
.malloc
(System
.CRTL
.size_t
(Size_In_Storage_Elements
));
911 Reset_Disable_At_Exit
:= True;
914 Pool
.Alloc_Count
:= Pool
.Alloc_Count
+ 1;
916 -- If necessary, start physically releasing memory. The reason this is
917 -- done here, although Pool.Logically_Deallocated has not changed above,
918 -- is so that we do this only after a series of deallocations (e.g loop
919 -- that deallocates a big array). If we were doing that in Deallocate,
920 -- we might be physically freeing memory several times during the loop,
921 -- which is expensive.
923 if Pool
.Logically_Deallocated
>
924 Byte_Count
(Pool
.Maximum_Logically_Freed_Memory
)
926 Free_Physically
(Pool
);
929 -- Use standard (i.e. through malloc) allocations. This automatically
930 -- raises Storage_Error if needed. We also try once more to physically
931 -- release memory, so that even marked blocks, in the advanced scanning,
932 -- are freed. Note that we do not initialize the storage array since it
933 -- is not necessary to do so (however this will cause bogus valgrind
934 -- warnings, which should simply be ignored).
937 P
:= new Local_Storage_Array
;
940 when Storage_Error
=>
941 Free_Physically
(Pool
);
942 P
:= new Local_Storage_Array
;
945 -- Compute Storage_Address, aimed at receiving user data. We need room
946 -- for the allocation header just ahead of the user data space plus
947 -- alignment padding so Storage_Address is aligned on Storage_Alignment,
950 -- Storage_Address, aligned
951 -- on Storage_Alignment
953 -- | ~~~~ | Header | User data ... |
957 -- Header_Offset is fixed so moving back and forth between user data
958 -- and allocation header is straightforward. The value is also such
959 -- that the header type alignment is honored when starting from
960 -- Default_alignment.
962 -- For the purpose of computing Storage_Address, we just do as if the
963 -- header was located first, followed by the alignment padding:
966 To_Address
(Align
(To_Integer
(P
.all'Address) +
967 Integer_Address
(Header_Offset
)));
968 -- Computation is done in Integer_Address, not Storage_Offset, because
969 -- the range of Storage_Offset may not be large enough.
971 pragma Assert
((Storage_Address
- System
.Null_Address
)
972 mod Storage_Alignment
= 0);
973 pragma Assert
(Storage_Address
+ Size_In_Storage_Elements
974 <= P
.all'Address + P
'Length);
977 Find_Or_Create_Traceback
980 Size
=> Size_In_Storage_Elements
,
981 Ignored_Frame_Start
=> Allocate_Label
'Address,
982 Ignored_Frame_End
=> Code_Address_For_Allocate_End
);
984 pragma Warnings
(Off
);
985 -- Turn warning on alignment for convert call off. We know that in fact
986 -- this conversion is safe since P itself is always aligned on
987 -- Storage_Alignment.
989 Header_Of
(Storage_Address
).all :=
990 (Allocation_Address
=> P
.all'Address,
991 Alloc_Traceback
=> Trace
,
992 Dealloc_Traceback
=> To_Traceback
(null),
993 Next
=> Pool
.First_Used_Block
,
994 Block_Size
=> Size_In_Storage_Elements
);
996 pragma Warnings
(On
);
998 -- Link this block in the list of used blocks. This will be used to list
999 -- memory leaks in Print_Info, and for the advanced schemes of
1000 -- Physical_Free, where we want to traverse all allocated blocks and
1001 -- search for possible references.
1003 -- We insert in front, since most likely we'll be freeing the most
1004 -- recently allocated blocks first (the older one might stay allocated
1005 -- for the whole life of the application).
1007 if Pool
.First_Used_Block
/= System
.Null_Address
then
1008 Header_Of
(Pool
.First_Used_Block
).Dealloc_Traceback
:=
1009 To_Address
(Storage_Address
);
1012 Pool
.First_Used_Block
:= Storage_Address
;
1014 -- Mark the new address as valid
1016 Set_Valid
(Storage_Address
, True);
1018 if Pool
.Low_Level_Traces
then
1019 Put
(Output_File
(Pool
),
1021 & Storage_Count
'Image (Size_In_Storage_Elements
)
1023 Print_Address
(Output_File
(Pool
), Storage_Address
);
1024 Put
(Output_File
(Pool
),
1026 & Storage_Count
'Image (Local_Storage_Array
'Length)
1028 Print_Address
(Output_File
(Pool
), P
.all'Address);
1029 Put
(Output_File
(Pool
),
1031 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1032 Allocate_Label
'Address,
1033 Code_Address_For_Deallocate_End
);
1036 -- Update internal data
1039 Pool
.Allocated
+ Byte_Count
(Size_In_Storage_Elements
);
1041 Current
:= Pool
.Current_Water_Mark
;
1043 if Current
> Pool
.High_Water
then
1044 Pool
.High_Water
:= Current
;
1053 if Reset_Disable_At_Exit
then
1064 -- DO NOT MOVE, this must be right after Allocate. This is similar to what
1065 -- is done in a-except, so that we can hide the traceback frames internal
1068 procedure Allocate_End
is
1070 <<Allocate_End_Label
>>
1071 Code_Address_For_Allocate_End
:= Allocate_End_Label
'Address;
1078 procedure Set_Dead_Beef
1079 (Storage_Address
: System
.Address
;
1080 Size_In_Storage_Elements
: Storage_Count
)
1082 Dead_Bytes
: constant := 4;
1084 type Data
is mod 2 ** (Dead_Bytes
* 8);
1085 for Data
'Size use Dead_Bytes
* 8;
1087 Dead
: constant Data
:= 16#DEAD_BEEF#
;
1089 type Dead_Memory
is array
1090 (1 .. Size_In_Storage_Elements
/ Dead_Bytes
) of Data
;
1091 type Mem_Ptr
is access Dead_Memory
;
1093 type Byte
is mod 2 ** 8;
1094 for Byte
'Size use 8;
1096 type Dead_Memory_Bytes
is array (0 .. 2) of Byte
;
1097 type Dead_Memory_Bytes_Ptr
is access Dead_Memory_Bytes
;
1099 function From_Ptr
is new Ada
.Unchecked_Conversion
1100 (System
.Address
, Mem_Ptr
);
1102 function From_Ptr
is new Ada
.Unchecked_Conversion
1103 (System
.Address
, Dead_Memory_Bytes_Ptr
);
1105 M
: constant Mem_Ptr
:= From_Ptr
(Storage_Address
);
1106 M2
: Dead_Memory_Bytes_Ptr
;
1107 Modulo
: constant Storage_Count
:=
1108 Size_In_Storage_Elements
mod Dead_Bytes
;
1110 M
.all := (others => Dead
);
1112 -- Any bytes left (up to three of them)
1115 M2
:= From_Ptr
(Storage_Address
+ M
'Length * Dead_Bytes
);
1128 ---------------------
1129 -- Free_Physically --
1130 ---------------------
1132 procedure Free_Physically
(Pool
: in out Debug_Pool
) is
1133 type Byte
is mod 256;
1134 type Byte_Access
is access Byte
;
1136 function To_Byte
is new Ada
.Unchecked_Conversion
1137 (System
.Address
, Byte_Access
);
1139 type Address_Access
is access System
.Address
;
1141 function To_Address_Access
is new Ada
.Unchecked_Conversion
1142 (System
.Address
, Address_Access
);
1144 In_Use_Mark
: constant Byte
:= 16#D#
;
1145 Free_Mark
: constant Byte
:= 16#F#
;
1147 Total_Freed
: Storage_Count
:= 0;
1149 procedure Reset_Marks
;
1150 -- Unmark all the logically freed blocks, so that they are considered
1151 -- for physical deallocation
1154 (H
: Allocation_Header_Access
; A
: System
.Address
; In_Use
: Boolean);
1155 -- Mark the user data block starting at A. For a block of size zero,
1156 -- nothing is done. For a block with a different size, the first byte
1157 -- is set to either "D" (in use) or "F" (free).
1159 function Marked
(A
: System
.Address
) return Boolean;
1160 -- Return true if the user data block starting at A might be in use
1163 procedure Mark_Blocks
;
1164 -- Traverse all allocated blocks, and search for possible references
1165 -- to logically freed blocks. Mark them appropriately
1167 procedure Free_Blocks
(Ignore_Marks
: Boolean);
1168 -- Physically release blocks. Only the blocks that haven't been marked
1169 -- will be released, unless Ignore_Marks is true.
1175 procedure Free_Blocks
(Ignore_Marks
: Boolean) is
1176 Header
: Allocation_Header_Access
;
1177 Tmp
: System
.Address
:= Pool
.First_Free_Block
;
1178 Next
: System
.Address
;
1179 Previous
: System
.Address
:= System
.Null_Address
;
1182 while Tmp
/= System
.Null_Address
1183 and then Total_Freed
< Pool
.Minimum_To_Free
1185 Header
:= Header_Of
(Tmp
);
1187 -- If we know, or at least assume, the block is no longer
1188 -- referenced anywhere, we can free it physically.
1190 if Ignore_Marks
or else not Marked
(Tmp
) then
1193 pragma Suppress
(All_Checks
);
1194 -- Suppress the checks on this section. If they are overflow
1195 -- errors, it isn't critical, and we'd rather avoid a
1196 -- Constraint_Error in that case.
1198 -- Note that block_size < zero for freed blocks
1200 Pool
.Physically_Deallocated
:=
1201 Pool
.Physically_Deallocated
-
1202 Byte_Count
(Header
.Block_Size
);
1204 Pool
.Logically_Deallocated
:=
1205 Pool
.Logically_Deallocated
+
1206 Byte_Count
(Header
.Block_Size
);
1208 Total_Freed
:= Total_Freed
- Header
.Block_Size
;
1211 Next
:= Header
.Next
;
1213 if Pool
.Low_Level_Traces
then
1215 (Output_File
(Pool
),
1216 "info: Freeing physical memory "
1217 & Storage_Count
'Image
1218 ((abs Header
.Block_Size
) + Extra_Allocation
)
1220 Print_Address
(Output_File
(Pool
),
1221 Header
.Allocation_Address
);
1222 Put_Line
(Output_File
(Pool
), "");
1225 if System_Memory_Debug_Pool_Enabled
then
1226 System
.CRTL
.free
(Header
.Allocation_Address
);
1228 System
.Memory
.Free
(Header
.Allocation_Address
);
1231 Set_Valid
(Tmp
, False);
1233 -- Remove this block from the list
1235 if Previous
= System
.Null_Address
then
1236 Pool
.First_Free_Block
:= Next
;
1238 Header_Of
(Previous
).Next
:= Next
;
1255 (H
: Allocation_Header_Access
;
1260 if H
.Block_Size
/= 0 then
1261 To_Byte
(A
).all := (if In_Use
then In_Use_Mark
else Free_Mark
);
1269 procedure Mark_Blocks
is
1270 Tmp
: System
.Address
:= Pool
.First_Used_Block
;
1271 Previous
: System
.Address
;
1272 Last
: System
.Address
;
1273 Pointed
: System
.Address
;
1274 Header
: Allocation_Header_Access
;
1277 -- For each allocated block, check its contents. Things that look
1278 -- like a possible address are used to mark the blocks so that we try
1279 -- and keep them, for better detection in case of invalid access.
1280 -- This mechanism is far from being fool-proof: it doesn't check the
1281 -- stacks of the threads, doesn't check possible memory allocated not
1282 -- under control of this debug pool. But it should allow us to catch
1285 while Tmp
/= System
.Null_Address
loop
1287 Last
:= Tmp
+ Header_Of
(Tmp
).Block_Size
;
1288 while Previous
< Last
loop
1289 -- ??? Should we move byte-per-byte, or consider that addresses
1290 -- are always aligned on 4-bytes boundaries ? Let's use the
1293 Pointed
:= To_Address_Access
(Previous
).all;
1294 if Is_Valid
(Pointed
) then
1295 Header
:= Header_Of
(Pointed
);
1297 -- Do not even attempt to mark blocks in use. That would
1298 -- screw up the whole application, of course.
1300 if Header
.Block_Size
< 0 then
1301 Mark
(Header
, Pointed
, In_Use
=> True);
1305 Previous
:= Previous
+ System
.Address
'Size;
1308 Tmp
:= Header_Of
(Tmp
).Next
;
1316 function Marked
(A
: System
.Address
) return Boolean is
1318 return To_Byte
(A
).all = In_Use_Mark
;
1325 procedure Reset_Marks
is
1326 Current
: System
.Address
:= Pool
.First_Free_Block
;
1327 Header
: Allocation_Header_Access
;
1329 while Current
/= System
.Null_Address
loop
1330 Header
:= Header_Of
(Current
);
1331 Mark
(Header
, Current
, False);
1332 Current
:= Header
.Next
;
1336 -- Start of processing for Free_Physically
1341 if Pool
.Advanced_Scanning
then
1343 -- Reset the mark for each freed block
1350 Free_Blocks
(Ignore_Marks
=> not Pool
.Advanced_Scanning
);
1352 -- The contract is that we need to free at least Minimum_To_Free bytes,
1353 -- even if this means freeing marked blocks in the advanced scheme
1355 if Total_Freed
< Pool
.Minimum_To_Free
1356 and then Pool
.Advanced_Scanning
1358 Pool
.Marked_Blocks_Deallocated
:= True;
1359 Free_Blocks
(Ignore_Marks
=> True);
1368 end Free_Physically
;
1375 (Storage_Address
: Address
;
1376 Size_In_Storage_Elements
: out Storage_Count
;
1377 Valid
: out Boolean) is
1381 Valid
:= Is_Valid
(Storage_Address
);
1383 if Is_Valid
(Storage_Address
) then
1385 Header
: constant Allocation_Header_Access
:=
1386 Header_Of
(Storage_Address
);
1388 if Header
.Block_Size
>= 0 then
1390 Size_In_Storage_Elements
:= Header
.Block_Size
;
1408 ---------------------
1409 -- Print_Traceback --
1410 ---------------------
1412 procedure Print_Traceback
1413 (Output_File
: File_Type
;
1415 Traceback
: Traceback_Htable_Elem_Ptr
) is
1417 if Traceback
/= null then
1418 Put
(Output_File
, Prefix
);
1419 Put_Line
(Output_File
, 0, Traceback
.Traceback
);
1421 end Print_Traceback
;
1427 procedure Deallocate
1428 (Pool
: in out Debug_Pool
;
1429 Storage_Address
: Address
;
1430 Size_In_Storage_Elements
: Storage_Count
;
1431 Alignment
: Storage_Count
)
1433 pragma Unreferenced
(Alignment
);
1435 Unlock_Task_Required
: Boolean := False;
1436 Header
: constant Allocation_Header_Access
:=
1437 Header_Of
(Storage_Address
);
1439 Previous
: System
.Address
;
1442 <<Deallocate_Label
>>
1444 Unlock_Task_Required
:= True;
1445 Valid
:= Is_Valid
(Storage_Address
);
1448 Unlock_Task_Required
:= False;
1451 if Storage_Address
= System
.Null_Address
then
1452 if Pool
.Raise_Exceptions
and then
1453 Size_In_Storage_Elements
/= Storage_Count
'Last
1455 raise Freeing_Not_Allocated_Storage
;
1457 Put
(Output_File
(Pool
),
1458 "error: Freeing Null_Address, at ");
1459 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1460 Deallocate_Label
'Address,
1461 Code_Address_For_Deallocate_End
);
1466 if Allow_Unhandled_Memory
and then not Is_Handled
(Storage_Address
)
1468 System
.CRTL
.free
(Storage_Address
);
1472 if Pool
.Raise_Exceptions
and then
1473 Size_In_Storage_Elements
/= Storage_Count
'Last
1475 raise Freeing_Not_Allocated_Storage
;
1477 Put
(Output_File
(Pool
),
1478 "error: Freeing not allocated storage, at ");
1479 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1480 Deallocate_Label
'Address,
1481 Code_Address_For_Deallocate_End
);
1484 elsif Header
.Block_Size
< 0 then
1485 Unlock_Task_Required
:= False;
1487 if Pool
.Raise_Exceptions
then
1488 raise Freeing_Deallocated_Storage
;
1490 Put
(Output_File
(Pool
),
1491 "error: Freeing already deallocated storage, at ");
1492 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1493 Deallocate_Label
'Address,
1494 Code_Address_For_Deallocate_End
);
1495 Print_Traceback
(Output_File
(Pool
),
1496 " Memory already deallocated at ",
1497 To_Traceback
(Header
.Dealloc_Traceback
));
1498 Print_Traceback
(Output_File
(Pool
), " Memory was allocated at ",
1499 Header
.Alloc_Traceback
);
1503 -- Some sort of codegen problem or heap corruption caused the
1504 -- Size_In_Storage_Elements to be wrongly computed.
1505 -- The code below is all based on the assumption that Header.all
1506 -- is not corrupted, such that the error is non-fatal.
1508 if Header
.Block_Size
/= Size_In_Storage_Elements
and then
1509 Size_In_Storage_Elements
/= Storage_Count
'Last
1511 Put_Line
(Output_File
(Pool
),
1512 "error: Deallocate size "
1513 & Storage_Count
'Image (Size_In_Storage_Elements
)
1514 & " does not match allocate size "
1515 & Storage_Count
'Image (Header
.Block_Size
));
1518 if Pool
.Low_Level_Traces
then
1519 Put
(Output_File
(Pool
),
1521 & Storage_Count
'Image (Header
.Block_Size
)
1523 Print_Address
(Output_File
(Pool
), Storage_Address
);
1524 Put
(Output_File
(Pool
),
1526 & Storage_Count
'Image (Header
.Block_Size
+ Extra_Allocation
)
1528 Print_Address
(Output_File
(Pool
), Header
.Allocation_Address
);
1529 Put
(Output_File
(Pool
), "), at ");
1531 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1532 Deallocate_Label
'Address,
1533 Code_Address_For_Deallocate_End
);
1534 Print_Traceback
(Output_File
(Pool
), " Memory was allocated at ",
1535 Header
.Alloc_Traceback
);
1538 -- Remove this block from the list of used blocks
1541 To_Address
(Header
.Dealloc_Traceback
);
1543 if Previous
= System
.Null_Address
then
1544 Pool
.First_Used_Block
:= Header_Of
(Pool
.First_Used_Block
).Next
;
1546 if Pool
.First_Used_Block
/= System
.Null_Address
then
1547 Header_Of
(Pool
.First_Used_Block
).Dealloc_Traceback
:=
1548 To_Traceback
(null);
1552 Header_Of
(Previous
).Next
:= Header
.Next
;
1554 if Header
.Next
/= System
.Null_Address
then
1556 (Header
.Next
).Dealloc_Traceback
:= To_Address
(Previous
);
1560 -- Update the Alloc_Traceback Frees/Total_Frees members (if present)
1562 if Header
.Alloc_Traceback
/= null then
1563 Header
.Alloc_Traceback
.Frees
:= Header
.Alloc_Traceback
.Frees
+ 1;
1564 Header
.Alloc_Traceback
.Total_Frees
:=
1565 Header
.Alloc_Traceback
.Total_Frees
+
1566 Byte_Count
(Header
.Block_Size
);
1569 Pool
.Free_Count
:= Pool
.Free_Count
+ 1;
1571 -- Update the header
1574 (Allocation_Address
=> Header
.Allocation_Address
,
1575 Alloc_Traceback
=> Header
.Alloc_Traceback
,
1576 Dealloc_Traceback
=> To_Traceback
1577 (Find_Or_Create_Traceback
1580 Deallocate_Label
'Address,
1581 Code_Address_For_Deallocate_End
)),
1582 Next
=> System
.Null_Address
,
1583 Block_Size
=> -Header
.Block_Size
);
1585 if Pool
.Reset_Content_On_Free
then
1586 Set_Dead_Beef
(Storage_Address
, -Header
.Block_Size
);
1589 Pool
.Logically_Deallocated
:=
1590 Pool
.Logically_Deallocated
+ Byte_Count
(-Header
.Block_Size
);
1592 -- Link this free block with the others (at the end of the list, so
1593 -- that we can start releasing the older blocks first later on).
1595 if Pool
.First_Free_Block
= System
.Null_Address
then
1596 Pool
.First_Free_Block
:= Storage_Address
;
1597 Pool
.Last_Free_Block
:= Storage_Address
;
1600 Header_Of
(Pool
.Last_Free_Block
).Next
:= Storage_Address
;
1601 Pool
.Last_Free_Block
:= Storage_Address
;
1604 -- Do not physically release the memory here, but in Alloc.
1605 -- See comment there for details.
1607 Unlock_Task_Required
:= False;
1613 if Unlock_Task_Required
then
1619 --------------------
1620 -- Deallocate_End --
1621 --------------------
1623 -- DO NOT MOVE, this must be right after Deallocate
1627 -- This is making assumptions about code order that may be invalid ???
1629 procedure Deallocate_End
is
1631 <<Deallocate_End_Label
>>
1632 Code_Address_For_Deallocate_End
:= Deallocate_End_Label
'Address;
1639 procedure Dereference
1640 (Pool
: in out Debug_Pool
;
1641 Storage_Address
: Address
;
1642 Size_In_Storage_Elements
: Storage_Count
;
1643 Alignment
: Storage_Count
)
1645 pragma Unreferenced
(Alignment
, Size_In_Storage_Elements
);
1647 Valid
: constant Boolean := Is_Valid
(Storage_Address
);
1648 Header
: Allocation_Header_Access
;
1651 -- Locking policy: we do not do any locking in this procedure. The
1652 -- tables are only read, not written to, and although a problem might
1653 -- appear if someone else is modifying the tables at the same time, this
1654 -- race condition is not intended to be detected by this storage_pool (a
1655 -- now invalid pointer would appear as valid). Instead, we prefer
1656 -- optimum performance for dereferences.
1658 <<Dereference_Label
>>
1661 if Pool
.Raise_Exceptions
then
1662 raise Accessing_Not_Allocated_Storage
;
1664 Put
(Output_File
(Pool
),
1665 "error: Accessing not allocated storage, at ");
1666 Put_Line
(Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1667 Dereference_Label
'Address,
1668 Code_Address_For_Dereference_End
);
1672 Header
:= Header_Of
(Storage_Address
);
1674 if Header
.Block_Size
< 0 then
1675 if Pool
.Raise_Exceptions
then
1676 raise Accessing_Deallocated_Storage
;
1678 Put
(Output_File
(Pool
),
1679 "error: Accessing deallocated storage, at ");
1681 (Output_File
(Pool
), Pool
.Stack_Trace_Depth
, null,
1682 Dereference_Label
'Address,
1683 Code_Address_For_Dereference_End
);
1684 Print_Traceback
(Output_File
(Pool
), " First deallocation at ",
1685 To_Traceback
(Header
.Dealloc_Traceback
));
1686 Print_Traceback
(Output_File
(Pool
), " Initial allocation at ",
1687 Header
.Alloc_Traceback
);
1693 ---------------------
1694 -- Dereference_End --
1695 ---------------------
1697 -- DO NOT MOVE: this must be right after Dereference
1701 -- This is making assumptions about code order that may be invalid ???
1703 procedure Dereference_End
is
1705 <<Dereference_End_Label
>>
1706 Code_Address_For_Dereference_End
:= Dereference_End_Label
'Address;
1707 end Dereference_End
;
1713 procedure Print_Info
1715 Cumulate
: Boolean := False;
1716 Display_Slots
: Boolean := False;
1717 Display_Leaks
: Boolean := False)
1720 package Backtrace_Htable_Cumulate
is new GNAT
.HTable
.Static_HTable
1721 (Header_Num
=> Header
,
1722 Element
=> Traceback_Htable_Elem
,
1723 Elmt_Ptr
=> Traceback_Htable_Elem_Ptr
,
1725 Set_Next
=> Set_Next
,
1727 Key
=> Tracebacks_Array_Access
,
1731 -- This needs a comment ??? probably some of the ones below do too???
1733 Data
: Traceback_Htable_Elem_Ptr
;
1734 Elem
: Traceback_Htable_Elem_Ptr
;
1735 Current
: System
.Address
;
1736 Header
: Allocation_Header_Access
;
1741 ("Total allocated bytes : " &
1742 Byte_Count
'Image (Pool
.Allocated
));
1745 ("Total logically deallocated bytes : " &
1746 Byte_Count
'Image (Pool
.Logically_Deallocated
));
1749 ("Total physically deallocated bytes : " &
1750 Byte_Count
'Image (Pool
.Physically_Deallocated
));
1752 if Pool
.Marked_Blocks_Deallocated
then
1753 Put_Line
("Marked blocks were physically deallocated. This is");
1754 Put_Line
("potentially dangerous, and you might want to run");
1755 Put_Line
("again with a lower value of Minimum_To_Free");
1759 ("Current Water Mark: " &
1760 Byte_Count
'Image (Pool
.Current_Water_Mark
));
1763 ("High Water Mark: " &
1764 Byte_Count
'Image (Pool
.High_Water
));
1768 if Display_Slots
then
1769 Data
:= Backtrace_Htable
.Get_First
;
1770 while Data
/= null loop
1771 if Data
.Kind
in Alloc
.. Dealloc
then
1773 new Traceback_Htable_Elem
'
1774 (Traceback => new Tracebacks_Array'(Data
.Traceback
.all),
1775 Count
=> Data
.Count
,
1777 Total
=> Data
.Total
,
1778 Frees
=> Data
.Frees
,
1779 Total_Frees
=> Data
.Total_Frees
,
1781 Backtrace_Htable_Cumulate
.Set
(Elem
);
1784 K
:= (if Data
.Kind
= Alloc
then Indirect_Alloc
1785 else Indirect_Dealloc
);
1787 -- Propagate the direct call to all its parents
1789 for T
in Data
.Traceback
'First + 1 .. Data
.Traceback
'Last loop
1790 Elem
:= Backtrace_Htable_Cumulate
.Get
1792 (T
.. Data
.Traceback
'Last)'Unrestricted_Access);
1794 -- If not, insert it
1797 Elem
:= new Traceback_Htable_Elem
'
1798 (Traceback => new Tracebacks_Array'
1799 (Data
.Traceback
(T
.. Data
.Traceback
'Last)),
1800 Count
=> Data
.Count
,
1802 Total
=> Data
.Total
,
1803 Frees
=> Data
.Frees
,
1804 Total_Frees
=> Data
.Total_Frees
,
1806 Backtrace_Htable_Cumulate
.Set
(Elem
);
1808 -- Properly take into account that the subprograms
1809 -- indirectly called might be doing either allocations
1810 -- or deallocations. This needs to be reflected in the
1814 Elem
.Count
:= Elem
.Count
+ Data
.Count
;
1816 if K
= Elem
.Kind
then
1817 Elem
.Total
:= Elem
.Total
+ Data
.Total
;
1819 elsif Elem
.Total
> Data
.Total
then
1820 Elem
.Total
:= Elem
.Total
- Data
.Total
;
1824 Elem
.Total
:= Data
.Total
- Elem
.Total
;
1830 Data
:= Backtrace_Htable
.Get_Next
;
1834 Put_Line
("List of allocations/deallocations: ");
1836 Data
:= Backtrace_Htable_Cumulate
.Get_First
;
1837 while Data
/= null loop
1839 when Alloc
=> Put
("alloc (count:");
1840 when Indirect_Alloc
=> Put
("indirect alloc (count:");
1841 when Dealloc
=> Put
("free (count:");
1842 when Indirect_Dealloc
=> Put
("indirect free (count:");
1845 Put
(Natural'Image (Data
.Count
) & ", total:" &
1846 Byte_Count
'Image (Data
.Total
) & ") ");
1848 for T
in Data
.Traceback
'Range loop
1849 Put
(Image_C
(PC_For
(Data
.Traceback
(T
))) & ' ');
1854 Data
:= Backtrace_Htable_Cumulate
.Get_Next
;
1857 Backtrace_Htable_Cumulate
.Reset
;
1860 if Display_Leaks
then
1862 Put_Line
("List of not deallocated blocks:");
1864 -- Do not try to group the blocks with the same stack traces
1865 -- together. This is done by the gnatmem output.
1867 Current
:= Pool
.First_Used_Block
;
1868 while Current
/= System
.Null_Address
loop
1869 Header
:= Header_Of
(Current
);
1871 Put
("Size: " & Storage_Count
'Image (Header
.Block_Size
) & " at: ");
1873 if Header
.Alloc_Traceback
/= null then
1874 for T
in Header
.Alloc_Traceback
.Traceback
'Range loop
1876 (PC_For
(Header
.Alloc_Traceback
.Traceback
(T
))) & ' ');
1881 Current
:= Header
.Next
;
1893 Report
: Report_Type
:= All_Reports
) is
1895 Total_Freed
: constant Byte_Count
:=
1896 Pool
.Logically_Deallocated
+ Pool
.Physically_Deallocated
;
1898 procedure Do_Report
(Sort
: Report_Type
);
1899 -- Do a specific type of report
1901 procedure Do_Report
(Sort
: Report_Type
) is
1902 Elem
: Traceback_Htable_Elem_Ptr
;
1904 Grand_Total
: Float;
1906 Max
: array (1 .. Size
) of Traceback_Htable_Elem_Ptr
:=
1908 -- Sorted array for the biggest memory users
1913 when Memory_Usage | All_Reports
=>
1914 Put_Line
(Size
'Img & " biggest memory users at this time:");
1915 Put_Line
("Results include bytes and chunks still allocated");
1916 Grand_Total
:= Float (Pool
.Current_Water_Mark
);
1917 when Allocations_Count
=>
1918 Put_Line
(Size
'Img & " biggest number of live allocations:");
1919 Put_Line
("Results include bytes and chunks still allocated");
1920 Grand_Total
:= Float (Pool
.Current_Water_Mark
);
1921 when Sort_Total_Allocs
=>
1922 Put_Line
(Size
'Img & " biggest number of allocations:");
1923 Put_Line
("Results include total bytes and chunks allocated,");
1924 Put_Line
("even if no longer allocated - Deallocations are"
1926 Grand_Total
:= Float (Pool
.Allocated
);
1927 when Marked_Blocks
=>
1928 Put_Line
("Special blocks marked by Mark_Traceback");
1932 Elem
:= Backtrace_Htable
.Get_First
;
1933 while Elem
/= null loop
1934 -- Handle only alloc elememts
1935 if Elem
.Kind
= Alloc
then
1936 -- Ignore small blocks (depending on the sorting criteria) to
1939 if (Sort
= Memory_Usage
1940 and then Elem
.Total
- Elem
.Total_Frees
>= 1_000
)
1941 or else (Sort
= Allocations_Count
1942 and then Elem
.Count
- Elem
.Frees
>= 1)
1943 or else (Sort
= Sort_Total_Allocs
and then Elem
.Count
> 1)
1944 or else (Sort
= Marked_Blocks
1945 and then Elem
.Total
= 0)
1947 if Sort
= Marked_Blocks
then
1948 Grand_Total
:= Grand_Total
+ Float (Elem
.Count
);
1951 for M
in Max
'Range loop
1952 Bigger
:= Max
(M
) = null;
1955 when Memory_Usage | All_Reports
=>
1957 Max
(M
).Total
- Max
(M
).Total_Frees
<
1958 Elem
.Total
- Elem
.Total_Frees
;
1959 when Allocations_Count
=>
1961 Max
(M
).Count
- Max
(M
).Frees
1962 < Elem
.Count
- Elem
.Frees
;
1963 when Sort_Total_Allocs | Marked_Blocks
=>
1964 Bigger
:= Max
(M
).Count
< Elem
.Count
;
1969 Max
(M
+ 1 .. Max
'Last) := Max
(M
.. Max
'Last - 1);
1977 Elem
:= Backtrace_Htable
.Get_Next
;
1980 if Grand_Total
= 0.0 then
1984 for M
in Max
'Range loop
1985 exit when Max
(M
) = null;
1987 type Percent
is delta 0.1 range 0.0 .. 100.0;
1992 when Memory_Usage | Allocations_Count | All_Reports
=>
1993 Total
:= Max
(M
).Total
- Max
(M
).Total_Frees
;
1994 when Sort_Total_Allocs
=>
1995 Total
:= Max
(M
).Total
;
1996 when Marked_Blocks
=>
1997 Total
:= Byte_Count
(Max
(M
).Count
);
2000 P
:= Percent
(100.0 * Float (Total
) / Grand_Total
);
2002 if Sort
= Marked_Blocks
then
2004 & Max
(M
).Count
'Img & " chunks /"
2005 & Integer (Grand_Total
)'Img & " at");
2007 Put
(P
'Img & "%:" & Total
'Img & " bytes in"
2008 & Max
(M
).Count
'Img & " chunks at");
2012 for J
in Max
(M
).Traceback
'Range loop
2013 Put
(Image_C
(PC_For
(Max
(M
).Traceback
(J
))));
2022 Put_Line
("Ada Allocs:" & Pool
.Allocated
'Img
2023 & " bytes in" & Pool
.Alloc_Count
'Img & " chunks");
2024 Put_Line
("Ada Free:" & Total_Freed
'Img & " bytes in" &
2027 Put_Line
("Ada Current watermark: "
2028 & Byte_Count
'Image (Pool
.Current_Water_Mark
)
2029 & " in" & Byte_Count
'Image (Pool
.Alloc_Count
-
2030 Pool
.Free_Count
) & " chunks");
2031 Put_Line
("Ada High watermark: " & Pool
.High_Water_Mark
'Img);
2035 for Sort
in Report_Type
loop
2036 if Sort
/= All_Reports
then
2051 procedure Dump_Stdout
2054 Report
: Report_Type
:= All_Reports
)
2057 procedure Internal
is new Dump
2058 (Put_Line
=> Stdout_Put_Line
,
2061 -- Start of processing for Dump_Stdout
2064 Internal
(Pool
, Size
, Report
);
2072 Elem
: Traceback_Htable_Elem_Ptr
;
2074 Elem
:= Backtrace_Htable
.Get_First
;
2075 while Elem
/= null loop
2079 Elem
.Total_Frees
:= 0;
2080 Elem
:= Backtrace_Htable
.Get_Next
;
2088 function Storage_Size
(Pool
: Debug_Pool
) return Storage_Count
is
2089 pragma Unreferenced
(Pool
);
2091 return Storage_Count
'Last;
2094 ---------------------
2095 -- High_Water_Mark --
2096 ---------------------
2098 function High_Water_Mark
2099 (Pool
: Debug_Pool
) return Byte_Count
is
2101 return Pool
.High_Water
;
2102 end High_Water_Mark
;
2104 ------------------------
2105 -- Current_Water_Mark --
2106 ------------------------
2108 function Current_Water_Mark
2109 (Pool
: Debug_Pool
) return Byte_Count
is
2111 return Pool
.Allocated
- Pool
.Logically_Deallocated
-
2112 Pool
.Physically_Deallocated
;
2113 end Current_Water_Mark
;
2115 ------------------------------
2116 -- System_Memory_Debug_Pool --
2117 ------------------------------
2119 procedure System_Memory_Debug_Pool
2120 (Has_Unhandled_Memory
: Boolean := True) is
2122 System_Memory_Debug_Pool_Enabled
:= True;
2123 Allow_Unhandled_Memory
:= Has_Unhandled_Memory
;
2124 end System_Memory_Debug_Pool
;
2131 (Pool
: in out Debug_Pool
;
2132 Stack_Trace_Depth
: Natural := Default_Stack_Trace_Depth
;
2133 Maximum_Logically_Freed_Memory
: SSC
:= Default_Max_Freed
;
2134 Minimum_To_Free
: SSC
:= Default_Min_Freed
;
2135 Reset_Content_On_Free
: Boolean := Default_Reset_Content
;
2136 Raise_Exceptions
: Boolean := Default_Raise_Exceptions
;
2137 Advanced_Scanning
: Boolean := Default_Advanced_Scanning
;
2138 Errors_To_Stdout
: Boolean := Default_Errors_To_Stdout
;
2139 Low_Level_Traces
: Boolean := Default_Low_Level_Traces
)
2142 Pool
.Stack_Trace_Depth
:= Stack_Trace_Depth
;
2143 Pool
.Maximum_Logically_Freed_Memory
:= Maximum_Logically_Freed_Memory
;
2144 Pool
.Reset_Content_On_Free
:= Reset_Content_On_Free
;
2145 Pool
.Raise_Exceptions
:= Raise_Exceptions
;
2146 Pool
.Minimum_To_Free
:= Minimum_To_Free
;
2147 Pool
.Advanced_Scanning
:= Advanced_Scanning
;
2148 Pool
.Errors_To_Stdout
:= Errors_To_Stdout
;
2149 Pool
.Low_Level_Traces
:= Low_Level_Traces
;
2156 procedure Print_Pool
(A
: System
.Address
) is
2157 Storage
: constant Address
:= A
;
2158 Valid
: constant Boolean := Is_Valid
(Storage
);
2159 Header
: Allocation_Header_Access
;
2162 -- We might get Null_Address if the call from gdb was done
2163 -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
2164 -- instead of passing the value of my_var
2166 if A
= System
.Null_Address
then
2168 (Standard_Output
, "Memory not under control of the storage pool");
2174 (Standard_Output
, "Memory not under control of the storage pool");
2177 Header
:= Header_Of
(Storage
);
2178 Print_Address
(Standard_Output
, A
);
2179 Put_Line
(Standard_Output
, " allocated at:");
2180 Print_Traceback
(Standard_Output
, "", Header
.Alloc_Traceback
);
2182 if To_Traceback
(Header
.Dealloc_Traceback
) /= null then
2183 Print_Address
(Standard_Output
, A
);
2184 Put_Line
(Standard_Output
,
2185 " logically freed memory, deallocated at:");
2186 Print_Traceback
(Standard_Output
, "",
2187 To_Traceback
(Header
.Dealloc_Traceback
));
2192 -----------------------
2193 -- Print_Info_Stdout --
2194 -----------------------
2196 procedure Print_Info_Stdout
2198 Cumulate
: Boolean := False;
2199 Display_Slots
: Boolean := False;
2200 Display_Leaks
: Boolean := False)
2203 procedure Internal
is new Print_Info
2204 (Put_Line
=> Stdout_Put_Line
,
2207 -- Start of processing for Print_Info_Stdout
2210 Internal
(Pool
, Cumulate
, Display_Slots
, Display_Leaks
);
2211 end Print_Info_Stdout
;
2217 procedure Dump_Gnatmem
(Pool
: Debug_Pool
; File_Name
: String) is
2218 type File_Ptr
is new System
.Address
;
2220 function fopen
(Path
: String; Mode
: String) return File_Ptr
;
2221 pragma Import
(C
, fopen
);
2224 (Ptr
: System
.Address
;
2234 pragma Import
(C
, fwrite
);
2236 procedure fputc
(C
: Integer; Stream
: File_Ptr
);
2237 pragma Import
(C
, fputc
);
2239 procedure fclose
(Stream
: File_Ptr
);
2240 pragma Import
(C
, fclose
);
2242 Address_Size
: constant size_t
:=
2243 System
.Address
'Max_Size_In_Storage_Elements;
2244 -- Size in bytes of a pointer
2247 Current
: System
.Address
;
2248 Header
: Allocation_Header_Access
;
2249 Actual_Size
: size_t
;
2250 Num_Calls
: Integer;
2251 Tracebk
: Tracebacks_Array_Access
;
2252 Dummy_Time
: Duration := 1.0;
2255 File
:= fopen
(File_Name
& ASCII
.NUL
, "wb" & ASCII
.NUL
);
2256 fwrite
("GMEM DUMP" & ASCII
.LF
, 10, 1, File
);
2257 fwrite
(Dummy_Time
'Address, Duration'Max_Size_In_Storage_Elements, 1,
2260 -- List of not deallocated blocks (see Print_Info)
2262 Current
:= Pool
.First_Used_Block
;
2263 while Current
/= System
.Null_Address
loop
2264 Header
:= Header_Of
(Current
);
2266 Actual_Size
:= size_t
(Header
.Block_Size
);
2267 Tracebk
:= Header
.Alloc_Traceback
.Traceback
;
2269 if Header
.Alloc_Traceback
/= null then
2270 Num_Calls
:= Tracebk
'Length;
2272 -- (Code taken from memtrack.adb in GNAT's sources)
2274 -- Logs allocation call using the format:
2276 -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
2278 fputc
(Character'Pos ('A'), File
);
2279 fwrite
(Current
'Address, Address_Size
, 1, File
);
2280 fwrite
(Actual_Size
'Address, size_t
'Max_Size_In_Storage_Elements,
2282 fwrite
(Dummy_Time
'Address, Duration'Max_Size_In_Storage_Elements,
2284 fwrite
(Num_Calls
'Address, Integer'Max_Size_In_Storage_Elements, 1,
2287 for J
in Tracebk
'First .. Tracebk
'First + Num_Calls
- 1 loop
2289 Ptr
: System
.Address
:= PC_For
(Tracebk
(J
));
2291 fwrite
(Ptr
'Address, Address_Size
, 1, File
);
2297 Current
:= Header
.Next
;
2307 procedure Stdout_Put
(S
: String) is
2309 Put
(Standard_Output
, S
);
2312 ---------------------
2313 -- Stdout_Put_Line --
2314 ---------------------
2316 procedure Stdout_Put_Line
(S
: String) is
2318 Put_Line
(Standard_Output
, S
);
2319 end Stdout_Put_Line
;
2321 -- Package initialization
2327 end GNAT
.Debug_Pools
;