]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
fbf5a39b | 5 | -- G N A T . D E B U G _ P O O L S -- |
38cbfe40 | 6 | -- -- |
fbf5a39b | 7 | -- B o d y -- |
38cbfe40 | 8 | -- -- |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
38cbfe40 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
38cbfe40 RK |
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 -- | |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
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. -- | |
21 | -- -- | |
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/>. -- | |
38cbfe40 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
fbf5a39b AC |
32 | with GNAT.IO; use GNAT.IO; |
33 | ||
be7e4a40 | 34 | with System.CRTL; |
fbf5a39b AC |
35 | with System.Memory; use System.Memory; |
36 | with System.Soft_Links; use System.Soft_Links; | |
37 | ||
b0c5fdda | 38 | with System.Traceback_Entries; |
fbf5a39b | 39 | |
bc38dbb4 | 40 | with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; |
38cbfe40 | 41 | with GNAT.HTable; |
fbf5a39b | 42 | with GNAT.Traceback; use GNAT.Traceback; |
38cbfe40 | 43 | |
dd89dddf | 44 | with Ada.Finalization; |
fbf5a39b | 45 | with Ada.Unchecked_Conversion; |
38cbfe40 RK |
46 | |
47 | package body GNAT.Debug_Pools is | |
38cbfe40 | 48 | |
f8c79ade AC |
49 | Storage_Alignment : constant := Standard'Maximum_Alignment; |
50 | -- Alignment enforced for all the memory chunks returned by Allocate, | |
51 | -- maximized to make sure that it will be compatible with all types. | |
52 | -- | |
53 | -- The addresses returned by the underlying low-level allocator (be it | |
54 | -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned | |
55 | -- on some targets, so we manage the needed alignment padding ourselves | |
56 | -- systematically. Use of a common value for every allocation allows | |
57 | -- significant simplifications in the code, nevertheless, for improved | |
58 | -- robustness and efficiency overall. | |
59 | ||
60 | -- We combine a few internal devices to offer the pool services: | |
61 | -- | |
62 | -- * A management header attached to each allocated memory block, located | |
63 | -- right ahead of it, like so: | |
64 | -- | |
65 | -- Storage Address returned by the pool, | |
66 | -- aligned on Storage_Alignment | |
67 | -- v | |
68 | -- +------+--------+--------------------- | |
69 | -- | ~~~~ | HEADER | USER DATA ... | | |
70 | -- +------+--------+--------------------- | |
71 | -- <----> | |
72 | -- alignment | |
73 | -- padding | |
74 | -- | |
75 | -- The alignment padding is required | |
76 | -- | |
77 | -- * A validity bitmap, which holds a validity bit for blocks managed by | |
78 | -- the pool. Enforcing Storage_Alignment on those blocks allows efficient | |
79 | -- validity management. | |
80 | -- | |
81 | -- * A list of currently used blocks. | |
fbf5a39b | 82 | |
fbf5a39b AC |
83 | Max_Ignored_Levels : constant Natural := 10; |
84 | -- Maximum number of levels that will be ignored in backtraces. This is so | |
85 | -- that we still have enough significant levels in the tracebacks returned | |
86 | -- to the user. | |
2989065e | 87 | -- |
fbf5a39b AC |
88 | -- The value 10 is chosen as being greater than the maximum callgraph |
89 | -- in this package. Its actual value is not really relevant, as long as it | |
90 | -- is high enough to make sure we still have enough frames to return to | |
91 | -- the user after we have hidden the frames internal to this package. | |
92 | ||
be7e4a40 AC |
93 | Disable : Boolean := False; |
94 | -- This variable is used to avoid infinite loops, where this package would | |
5f0a92e5 AC |
95 | -- itself allocate memory and then call itself recursively, forever. Useful |
96 | -- when System_Memory_Debug_Pool_Enabled is True. | |
be7e4a40 AC |
97 | |
98 | System_Memory_Debug_Pool_Enabled : Boolean := False; | |
5f0a92e5 | 99 | -- If True, System.Memory allocation uses Debug_Pool |
be7e4a40 AC |
100 | |
101 | Allow_Unhandled_Memory : Boolean := False; | |
5f0a92e5 | 102 | -- If True, protects Deallocate against releasing memory allocated before |
be7e4a40 AC |
103 | -- System_Memory_Debug_Pool_Enabled was set. |
104 | ||
1d2d8a8f AC |
105 | Traceback_Count : Byte_Count := 0; |
106 | -- Total number of traceback elements | |
107 | ||
2989065e RD |
108 | --------------------------- |
109 | -- Back Trace Hash Table -- | |
110 | --------------------------- | |
38cbfe40 | 111 | |
fbf5a39b AC |
112 | -- This package needs to store one set of tracebacks for each allocation |
113 | -- point (when was it allocated or deallocated). This would use too much | |
114 | -- memory, so the tracebacks are actually stored in a hash table, and | |
115 | -- we reference elements in this hash table instead. | |
116 | ||
117 | -- This hash-table will remain empty if the discriminant Stack_Trace_Depth | |
118 | -- for the pools is set to 0. | |
119 | ||
120 | -- This table is a global table, that can be shared among all debug pools | |
121 | -- with no problems. | |
38cbfe40 RK |
122 | |
123 | type Header is range 1 .. 1023; | |
fbf5a39b AC |
124 | -- Number of elements in the hash-table |
125 | ||
b0c5fdda | 126 | type Tracebacks_Array_Access is access Tracebacks_Array; |
fbf5a39b AC |
127 | |
128 | type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc); | |
129 | ||
130 | type Traceback_Htable_Elem; | |
131 | type Traceback_Htable_Elem_Ptr | |
132 | is access Traceback_Htable_Elem; | |
133 | ||
134 | type Traceback_Htable_Elem is record | |
be7e4a40 AC |
135 | Traceback : Tracebacks_Array_Access; |
136 | Kind : Traceback_Kind; | |
137 | Count : Natural; | |
5f0a92e5 | 138 | -- Size of the memory allocated/freed at Traceback since last Reset call |
be7e4a40 AC |
139 | |
140 | Total : Byte_Count; | |
5f0a92e5 | 141 | -- Number of chunk of memory allocated/freed at Traceback since last |
be7e4a40 AC |
142 | -- Reset call. |
143 | ||
144 | Frees : Natural; | |
5f0a92e5 | 145 | -- Number of chunk of memory allocated at Traceback, currently freed |
be7e4a40 AC |
146 | -- since last Reset call. (only for Alloc & Indirect_Alloc elements) |
147 | ||
148 | Total_Frees : Byte_Count; | |
5f0a92e5 | 149 | -- Size of the memory allocated at Traceback, currently freed since last |
be7e4a40 AC |
150 | -- Reset call. (only for Alloc & Indirect_Alloc elements) |
151 | ||
152 | Next : Traceback_Htable_Elem_Ptr; | |
fbf5a39b AC |
153 | end record; |
154 | ||
2989065e RD |
155 | -- Subprograms used for the Backtrace_Htable instantiation |
156 | ||
fbf5a39b AC |
157 | procedure Set_Next |
158 | (E : Traceback_Htable_Elem_Ptr; | |
159 | Next : Traceback_Htable_Elem_Ptr); | |
2989065e RD |
160 | pragma Inline (Set_Next); |
161 | ||
fbf5a39b | 162 | function Next |
2989065e RD |
163 | (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; |
164 | pragma Inline (Next); | |
165 | ||
fbf5a39b | 166 | function Get_Key |
2989065e RD |
167 | (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; |
168 | pragma Inline (Get_Key); | |
169 | ||
fbf5a39b | 170 | function Hash (T : Tracebacks_Array_Access) return Header; |
2989065e RD |
171 | pragma Inline (Hash); |
172 | ||
fbf5a39b | 173 | function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; |
2989065e RD |
174 | -- Why is this not inlined??? |
175 | ||
176 | -- The hash table for back traces | |
fbf5a39b AC |
177 | |
178 | package Backtrace_Htable is new GNAT.HTable.Static_HTable | |
179 | (Header_Num => Header, | |
180 | Element => Traceback_Htable_Elem, | |
181 | Elmt_Ptr => Traceback_Htable_Elem_Ptr, | |
182 | Null_Ptr => null, | |
183 | Set_Next => Set_Next, | |
184 | Next => Next, | |
185 | Key => Tracebacks_Array_Access, | |
186 | Get_Key => Get_Key, | |
187 | Hash => Hash, | |
188 | Equal => Equal); | |
189 | ||
190 | ----------------------- | |
191 | -- Allocations table -- | |
192 | ----------------------- | |
193 | ||
194 | type Allocation_Header; | |
195 | type Allocation_Header_Access is access Allocation_Header; | |
196 | ||
fbf5a39b AC |
197 | type Traceback_Ptr_Or_Address is new System.Address; |
198 | -- A type that acts as a C union, and is either a System.Address or a | |
199 | -- Traceback_Htable_Elem_Ptr. | |
200 | ||
2989065e RD |
201 | -- The following record stores extra information that needs to be |
202 | -- memorized for each block allocated with the special debug pool. | |
203 | ||
fbf5a39b | 204 | type Allocation_Header is record |
cc335f43 | 205 | Allocation_Address : System.Address; |
2989065e | 206 | -- Address of the block returned by malloc, possibly unaligned |
cc335f43 | 207 | |
2989065e | 208 | Block_Size : Storage_Offset; |
fbf5a39b AC |
209 | -- Needed only for advanced freeing algorithms (traverse all allocated |
210 | -- blocks for potential references). This value is negated when the | |
211 | -- chunk of memory has been logically freed by the application. This | |
212 | -- chunk has not been physically released yet. | |
213 | ||
2989065e RD |
214 | Alloc_Traceback : Traceback_Htable_Elem_Ptr; |
215 | -- ??? comment required | |
216 | ||
fbf5a39b | 217 | Dealloc_Traceback : Traceback_Ptr_Or_Address; |
cc335f43 | 218 | -- Pointer to the traceback for the allocation (if the memory chunk is |
fbf5a39b AC |
219 | -- still valid), or to the first deallocation otherwise. Make sure this |
220 | -- is a thin pointer to save space. | |
221 | -- | |
222 | -- Dealloc_Traceback is also for blocks that are still allocated to | |
223 | -- point to the previous block in the list. This saves space in this | |
224 | -- header, and make manipulation of the lists of allocated pointers | |
225 | -- faster. | |
226 | ||
227 | Next : System.Address; | |
228 | -- Point to the next block of the same type (either allocated or | |
229 | -- logically freed) in memory. This points to the beginning of the user | |
230 | -- data, and does not include the header of that block. | |
231 | end record; | |
232 | ||
bc38dbb4 AC |
233 | function Header_Of |
234 | (Address : System.Address) return Allocation_Header_Access; | |
fbf5a39b AC |
235 | pragma Inline (Header_Of); |
236 | -- Return the header corresponding to a previously allocated address | |
237 | ||
238 | function To_Address is new Ada.Unchecked_Conversion | |
239 | (Traceback_Ptr_Or_Address, System.Address); | |
2989065e | 240 | |
fbf5a39b AC |
241 | function To_Address is new Ada.Unchecked_Conversion |
242 | (System.Address, Traceback_Ptr_Or_Address); | |
2989065e | 243 | |
fbf5a39b AC |
244 | function To_Traceback is new Ada.Unchecked_Conversion |
245 | (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr); | |
2989065e | 246 | |
fbf5a39b AC |
247 | function To_Traceback is new Ada.Unchecked_Conversion |
248 | (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address); | |
249 | ||
2989065e | 250 | Header_Offset : constant Storage_Count := |
f8c79ade AC |
251 | (Allocation_Header'Object_Size / System.Storage_Unit); |
252 | -- Offset, in bytes, from start of allocation Header to start of User | |
253 | -- data. The start of user data is assumed to be aligned at least as much | |
254 | -- as what the header type requires, so applying this offset yields a | |
255 | -- suitably aligned address as well. | |
256 | ||
257 | Extra_Allocation : constant Storage_Count := | |
258 | (Storage_Alignment - 1 + Header_Offset); | |
259 | -- Amount we need to secure in addition to the user data for a given | |
260 | -- allocation request: room for the allocation header plus worst-case | |
261 | -- alignment padding. | |
fbf5a39b | 262 | |
fbf5a39b AC |
263 | ----------------------- |
264 | -- Local subprograms -- | |
265 | ----------------------- | |
266 | ||
f8c79ade AC |
267 | function Align (Addr : Integer_Address) return Integer_Address; |
268 | pragma Inline (Align); | |
269 | -- Return the next address aligned on Storage_Alignment from Addr. | |
270 | ||
fbf5a39b AC |
271 | function Find_Or_Create_Traceback |
272 | (Pool : Debug_Pool; | |
273 | Kind : Traceback_Kind; | |
274 | Size : Storage_Count; | |
275 | Ignored_Frame_Start : System.Address; | |
2989065e | 276 | Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr; |
fbf5a39b AC |
277 | -- Return an element matching the current traceback (omitting the frames |
278 | -- that are in the current package). If this traceback already existed in | |
279 | -- the htable, a pointer to this is returned to spare memory. Null is | |
280 | -- returned if the pool is set not to store tracebacks. If the traceback | |
281 | -- already existed in the table, the count is incremented so that | |
2989065e RD |
282 | -- Dump_Tracebacks returns useful results. All addresses up to, and |
283 | -- including, an address between Ignored_Frame_Start .. Ignored_Frame_End | |
284 | -- are ignored. | |
fbf5a39b | 285 | |
f38df0e1 VC |
286 | function Output_File (Pool : Debug_Pool) return File_Type; |
287 | pragma Inline (Output_File); | |
288 | -- Returns file_type on which error messages have to be generated for Pool | |
289 | ||
fbf5a39b | 290 | procedure Put_Line |
f38df0e1 VC |
291 | (File : File_Type; |
292 | Depth : Natural; | |
fbf5a39b AC |
293 | Traceback : Tracebacks_Array_Access; |
294 | Ignored_Frame_Start : System.Address := System.Null_Address; | |
295 | Ignored_Frame_End : System.Address := System.Null_Address); | |
f38df0e1 VC |
296 | -- Print Traceback to File. If Traceback is null, print the call_chain |
297 | -- at the current location, up to Depth levels, ignoring all addresses | |
298 | -- up to the first one in the range: | |
299 | -- Ignored_Frame_Start .. Ignored_Frame_End | |
fbf5a39b | 300 | |
bc38dbb4 | 301 | procedure Stdout_Put (S : String); |
5f0a92e5 AC |
302 | -- Wrapper for Put that ensures we always write to stdout instead of the |
303 | -- current output file defined in GNAT.IO. | |
be7e4a40 AC |
304 | |
305 | procedure Stdout_Put_Line (S : String); | |
5f0a92e5 AC |
306 | -- Wrapper for Put_Line that ensures we always write to stdout instead of |
307 | -- the current output file defined in GNAT.IO. | |
be7e4a40 | 308 | |
c96c518f AC |
309 | procedure Print_Traceback |
310 | (Output_File : File_Type; | |
311 | Prefix : String; | |
312 | Traceback : Traceback_Htable_Elem_Ptr); | |
bc38dbb4 | 313 | -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null. |
c96c518f AC |
314 | |
315 | procedure Print_Address (File : File_Type; Addr : Address); | |
316 | -- Output System.Address without using secondary stack. | |
317 | -- When System.Memory uses Debug_Pool, secondary stack cannot be used | |
318 | -- during Allocate calls, as some Allocate calls are done to | |
319 | -- register/initialize a secondary stack for a foreign thread. | |
320 | -- During these calls, the secondary stack is not available yet. | |
321 | ||
11f03980 | 322 | package Validity is |
be7e4a40 AC |
323 | function Is_Handled (Storage : System.Address) return Boolean; |
324 | pragma Inline (Is_Handled); | |
325 | -- Return True if Storage is the address of a block that the debug pool | |
5f0a92e5 AC |
326 | -- already had under its control. Used to allow System.Memory to use |
327 | -- Debug_Pools | |
be7e4a40 | 328 | |
11f03980 VC |
329 | function Is_Valid (Storage : System.Address) return Boolean; |
330 | pragma Inline (Is_Valid); | |
f38df0e1 VC |
331 | -- Return True if Storage is the address of a block that the debug pool |
332 | -- has under its control, in which case Header_Of may be used to access | |
333 | -- the associated allocation header. | |
fbf5a39b | 334 | |
11f03980 VC |
335 | procedure Set_Valid (Storage : System.Address; Value : Boolean); |
336 | pragma Inline (Set_Valid); | |
337 | -- Mark the address Storage as being under control of the memory pool | |
338 | -- (if Value is True), or not (if Value is False). | |
1d2d8a8f AC |
339 | |
340 | Validity_Count : Byte_Count := 0; | |
341 | -- Total number of validity elements | |
342 | ||
11f03980 VC |
343 | end Validity; |
344 | ||
345 | use Validity; | |
fbf5a39b AC |
346 | |
347 | procedure Set_Dead_Beef | |
348 | (Storage_Address : System.Address; | |
349 | Size_In_Storage_Elements : Storage_Count); | |
350 | -- Set the contents of the memory block pointed to by Storage_Address to | |
351 | -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple | |
352 | -- of the length of this pattern, the last instance may be partial. | |
353 | ||
354 | procedure Free_Physically (Pool : in out Debug_Pool); | |
355 | -- Start to physically release some memory to the system, until the amount | |
356 | -- of logically (but not physically) freed memory is lower than the | |
357 | -- expected amount in Pool. | |
358 | ||
359 | procedure Allocate_End; | |
360 | procedure Deallocate_End; | |
361 | procedure Dereference_End; | |
362 | -- These procedures are used as markers when computing the stacktraces, | |
363 | -- so that addresses in the debug pool itself are not reported to the user. | |
364 | ||
365 | Code_Address_For_Allocate_End : System.Address; | |
366 | Code_Address_For_Deallocate_End : System.Address; | |
367 | Code_Address_For_Dereference_End : System.Address; | |
368 | -- Taking the address of the above procedures will not work on some | |
7a5b62b0 AC |
369 | -- architectures (HPUX for instance). Thus we do the same thing that |
370 | -- is done in a-except.adb, and get the address of labels instead. | |
fbf5a39b AC |
371 | |
372 | procedure Skip_Levels | |
373 | (Depth : Natural; | |
374 | Trace : Tracebacks_Array; | |
375 | Start : out Natural; | |
376 | Len : in out Natural; | |
377 | Ignored_Frame_Start : System.Address; | |
378 | Ignored_Frame_End : System.Address); | |
379 | -- Set Start .. Len to the range of values from Trace that should be output | |
e14c931f RW |
380 | -- to the user. This range of values excludes any address prior to the |
381 | -- first one in Ignored_Frame_Start .. Ignored_Frame_End (basically | |
382 | -- addresses internal to this package). Depth is the number of levels that | |
383 | -- the user is interested in. | |
fbf5a39b | 384 | |
b0c5fdda AC |
385 | package STBE renames System.Traceback_Entries; |
386 | ||
387 | function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address | |
388 | renames STBE.PC_For; | |
389 | ||
dd89dddf AC |
390 | type Scope_Lock is |
391 | new Ada.Finalization.Limited_Controlled with null record; | |
c23c86bb | 392 | -- Used to handle Lock_Task/Unlock_Task calls |
dd89dddf AC |
393 | |
394 | overriding procedure Initialize (This : in out Scope_Lock); | |
c23c86bb | 395 | -- Lock task on initialization |
dd89dddf AC |
396 | |
397 | overriding procedure Finalize (This : in out Scope_Lock); | |
c23c86bb | 398 | -- Unlock task on finalization |
dd89dddf AC |
399 | |
400 | ---------------- | |
401 | -- Initialize -- | |
402 | ---------------- | |
403 | ||
404 | procedure Initialize (This : in out Scope_Lock) is | |
405 | pragma Unreferenced (This); | |
406 | begin | |
407 | Lock_Task.all; | |
408 | end Initialize; | |
409 | ||
410 | -------------- | |
411 | -- Finalize -- | |
412 | -------------- | |
413 | ||
414 | procedure Finalize (This : in out Scope_Lock) is | |
415 | pragma Unreferenced (This); | |
416 | begin | |
417 | Unlock_Task.all; | |
418 | end Finalize; | |
419 | ||
f8c79ade AC |
420 | ----------- |
421 | -- Align -- | |
422 | ----------- | |
423 | ||
424 | function Align (Addr : Integer_Address) return Integer_Address is | |
425 | Factor : constant Integer_Address := Storage_Alignment; | |
426 | begin | |
427 | return ((Addr + Factor - 1) / Factor) * Factor; | |
428 | end Align; | |
429 | ||
fbf5a39b AC |
430 | --------------- |
431 | -- Header_Of -- | |
432 | --------------- | |
433 | ||
c23c86bb AC |
434 | function Header_Of |
435 | (Address : System.Address) return Allocation_Header_Access | |
fbf5a39b | 436 | is |
c23c86bb AC |
437 | function Convert is |
438 | new Ada.Unchecked_Conversion | |
439 | (System.Address, | |
440 | Allocation_Header_Access); | |
fbf5a39b | 441 | begin |
cc335f43 | 442 | return Convert (Address - Header_Offset); |
fbf5a39b AC |
443 | end Header_Of; |
444 | ||
445 | -------------- | |
446 | -- Set_Next -- | |
447 | -------------- | |
448 | ||
449 | procedure Set_Next | |
450 | (E : Traceback_Htable_Elem_Ptr; | |
451 | Next : Traceback_Htable_Elem_Ptr) | |
452 | is | |
453 | begin | |
454 | E.Next := Next; | |
455 | end Set_Next; | |
456 | ||
457 | ---------- | |
458 | -- Next -- | |
459 | ---------- | |
460 | ||
461 | function Next | |
c23c86bb AC |
462 | (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr |
463 | is | |
fbf5a39b AC |
464 | begin |
465 | return E.Next; | |
466 | end Next; | |
467 | ||
468 | ----------- | |
469 | -- Equal -- | |
470 | ----------- | |
471 | ||
472 | function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is | |
b0c5fdda | 473 | use type Tracebacks_Array; |
fbf5a39b AC |
474 | begin |
475 | return K1.all = K2.all; | |
476 | end Equal; | |
477 | ||
478 | ------------- | |
479 | -- Get_Key -- | |
480 | ------------- | |
481 | ||
482 | function Get_Key | |
2989065e | 483 | (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access |
fbf5a39b AC |
484 | is |
485 | begin | |
486 | return E.Traceback; | |
487 | end Get_Key; | |
488 | ||
489 | ---------- | |
490 | -- Hash -- | |
491 | ---------- | |
38cbfe40 | 492 | |
fbf5a39b AC |
493 | function Hash (T : Tracebacks_Array_Access) return Header is |
494 | Result : Integer_Address := 0; | |
2989065e | 495 | |
fbf5a39b AC |
496 | begin |
497 | for X in T'Range loop | |
498 | Result := Result + To_Integer (PC_For (T (X))); | |
499 | end loop; | |
2989065e | 500 | |
fbf5a39b AC |
501 | return Header (1 + Result mod Integer_Address (Header'Last)); |
502 | end Hash; | |
503 | ||
f38df0e1 VC |
504 | ----------------- |
505 | -- Output_File -- | |
506 | ----------------- | |
507 | ||
508 | function Output_File (Pool : Debug_Pool) return File_Type is | |
509 | begin | |
510 | if Pool.Errors_To_Stdout then | |
511 | return Standard_Output; | |
512 | else | |
513 | return Standard_Error; | |
514 | end if; | |
515 | end Output_File; | |
516 | ||
c96c518f AC |
517 | ------------------- |
518 | -- Print_Address -- | |
519 | ------------------- | |
520 | ||
521 | procedure Print_Address (File : File_Type; Addr : Address) is | |
c96c518f | 522 | begin |
bc38dbb4 AC |
523 | -- Warning: secondary stack cannot be used here. When System.Memory |
524 | -- implementation uses Debug_Pool, Print_Address can be called during | |
525 | -- secondary stack creation for foreign threads. | |
90b510e4 | 526 | |
bc38dbb4 | 527 | Put (File, Image_C (Addr)); |
c96c518f AC |
528 | end Print_Address; |
529 | ||
fbf5a39b AC |
530 | -------------- |
531 | -- Put_Line -- | |
532 | -------------- | |
533 | ||
534 | procedure Put_Line | |
f38df0e1 VC |
535 | (File : File_Type; |
536 | Depth : Natural; | |
fbf5a39b AC |
537 | Traceback : Tracebacks_Array_Access; |
538 | Ignored_Frame_Start : System.Address := System.Null_Address; | |
539 | Ignored_Frame_End : System.Address := System.Null_Address) | |
540 | is | |
541 | procedure Print (Tr : Tracebacks_Array); | |
542 | -- Print the traceback to standard_output | |
543 | ||
544 | ----------- | |
545 | -- Print -- | |
546 | ----------- | |
547 | ||
548 | procedure Print (Tr : Tracebacks_Array) is | |
549 | begin | |
550 | for J in Tr'Range loop | |
c96c518f AC |
551 | Print_Address (File, PC_For (Tr (J))); |
552 | Put (File, ' '); | |
fbf5a39b | 553 | end loop; |
f38df0e1 | 554 | Put (File, ASCII.LF); |
fbf5a39b AC |
555 | end Print; |
556 | ||
557 | -- Start of processing for Put_Line | |
558 | ||
559 | begin | |
560 | if Traceback = null then | |
561 | declare | |
bc38dbb4 AC |
562 | Len : Natural; |
563 | Start : Natural; | |
564 | Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); | |
fbf5a39b AC |
565 | |
566 | begin | |
bc38dbb4 AC |
567 | Call_Chain (Trace, Len); |
568 | Skip_Levels | |
569 | (Depth => Depth, | |
570 | Trace => Trace, | |
571 | Start => Start, | |
572 | Len => Len, | |
573 | Ignored_Frame_Start => Ignored_Frame_Start, | |
574 | Ignored_Frame_End => Ignored_Frame_End); | |
575 | Print (Trace (Start .. Len)); | |
fbf5a39b AC |
576 | end; |
577 | ||
578 | else | |
579 | Print (Traceback.all); | |
580 | end if; | |
581 | end Put_Line; | |
582 | ||
583 | ----------------- | |
584 | -- Skip_Levels -- | |
585 | ----------------- | |
586 | ||
587 | procedure Skip_Levels | |
588 | (Depth : Natural; | |
589 | Trace : Tracebacks_Array; | |
590 | Start : out Natural; | |
591 | Len : in out Natural; | |
592 | Ignored_Frame_Start : System.Address; | |
593 | Ignored_Frame_End : System.Address) | |
594 | is | |
595 | begin | |
596 | Start := Trace'First; | |
597 | ||
598 | while Start <= Len | |
599 | and then (PC_For (Trace (Start)) < Ignored_Frame_Start | |
600 | or else PC_For (Trace (Start)) > Ignored_Frame_End) | |
601 | loop | |
602 | Start := Start + 1; | |
603 | end loop; | |
604 | ||
605 | Start := Start + 1; | |
606 | ||
607 | -- Just in case: make sure we have a traceback even if Ignore_Till | |
608 | -- wasn't found. | |
609 | ||
610 | if Start > Len then | |
611 | Start := 1; | |
612 | end if; | |
613 | ||
614 | if Len - Start + 1 > Depth then | |
615 | Len := Depth + Start - 1; | |
616 | end if; | |
617 | end Skip_Levels; | |
618 | ||
619 | ------------------------------ | |
620 | -- Find_Or_Create_Traceback -- | |
621 | ------------------------------ | |
622 | ||
623 | function Find_Or_Create_Traceback | |
624 | (Pool : Debug_Pool; | |
625 | Kind : Traceback_Kind; | |
626 | Size : Storage_Count; | |
627 | Ignored_Frame_Start : System.Address; | |
2989065e | 628 | Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr |
fbf5a39b AC |
629 | is |
630 | begin | |
631 | if Pool.Stack_Trace_Depth = 0 then | |
632 | return null; | |
633 | end if; | |
634 | ||
635 | declare | |
be7e4a40 | 636 | Disable_Exit_Value : constant Boolean := Disable; |
bc38dbb4 | 637 | |
fbf5a39b | 638 | Elem : Traceback_Htable_Elem_Ptr; |
bc38dbb4 AC |
639 | Len : Natural; |
640 | Start : Natural; | |
641 | Trace : aliased Tracebacks_Array | |
642 | (1 .. Integer (Pool.Stack_Trace_Depth) + | |
643 | Max_Ignored_Levels); | |
fbf5a39b AC |
644 | |
645 | begin | |
be7e4a40 | 646 | Disable := True; |
fbf5a39b | 647 | Call_Chain (Trace, Len); |
bc38dbb4 AC |
648 | Skip_Levels |
649 | (Depth => Pool.Stack_Trace_Depth, | |
650 | Trace => Trace, | |
651 | Start => Start, | |
652 | Len => Len, | |
653 | Ignored_Frame_Start => Ignored_Frame_Start, | |
654 | Ignored_Frame_End => Ignored_Frame_End); | |
fbf5a39b | 655 | |
2989065e | 656 | -- Check if the traceback is already in the table |
fbf5a39b AC |
657 | |
658 | Elem := | |
659 | Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access); | |
660 | ||
661 | -- If not, insert it | |
662 | ||
663 | if Elem = null then | |
bc38dbb4 AC |
664 | Elem := |
665 | new Traceback_Htable_Elem' | |
666 | (Traceback => | |
667 | new Tracebacks_Array'(Trace (Start .. Len)), | |
668 | Count => 1, | |
669 | Kind => Kind, | |
670 | Total => Byte_Count (Size), | |
671 | Frees => 0, | |
672 | Total_Frees => 0, | |
673 | Next => null); | |
1d2d8a8f | 674 | Traceback_Count := Traceback_Count + 1; |
fbf5a39b AC |
675 | Backtrace_Htable.Set (Elem); |
676 | ||
677 | else | |
678 | Elem.Count := Elem.Count + 1; | |
679 | Elem.Total := Elem.Total + Byte_Count (Size); | |
680 | end if; | |
681 | ||
be7e4a40 | 682 | Disable := Disable_Exit_Value; |
fbf5a39b | 683 | return Elem; |
be7e4a40 AC |
684 | exception |
685 | when others => | |
686 | Disable := Disable_Exit_Value; | |
687 | raise; | |
fbf5a39b AC |
688 | end; |
689 | end Find_Or_Create_Traceback; | |
690 | ||
691 | -------------- | |
11f03980 | 692 | -- Validity -- |
fbf5a39b AC |
693 | -------------- |
694 | ||
11f03980 | 695 | package body Validity is |
5b8b9057 | 696 | |
11f03980 VC |
697 | -- The validity bits of the allocated blocks are kept in a has table. |
698 | -- Each component of the hash table contains the validity bits for a | |
699 | -- 16 Mbyte memory chunk. | |
5b8b9057 | 700 | |
11f03980 VC |
701 | -- The reason the validity bits are kept for chunks of memory rather |
702 | -- than in a big array is that on some 64 bit platforms, it may happen | |
703 | -- that two chunk of allocated data are very far from each other. | |
5b8b9057 | 704 | |
11f03980 | 705 | Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB |
f8c79ade | 706 | Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; |
5b8b9057 | 707 | |
11f03980 | 708 | Max_Validity_Byte_Index : constant := |
bc38dbb4 | 709 | Memory_Chunk_Size / Validity_Divisor; |
fbf5a39b | 710 | |
bc38dbb4 AC |
711 | subtype Validity_Byte_Index is |
712 | Integer_Address range 0 .. Max_Validity_Byte_Index - 1; | |
fbf5a39b | 713 | |
11f03980 | 714 | type Byte is mod 2 ** System.Storage_Unit; |
fbf5a39b | 715 | |
be7e4a40 AC |
716 | type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; |
717 | type Validity_Bits_Part_Ref is access all Validity_Bits_Part; | |
718 | No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; | |
719 | ||
720 | type Validity_Bits is record | |
721 | Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; | |
5f0a92e5 | 722 | -- True if chunk of memory at this address is currently allocated |
be7e4a40 AC |
723 | |
724 | Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; | |
725 | -- True if chunk of memory at this address was allocated once after | |
5f0a92e5 AC |
726 | -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate |
727 | -- if chunk of memory should be handled a block allocated by this | |
728 | -- package. | |
be7e4a40 AC |
729 | |
730 | end record; | |
fbf5a39b | 731 | |
11f03980 VC |
732 | type Validity_Bits_Ref is access all Validity_Bits; |
733 | No_Validity_Bits : constant Validity_Bits_Ref := null; | |
fbf5a39b | 734 | |
11f03980 | 735 | Max_Header_Num : constant := 1023; |
fbf5a39b | 736 | |
11f03980 | 737 | type Header_Num is range 0 .. Max_Header_Num - 1; |
fbf5a39b | 738 | |
11f03980 | 739 | function Hash (F : Integer_Address) return Header_Num; |
fbf5a39b | 740 | |
be7e4a40 AC |
741 | function Is_Valid_Or_Handled |
742 | (Storage : System.Address; | |
743 | Valid : Boolean) return Boolean; | |
744 | pragma Inline (Is_Valid_Or_Handled); | |
5f0a92e5 | 745 | -- Internal implementation of Is_Valid and Is_Handled. |
be7e4a40 AC |
746 | -- Valid is used to select Valid or Handled arrays. |
747 | ||
11f03980 VC |
748 | package Validy_Htable is new GNAT.HTable.Simple_HTable |
749 | (Header_Num => Header_Num, | |
750 | Element => Validity_Bits_Ref, | |
751 | No_Element => No_Validity_Bits, | |
752 | Key => Integer_Address, | |
753 | Hash => Hash, | |
754 | Equal => "="); | |
be7e4a40 | 755 | -- Table to keep the validity and handled bit blocks for the allocated |
5f0a92e5 | 756 | -- data. |
fbf5a39b | 757 | |
11f03980 | 758 | function To_Pointer is new Ada.Unchecked_Conversion |
be7e4a40 | 759 | (System.Address, Validity_Bits_Part_Ref); |
fbf5a39b | 760 | |
11f03980 VC |
761 | procedure Memset (A : Address; C : Integer; N : size_t); |
762 | pragma Import (C, Memset, "memset"); | |
2989065e | 763 | |
11f03980 VC |
764 | ---------- |
765 | -- Hash -- | |
766 | ---------- | |
2989065e | 767 | |
11f03980 VC |
768 | function Hash (F : Integer_Address) return Header_Num is |
769 | begin | |
770 | return Header_Num (F mod Max_Header_Num); | |
771 | end Hash; | |
772 | ||
be7e4a40 AC |
773 | ------------------------- |
774 | -- Is_Valid_Or_Handled -- | |
775 | ------------------------- | |
11f03980 | 776 | |
be7e4a40 AC |
777 | function Is_Valid_Or_Handled |
778 | (Storage : System.Address; | |
779 | Valid : Boolean) return Boolean is | |
11f03980 | 780 | Int_Storage : constant Integer_Address := To_Integer (Storage); |
f38df0e1 | 781 | |
11f03980 | 782 | begin |
f8c79ade | 783 | -- The pool only returns addresses aligned on Storage_Alignment so |
f38df0e1 | 784 | -- anything off cannot be a valid block address and we can return |
e14c931f | 785 | -- early in this case. We actually have to since our data structures |
f38df0e1 VC |
786 | -- map validity bits for such aligned addresses only. |
787 | ||
f8c79ade | 788 | if Int_Storage mod Storage_Alignment /= 0 then |
11f03980 | 789 | return False; |
11f03980 | 790 | end if; |
f38df0e1 VC |
791 | |
792 | declare | |
793 | Block_Number : constant Integer_Address := | |
794 | Int_Storage / Memory_Chunk_Size; | |
795 | Ptr : constant Validity_Bits_Ref := | |
796 | Validy_Htable.Get (Block_Number); | |
797 | Offset : constant Integer_Address := | |
798 | (Int_Storage - | |
799 | (Block_Number * Memory_Chunk_Size)) / | |
f8c79ade | 800 | Storage_Alignment; |
f38df0e1 VC |
801 | Bit : constant Byte := |
802 | 2 ** Natural (Offset mod System.Storage_Unit); | |
803 | begin | |
804 | if Ptr = No_Validity_Bits then | |
805 | return False; | |
806 | else | |
be7e4a40 AC |
807 | if Valid then |
808 | return (Ptr.Valid (Offset / System.Storage_Unit) | |
809 | and Bit) /= 0; | |
810 | else | |
811 | if Ptr.Handled = No_Validity_Bits_Part then | |
812 | return False; | |
813 | else | |
814 | return (Ptr.Handled (Offset / System.Storage_Unit) | |
815 | and Bit) /= 0; | |
816 | end if; | |
817 | end if; | |
f38df0e1 VC |
818 | end if; |
819 | end; | |
be7e4a40 AC |
820 | end Is_Valid_Or_Handled; |
821 | ||
822 | -------------- | |
823 | -- Is_Valid -- | |
824 | -------------- | |
825 | ||
826 | function Is_Valid (Storage : System.Address) return Boolean is | |
827 | begin | |
828 | return Is_Valid_Or_Handled (Storage => Storage, Valid => True); | |
11f03980 VC |
829 | end Is_Valid; |
830 | ||
be7e4a40 AC |
831 | ----------------- |
832 | -- Is_Handled -- | |
833 | ----------------- | |
834 | ||
835 | function Is_Handled (Storage : System.Address) return Boolean is | |
836 | begin | |
837 | return Is_Valid_Or_Handled (Storage => Storage, Valid => False); | |
838 | end Is_Handled; | |
839 | ||
11f03980 VC |
840 | --------------- |
841 | -- Set_Valid -- | |
842 | --------------- | |
843 | ||
844 | procedure Set_Valid (Storage : System.Address; Value : Boolean) is | |
845 | Int_Storage : constant Integer_Address := To_Integer (Storage); | |
846 | Block_Number : constant Integer_Address := | |
847 | Int_Storage / Memory_Chunk_Size; | |
848 | Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); | |
849 | Offset : constant Integer_Address := | |
850 | (Int_Storage - (Block_Number * Memory_Chunk_Size)) / | |
f8c79ade | 851 | Storage_Alignment; |
11f03980 VC |
852 | Bit : constant Byte := |
853 | 2 ** Natural (Offset mod System.Storage_Unit); | |
2989065e | 854 | |
be7e4a40 AC |
855 | procedure Set_Handled; |
856 | pragma Inline (Set_Handled); | |
857 | -- if Allow_Unhandled_Memory set Handled bit in table. | |
858 | ||
859 | ----------------- | |
860 | -- Set_Handled -- | |
861 | ----------------- | |
862 | ||
863 | procedure Set_Handled is | |
864 | begin | |
865 | if Allow_Unhandled_Memory then | |
866 | if Ptr.Handled = No_Validity_Bits_Part then | |
867 | Ptr.Handled := | |
bc38dbb4 AC |
868 | To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); |
869 | Memset | |
870 | (A => Ptr.Handled.all'Address, | |
871 | C => 0, | |
872 | N => size_t (Max_Validity_Byte_Index)); | |
be7e4a40 | 873 | end if; |
bc38dbb4 | 874 | |
be7e4a40 | 875 | Ptr.Handled (Offset / System.Storage_Unit) := |
bc38dbb4 | 876 | Ptr.Handled (Offset / System.Storage_Unit) or Bit; |
be7e4a40 AC |
877 | end if; |
878 | end Set_Handled; | |
879 | ||
bc38dbb4 AC |
880 | -- Start of processing for Set_Valid |
881 | ||
11f03980 VC |
882 | begin |
883 | if Ptr = No_Validity_Bits then | |
fbf5a39b | 884 | |
11f03980 VC |
885 | -- First time in this memory area: allocate a new block and put |
886 | -- it in the table. | |
fbf5a39b | 887 | |
11f03980 | 888 | if Value then |
be7e4a40 | 889 | Ptr := new Validity_Bits; |
1d2d8a8f | 890 | Validity_Count := Validity_Count + 1; |
be7e4a40 | 891 | Ptr.Valid := |
bc38dbb4 | 892 | To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); |
11f03980 | 893 | Validy_Htable.Set (Block_Number, Ptr); |
bc38dbb4 AC |
894 | Memset |
895 | (A => Ptr.Valid.all'Address, | |
896 | C => 0, | |
897 | N => size_t (Max_Validity_Byte_Index)); | |
be7e4a40 AC |
898 | Ptr.Valid (Offset / System.Storage_Unit) := Bit; |
899 | Set_Handled; | |
11f03980 | 900 | end if; |
fbf5a39b | 901 | |
11f03980 VC |
902 | else |
903 | if Value then | |
be7e4a40 AC |
904 | Ptr.Valid (Offset / System.Storage_Unit) := |
905 | Ptr.Valid (Offset / System.Storage_Unit) or Bit; | |
906 | Set_Handled; | |
11f03980 | 907 | else |
be7e4a40 AC |
908 | Ptr.Valid (Offset / System.Storage_Unit) := |
909 | Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); | |
11f03980 VC |
910 | end if; |
911 | end if; | |
912 | end Set_Valid; | |
11f03980 | 913 | end Validity; |
38cbfe40 RK |
914 | |
915 | -------------- | |
916 | -- Allocate -- | |
917 | -------------- | |
918 | ||
919 | procedure Allocate | |
920 | (Pool : in out Debug_Pool; | |
921 | Storage_Address : out Address; | |
922 | Size_In_Storage_Elements : Storage_Count; | |
07fc65c4 GB |
923 | Alignment : Storage_Count) |
924 | is | |
fbf5a39b | 925 | pragma Unreferenced (Alignment); |
f8c79ade | 926 | -- Ignored, we always force Storage_Alignment |
fbf5a39b AC |
927 | |
928 | type Local_Storage_Array is new Storage_Array | |
f8c79ade | 929 | (1 .. Size_In_Storage_Elements + Extra_Allocation); |
fbf5a39b AC |
930 | |
931 | type Ptr is access Local_Storage_Array; | |
11f03980 VC |
932 | -- On some systems, we might want to physically protect pages against |
933 | -- writing when they have been freed (of course, this is expensive in | |
934 | -- terms of wasted memory). To do that, all we should have to do it to | |
935 | -- set the size of this array to the page size. See mprotect(). | |
fbf5a39b | 936 | |
fbf5a39b | 937 | Current : Byte_Count; |
75965852 | 938 | P : Ptr; |
fbf5a39b | 939 | Trace : Traceback_Htable_Elem_Ptr; |
07fc65c4 | 940 | |
aff557c7 | 941 | Reset_Disable_At_Exit : Boolean := False; |
be7e4a40 | 942 | |
dd89dddf AC |
943 | Lock : Scope_Lock; |
944 | pragma Unreferenced (Lock); | |
945 | ||
38cbfe40 | 946 | begin |
fbf5a39b | 947 | <<Allocate_Label>> |
38cbfe40 | 948 | |
be7e4a40 AC |
949 | if Disable then |
950 | Storage_Address := | |
951 | System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); | |
be7e4a40 AC |
952 | return; |
953 | end if; | |
954 | ||
aff557c7 | 955 | Reset_Disable_At_Exit := True; |
be7e4a40 AC |
956 | Disable := True; |
957 | ||
958 | Pool.Alloc_Count := Pool.Alloc_Count + 1; | |
959 | ||
fbf5a39b AC |
960 | -- If necessary, start physically releasing memory. The reason this is |
961 | -- done here, although Pool.Logically_Deallocated has not changed above, | |
11f03980 VC |
962 | -- is so that we do this only after a series of deallocations (e.g loop |
963 | -- that deallocates a big array). If we were doing that in Deallocate, | |
964 | -- we might be physically freeing memory several times during the loop, | |
965 | -- which is expensive. | |
38cbfe40 | 966 | |
fbf5a39b | 967 | if Pool.Logically_Deallocated > |
bc38dbb4 | 968 | Byte_Count (Pool.Maximum_Logically_Freed_Memory) |
fbf5a39b AC |
969 | then |
970 | Free_Physically (Pool); | |
971 | end if; | |
972 | ||
e14c931f | 973 | -- Use standard (i.e. through malloc) allocations. This automatically |
fbf5a39b AC |
974 | -- raises Storage_Error if needed. We also try once more to physically |
975 | -- release memory, so that even marked blocks, in the advanced scanning, | |
e187fa72 AC |
976 | -- are freed. Note that we do not initialize the storage array since it |
977 | -- is not necessary to do so (however this will cause bogus valgrind | |
978 | -- warnings, which should simply be ignored). | |
fbf5a39b AC |
979 | |
980 | begin | |
67336960 | 981 | P := new Local_Storage_Array; |
fbf5a39b AC |
982 | |
983 | exception | |
984 | when Storage_Error => | |
985 | Free_Physically (Pool); | |
67336960 | 986 | P := new Local_Storage_Array; |
fbf5a39b AC |
987 | end; |
988 | ||
f8c79ade AC |
989 | -- Compute Storage_Address, aimed at receiving user data. We need room |
990 | -- for the allocation header just ahead of the user data space plus | |
991 | -- alignment padding so Storage_Address is aligned on Storage_Alignment, | |
992 | -- like so: | |
993 | -- | |
994 | -- Storage_Address, aligned | |
995 | -- on Storage_Alignment | |
996 | -- v | |
997 | -- | ~~~~ | Header | User data ... | | |
998 | -- ^........^ | |
999 | -- Header_Offset | |
1000 | -- | |
1001 | -- Header_Offset is fixed so moving back and forth between user data | |
1002 | -- and allocation header is straightforward. The value is also such | |
1003 | -- that the header type alignment is honored when starting from | |
1004 | -- Default_alignment. | |
1005 | ||
1006 | -- For the purpose of computing Storage_Address, we just do as if the | |
1007 | -- header was located first, followed by the alignment padding: | |
1008 | ||
bc38dbb4 AC |
1009 | Storage_Address := |
1010 | To_Address (Align (To_Integer (P.all'Address) + | |
1011 | Integer_Address (Header_Offset))); | |
f38df0e1 VC |
1012 | -- Computation is done in Integer_Address, not Storage_Offset, because |
1013 | -- the range of Storage_Offset may not be large enough. | |
2989065e | 1014 | |
cc335f43 | 1015 | pragma Assert ((Storage_Address - System.Null_Address) |
f8c79ade | 1016 | mod Storage_Alignment = 0); |
cc335f43 AC |
1017 | pragma Assert (Storage_Address + Size_In_Storage_Elements |
1018 | <= P.all'Address + P'Length); | |
fbf5a39b | 1019 | |
bc38dbb4 AC |
1020 | Trace := |
1021 | Find_Or_Create_Traceback | |
1022 | (Pool => Pool, | |
1023 | Kind => Alloc, | |
1024 | Size => Size_In_Storage_Elements, | |
1025 | Ignored_Frame_Start => Allocate_Label'Address, | |
1026 | Ignored_Frame_End => Code_Address_For_Allocate_End); | |
fbf5a39b AC |
1027 | |
1028 | pragma Warnings (Off); | |
11f03980 VC |
1029 | -- Turn warning on alignment for convert call off. We know that in fact |
1030 | -- this conversion is safe since P itself is always aligned on | |
f8c79ade | 1031 | -- Storage_Alignment. |
fbf5a39b AC |
1032 | |
1033 | Header_Of (Storage_Address).all := | |
cc335f43 AC |
1034 | (Allocation_Address => P.all'Address, |
1035 | Alloc_Traceback => Trace, | |
1036 | Dealloc_Traceback => To_Traceback (null), | |
1037 | Next => Pool.First_Used_Block, | |
1038 | Block_Size => Size_In_Storage_Elements); | |
fbf5a39b AC |
1039 | |
1040 | pragma Warnings (On); | |
1041 | ||
1042 | -- Link this block in the list of used blocks. This will be used to list | |
1043 | -- memory leaks in Print_Info, and for the advanced schemes of | |
1044 | -- Physical_Free, where we want to traverse all allocated blocks and | |
1045 | -- search for possible references. | |
1046 | ||
1047 | -- We insert in front, since most likely we'll be freeing the most | |
1048 | -- recently allocated blocks first (the older one might stay allocated | |
1049 | -- for the whole life of the application). | |
1050 | ||
1051 | if Pool.First_Used_Block /= System.Null_Address then | |
1052 | Header_Of (Pool.First_Used_Block).Dealloc_Traceback := | |
1053 | To_Address (Storage_Address); | |
1054 | end if; | |
1055 | ||
1056 | Pool.First_Used_Block := Storage_Address; | |
1057 | ||
1058 | -- Mark the new address as valid | |
1059 | ||
1060 | Set_Valid (Storage_Address, True); | |
1061 | ||
f38df0e1 VC |
1062 | if Pool.Low_Level_Traces then |
1063 | Put (Output_File (Pool), | |
1064 | "info: Allocated" | |
c96c518f AC |
1065 | & Storage_Count'Image (Size_In_Storage_Elements) |
1066 | & " bytes at "); | |
1067 | Print_Address (Output_File (Pool), Storage_Address); | |
1068 | Put (Output_File (Pool), | |
1069 | " (physically:" | |
1070 | & Storage_Count'Image (Local_Storage_Array'Length) | |
1071 | & " bytes at "); | |
1072 | Print_Address (Output_File (Pool), P.all'Address); | |
1073 | Put (Output_File (Pool), | |
1074 | "), at "); | |
f38df0e1 VC |
1075 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, |
1076 | Allocate_Label'Address, | |
1077 | Code_Address_For_Deallocate_End); | |
1078 | end if; | |
1079 | ||
fbf5a39b AC |
1080 | -- Update internal data |
1081 | ||
1082 | Pool.Allocated := | |
1083 | Pool.Allocated + Byte_Count (Size_In_Storage_Elements); | |
1084 | ||
be7e4a40 | 1085 | Current := Pool.Current_Water_Mark; |
fbf5a39b AC |
1086 | |
1087 | if Current > Pool.High_Water then | |
1088 | Pool.High_Water := Current; | |
38cbfe40 | 1089 | end if; |
fbf5a39b | 1090 | |
aff557c7 | 1091 | Disable := False; |
be7e4a40 | 1092 | |
af4b9434 AC |
1093 | exception |
1094 | when others => | |
aff557c7 AC |
1095 | if Reset_Disable_At_Exit then |
1096 | Disable := False; | |
1097 | end if; | |
af4b9434 | 1098 | raise; |
38cbfe40 RK |
1099 | end Allocate; |
1100 | ||
fbf5a39b AC |
1101 | ------------------ |
1102 | -- Allocate_End -- | |
1103 | ------------------ | |
1104 | ||
11f03980 VC |
1105 | -- DO NOT MOVE, this must be right after Allocate. This is similar to what |
1106 | -- is done in a-except, so that we can hide the traceback frames internal | |
1107 | -- to this package | |
fbf5a39b AC |
1108 | |
1109 | procedure Allocate_End is | |
1110 | begin | |
1111 | <<Allocate_End_Label>> | |
1112 | Code_Address_For_Allocate_End := Allocate_End_Label'Address; | |
1113 | end Allocate_End; | |
1114 | ||
1115 | ------------------- | |
1116 | -- Set_Dead_Beef -- | |
1117 | ------------------- | |
1118 | ||
1119 | procedure Set_Dead_Beef | |
1120 | (Storage_Address : System.Address; | |
1121 | Size_In_Storage_Elements : Storage_Count) | |
1122 | is | |
1123 | Dead_Bytes : constant := 4; | |
1124 | ||
1125 | type Data is mod 2 ** (Dead_Bytes * 8); | |
1126 | for Data'Size use Dead_Bytes * 8; | |
1127 | ||
1128 | Dead : constant Data := 16#DEAD_BEEF#; | |
1129 | ||
1130 | type Dead_Memory is array | |
1131 | (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data; | |
1132 | type Mem_Ptr is access Dead_Memory; | |
1133 | ||
1134 | type Byte is mod 2 ** 8; | |
1135 | for Byte'Size use 8; | |
1136 | ||
1137 | type Dead_Memory_Bytes is array (0 .. 2) of Byte; | |
1138 | type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes; | |
1139 | ||
1140 | function From_Ptr is new Ada.Unchecked_Conversion | |
1141 | (System.Address, Mem_Ptr); | |
1142 | ||
1143 | function From_Ptr is new Ada.Unchecked_Conversion | |
1144 | (System.Address, Dead_Memory_Bytes_Ptr); | |
1145 | ||
1146 | M : constant Mem_Ptr := From_Ptr (Storage_Address); | |
1147 | M2 : Dead_Memory_Bytes_Ptr; | |
1148 | Modulo : constant Storage_Count := | |
1149 | Size_In_Storage_Elements mod Dead_Bytes; | |
1150 | begin | |
1151 | M.all := (others => Dead); | |
1152 | ||
1153 | -- Any bytes left (up to three of them) | |
1154 | ||
1155 | if Modulo /= 0 then | |
1156 | M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes); | |
1157 | ||
1158 | M2 (0) := 16#DE#; | |
1159 | if Modulo >= 2 then | |
1160 | M2 (1) := 16#AD#; | |
1161 | ||
1162 | if Modulo >= 3 then | |
1163 | M2 (2) := 16#BE#; | |
1164 | end if; | |
1165 | end if; | |
1166 | end if; | |
1167 | end Set_Dead_Beef; | |
1168 | ||
1169 | --------------------- | |
1170 | -- Free_Physically -- | |
1171 | --------------------- | |
1172 | ||
1173 | procedure Free_Physically (Pool : in out Debug_Pool) is | |
1174 | type Byte is mod 256; | |
1175 | type Byte_Access is access Byte; | |
1176 | ||
1177 | function To_Byte is new Ada.Unchecked_Conversion | |
1178 | (System.Address, Byte_Access); | |
1179 | ||
1180 | type Address_Access is access System.Address; | |
1181 | ||
1182 | function To_Address_Access is new Ada.Unchecked_Conversion | |
1183 | (System.Address, Address_Access); | |
1184 | ||
1185 | In_Use_Mark : constant Byte := 16#D#; | |
1186 | Free_Mark : constant Byte := 16#F#; | |
1187 | ||
1188 | Total_Freed : Storage_Count := 0; | |
1189 | ||
1190 | procedure Reset_Marks; | |
1191 | -- Unmark all the logically freed blocks, so that they are considered | |
1192 | -- for physical deallocation | |
1193 | ||
1194 | procedure Mark | |
1195 | (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean); | |
1196 | -- Mark the user data block starting at A. For a block of size zero, | |
1197 | -- nothing is done. For a block with a different size, the first byte | |
1198 | -- is set to either "D" (in use) or "F" (free). | |
1199 | ||
1200 | function Marked (A : System.Address) return Boolean; | |
1201 | -- Return true if the user data block starting at A might be in use | |
1202 | -- somewhere else | |
1203 | ||
1204 | procedure Mark_Blocks; | |
1205 | -- Traverse all allocated blocks, and search for possible references | |
1206 | -- to logically freed blocks. Mark them appropriately | |
1207 | ||
1208 | procedure Free_Blocks (Ignore_Marks : Boolean); | |
1209 | -- Physically release blocks. Only the blocks that haven't been marked | |
1210 | -- will be released, unless Ignore_Marks is true. | |
1211 | ||
1212 | ----------------- | |
1213 | -- Free_Blocks -- | |
1214 | ----------------- | |
1215 | ||
1216 | procedure Free_Blocks (Ignore_Marks : Boolean) is | |
1217 | Header : Allocation_Header_Access; | |
1218 | Tmp : System.Address := Pool.First_Free_Block; | |
1219 | Next : System.Address; | |
1220 | Previous : System.Address := System.Null_Address; | |
1221 | ||
1222 | begin | |
1223 | while Tmp /= System.Null_Address | |
1d2d8a8f AC |
1224 | and then |
1225 | not (Total_Freed > Pool.Minimum_To_Free | |
1226 | and Pool.Logically_Deallocated < | |
1227 | Byte_Count (Pool.Maximum_Logically_Freed_Memory)) | |
fbf5a39b AC |
1228 | loop |
1229 | Header := Header_Of (Tmp); | |
1230 | ||
1231 | -- If we know, or at least assume, the block is no longer | |
11f03980 | 1232 | -- referenced anywhere, we can free it physically. |
fbf5a39b AC |
1233 | |
1234 | if Ignore_Marks or else not Marked (Tmp) then | |
fbf5a39b AC |
1235 | declare |
1236 | pragma Suppress (All_Checks); | |
1237 | -- Suppress the checks on this section. If they are overflow | |
1238 | -- errors, it isn't critical, and we'd rather avoid a | |
1239 | -- Constraint_Error in that case. | |
1d2d8a8f | 1240 | |
fbf5a39b AC |
1241 | begin |
1242 | -- Note that block_size < zero for freed blocks | |
1243 | ||
1244 | Pool.Physically_Deallocated := | |
1245 | Pool.Physically_Deallocated - | |
1246 | Byte_Count (Header.Block_Size); | |
1247 | ||
1248 | Pool.Logically_Deallocated := | |
1249 | Pool.Logically_Deallocated + | |
1250 | Byte_Count (Header.Block_Size); | |
1251 | ||
1252 | Total_Freed := Total_Freed - Header.Block_Size; | |
1253 | end; | |
1254 | ||
1255 | Next := Header.Next; | |
f38df0e1 VC |
1256 | |
1257 | if Pool.Low_Level_Traces then | |
c96c518f | 1258 | Put |
f38df0e1 VC |
1259 | (Output_File (Pool), |
1260 | "info: Freeing physical memory " | |
c96c518f | 1261 | & Storage_Count'Image |
f8c79ade | 1262 | ((abs Header.Block_Size) + Extra_Allocation) |
c96c518f AC |
1263 | & " bytes at "); |
1264 | Print_Address (Output_File (Pool), | |
1265 | Header.Allocation_Address); | |
1266 | Put_Line (Output_File (Pool), ""); | |
f38df0e1 VC |
1267 | end if; |
1268 | ||
be7e4a40 AC |
1269 | if System_Memory_Debug_Pool_Enabled then |
1270 | System.CRTL.free (Header.Allocation_Address); | |
1271 | else | |
1272 | System.Memory.Free (Header.Allocation_Address); | |
1273 | end if; | |
1274 | ||
fbf5a39b AC |
1275 | Set_Valid (Tmp, False); |
1276 | ||
2989065e | 1277 | -- Remove this block from the list |
fbf5a39b AC |
1278 | |
1279 | if Previous = System.Null_Address then | |
1280 | Pool.First_Free_Block := Next; | |
1281 | else | |
1282 | Header_Of (Previous).Next := Next; | |
1283 | end if; | |
1284 | ||
1d2d8a8f | 1285 | Tmp := Next; |
fbf5a39b AC |
1286 | |
1287 | else | |
1288 | Previous := Tmp; | |
1289 | Tmp := Header.Next; | |
1290 | end if; | |
1291 | end loop; | |
1292 | end Free_Blocks; | |
1293 | ||
1294 | ---------- | |
1295 | -- Mark -- | |
1296 | ---------- | |
1297 | ||
1298 | procedure Mark | |
1299 | (H : Allocation_Header_Access; | |
1300 | A : System.Address; | |
1301 | In_Use : Boolean) | |
1302 | is | |
1303 | begin | |
1304 | if H.Block_Size /= 0 then | |
e64e5f74 | 1305 | To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); |
fbf5a39b AC |
1306 | end if; |
1307 | end Mark; | |
1308 | ||
1309 | ----------------- | |
1310 | -- Mark_Blocks -- | |
1311 | ----------------- | |
1312 | ||
1313 | procedure Mark_Blocks is | |
1314 | Tmp : System.Address := Pool.First_Used_Block; | |
1315 | Previous : System.Address; | |
1316 | Last : System.Address; | |
1317 | Pointed : System.Address; | |
1318 | Header : Allocation_Header_Access; | |
1319 | ||
1320 | begin | |
1321 | -- For each allocated block, check its contents. Things that look | |
1322 | -- like a possible address are used to mark the blocks so that we try | |
1323 | -- and keep them, for better detection in case of invalid access. | |
1324 | -- This mechanism is far from being fool-proof: it doesn't check the | |
1325 | -- stacks of the threads, doesn't check possible memory allocated not | |
1326 | -- under control of this debug pool. But it should allow us to catch | |
1327 | -- more cases. | |
1328 | ||
1329 | while Tmp /= System.Null_Address loop | |
1330 | Previous := Tmp; | |
1331 | Last := Tmp + Header_Of (Tmp).Block_Size; | |
1332 | while Previous < Last loop | |
1333 | -- ??? Should we move byte-per-byte, or consider that addresses | |
1334 | -- are always aligned on 4-bytes boundaries ? Let's use the | |
1335 | -- fastest for now. | |
1336 | ||
1337 | Pointed := To_Address_Access (Previous).all; | |
1338 | if Is_Valid (Pointed) then | |
1339 | Header := Header_Of (Pointed); | |
1340 | ||
1341 | -- Do not even attempt to mark blocks in use. That would | |
1342 | -- screw up the whole application, of course. | |
11f03980 | 1343 | |
fbf5a39b AC |
1344 | if Header.Block_Size < 0 then |
1345 | Mark (Header, Pointed, In_Use => True); | |
1346 | end if; | |
1347 | end if; | |
1348 | ||
1349 | Previous := Previous + System.Address'Size; | |
1350 | end loop; | |
1351 | ||
1352 | Tmp := Header_Of (Tmp).Next; | |
1353 | end loop; | |
1354 | end Mark_Blocks; | |
1355 | ||
1356 | ------------ | |
1357 | -- Marked -- | |
1358 | ------------ | |
1359 | ||
1360 | function Marked (A : System.Address) return Boolean is | |
1361 | begin | |
1362 | return To_Byte (A).all = In_Use_Mark; | |
1363 | end Marked; | |
1364 | ||
1365 | ----------------- | |
1366 | -- Reset_Marks -- | |
1367 | ----------------- | |
1368 | ||
1369 | procedure Reset_Marks is | |
1370 | Current : System.Address := Pool.First_Free_Block; | |
1371 | Header : Allocation_Header_Access; | |
c23c86bb | 1372 | |
fbf5a39b AC |
1373 | begin |
1374 | while Current /= System.Null_Address loop | |
1375 | Header := Header_Of (Current); | |
1376 | Mark (Header, Current, False); | |
1377 | Current := Header.Next; | |
1378 | end loop; | |
1379 | end Reset_Marks; | |
1380 | ||
dd89dddf AC |
1381 | Lock : Scope_Lock; |
1382 | pragma Unreferenced (Lock); | |
1383 | ||
c23c86bb | 1384 | -- Start of processing for Free_Physically |
fbf5a39b AC |
1385 | |
1386 | begin | |
fbf5a39b | 1387 | if Pool.Advanced_Scanning then |
11f03980 VC |
1388 | |
1389 | -- Reset the mark for each freed block | |
1390 | ||
1391 | Reset_Marks; | |
1392 | ||
fbf5a39b AC |
1393 | Mark_Blocks; |
1394 | end if; | |
1395 | ||
1396 | Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning); | |
1397 | ||
1398 | -- The contract is that we need to free at least Minimum_To_Free bytes, | |
c23c86bb | 1399 | -- even if this means freeing marked blocks in the advanced scheme. |
fbf5a39b AC |
1400 | |
1401 | if Total_Freed < Pool.Minimum_To_Free | |
1402 | and then Pool.Advanced_Scanning | |
1403 | then | |
1404 | Pool.Marked_Blocks_Deallocated := True; | |
1405 | Free_Blocks (Ignore_Marks => True); | |
1406 | end if; | |
fbf5a39b AC |
1407 | end Free_Physically; |
1408 | ||
be7e4a40 AC |
1409 | -------------- |
1410 | -- Get_Size -- | |
1411 | -------------- | |
1412 | ||
1413 | procedure Get_Size | |
1414 | (Storage_Address : Address; | |
1415 | Size_In_Storage_Elements : out Storage_Count; | |
c23c86bb AC |
1416 | Valid : out Boolean) |
1417 | is | |
dd89dddf AC |
1418 | Lock : Scope_Lock; |
1419 | pragma Unreferenced (Lock); | |
1420 | ||
be7e4a40 | 1421 | begin |
be7e4a40 | 1422 | Valid := Is_Valid (Storage_Address); |
a6b13d32 | 1423 | Size_In_Storage_Elements := Storage_Count'First; |
be7e4a40 AC |
1424 | |
1425 | if Is_Valid (Storage_Address) then | |
1426 | declare | |
c23c86bb AC |
1427 | Header : constant Allocation_Header_Access := |
1428 | Header_Of (Storage_Address); | |
1429 | ||
be7e4a40 AC |
1430 | begin |
1431 | if Header.Block_Size >= 0 then | |
1432 | Valid := True; | |
1433 | Size_In_Storage_Elements := Header.Block_Size; | |
1434 | else | |
1435 | Valid := False; | |
1436 | end if; | |
1437 | end; | |
1438 | else | |
1439 | Valid := False; | |
1440 | end if; | |
be7e4a40 AC |
1441 | end Get_Size; |
1442 | ||
c96c518f AC |
1443 | --------------------- |
1444 | -- Print_Traceback -- | |
1445 | --------------------- | |
1446 | ||
1447 | procedure Print_Traceback | |
1448 | (Output_File : File_Type; | |
1449 | Prefix : String; | |
c23c86bb AC |
1450 | Traceback : Traceback_Htable_Elem_Ptr) |
1451 | is | |
c96c518f AC |
1452 | begin |
1453 | if Traceback /= null then | |
1454 | Put (Output_File, Prefix); | |
1455 | Put_Line (Output_File, 0, Traceback.Traceback); | |
1456 | end if; | |
1457 | end Print_Traceback; | |
1458 | ||
38cbfe40 RK |
1459 | ---------------- |
1460 | -- Deallocate -- | |
1461 | ---------------- | |
1462 | ||
1463 | procedure Deallocate | |
1464 | (Pool : in out Debug_Pool; | |
1465 | Storage_Address : Address; | |
1466 | Size_In_Storage_Elements : Storage_Count; | |
1467 | Alignment : Storage_Count) | |
1468 | is | |
fbf5a39b AC |
1469 | pragma Unreferenced (Alignment); |
1470 | ||
1471 | Header : constant Allocation_Header_Access := | |
c23c86bb | 1472 | Header_Of (Storage_Address); |
fbf5a39b | 1473 | Previous : System.Address; |
c23c86bb AC |
1474 | Valid : Boolean; |
1475 | ||
dd89dddf | 1476 | Header_Block_Size_Was_Less_Than_0 : Boolean := True; |
fbf5a39b AC |
1477 | |
1478 | begin | |
1479 | <<Deallocate_Label>> | |
dd89dddf AC |
1480 | |
1481 | declare | |
1482 | Lock : Scope_Lock; | |
1483 | pragma Unreferenced (Lock); | |
c23c86bb | 1484 | |
dd89dddf AC |
1485 | begin |
1486 | Valid := Is_Valid (Storage_Address); | |
1487 | ||
1488 | if Valid and then not (Header.Block_Size < 0) then | |
1489 | Header_Block_Size_Was_Less_Than_0 := False; | |
1490 | ||
1491 | -- Some sort of codegen problem or heap corruption caused the | |
c23c86bb AC |
1492 | -- Size_In_Storage_Elements to be wrongly computed. The code |
1493 | -- below is all based on the assumption that Header.all is not | |
1494 | -- corrupted, such that the error is non-fatal. | |
dd89dddf AC |
1495 | |
1496 | if Header.Block_Size /= Size_In_Storage_Elements and then | |
1497 | Size_In_Storage_Elements /= Storage_Count'Last | |
1498 | then | |
1499 | Put_Line (Output_File (Pool), | |
1500 | "error: Deallocate size " | |
1501 | & Storage_Count'Image (Size_In_Storage_Elements) | |
1502 | & " does not match allocate size " | |
1503 | & Storage_Count'Image (Header.Block_Size)); | |
1504 | end if; | |
1505 | ||
1506 | if Pool.Low_Level_Traces then | |
1507 | Put (Output_File (Pool), | |
1508 | "info: Deallocated" | |
1509 | & Storage_Count'Image (Header.Block_Size) | |
1510 | & " bytes at "); | |
1511 | Print_Address (Output_File (Pool), Storage_Address); | |
1512 | Put (Output_File (Pool), | |
1513 | " (physically" | |
1514 | & Storage_Count'Image | |
1515 | (Header.Block_Size + Extra_Allocation) | |
1516 | & " bytes at "); | |
1517 | Print_Address (Output_File (Pool), Header.Allocation_Address); | |
1518 | Put (Output_File (Pool), "), at "); | |
1519 | ||
1520 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, | |
1521 | Deallocate_Label'Address, | |
1522 | Code_Address_For_Deallocate_End); | |
1523 | Print_Traceback (Output_File (Pool), | |
1524 | " Memory was allocated at ", | |
1525 | Header.Alloc_Traceback); | |
1526 | end if; | |
1527 | ||
1528 | -- Remove this block from the list of used blocks | |
1529 | ||
1530 | Previous := | |
1531 | To_Address (Header.Dealloc_Traceback); | |
1532 | ||
1533 | if Previous = System.Null_Address then | |
1534 | Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; | |
1535 | ||
1536 | if Pool.First_Used_Block /= System.Null_Address then | |
1537 | Header_Of (Pool.First_Used_Block).Dealloc_Traceback := | |
1538 | To_Traceback (null); | |
1539 | end if; | |
1540 | ||
1541 | else | |
1542 | Header_Of (Previous).Next := Header.Next; | |
1543 | ||
1544 | if Header.Next /= System.Null_Address then | |
1545 | Header_Of | |
1546 | (Header.Next).Dealloc_Traceback := To_Address (Previous); | |
1547 | end if; | |
1548 | end if; | |
1549 | ||
1550 | -- Update the Alloc_Traceback Frees/Total_Frees members | |
1551 | -- (if present) | |
1552 | ||
1553 | if Header.Alloc_Traceback /= null then | |
1554 | Header.Alloc_Traceback.Frees := | |
1555 | Header.Alloc_Traceback.Frees + 1; | |
1556 | Header.Alloc_Traceback.Total_Frees := | |
1557 | Header.Alloc_Traceback.Total_Frees + | |
1558 | Byte_Count (Header.Block_Size); | |
1559 | end if; | |
1560 | ||
1561 | Pool.Free_Count := Pool.Free_Count + 1; | |
1562 | ||
1563 | -- Update the header | |
1564 | ||
1565 | Header.all := | |
1566 | (Allocation_Address => Header.Allocation_Address, | |
1567 | Alloc_Traceback => Header.Alloc_Traceback, | |
1568 | Dealloc_Traceback => To_Traceback | |
1569 | (Find_Or_Create_Traceback | |
1570 | (Pool, Dealloc, | |
1571 | Header.Block_Size, | |
1572 | Deallocate_Label'Address, | |
1573 | Code_Address_For_Deallocate_End)), | |
1574 | Next => System.Null_Address, | |
1575 | Block_Size => -Header.Block_Size); | |
1576 | ||
1577 | if Pool.Reset_Content_On_Free then | |
1578 | Set_Dead_Beef (Storage_Address, -Header.Block_Size); | |
1579 | end if; | |
1580 | ||
1581 | Pool.Logically_Deallocated := | |
1582 | Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); | |
1583 | ||
1584 | -- Link this free block with the others (at the end of the list, | |
1585 | -- so that we can start releasing the older blocks first later on) | |
1586 | ||
1587 | if Pool.First_Free_Block = System.Null_Address then | |
1588 | Pool.First_Free_Block := Storage_Address; | |
1589 | Pool.Last_Free_Block := Storage_Address; | |
1590 | ||
1591 | else | |
1592 | Header_Of (Pool.Last_Free_Block).Next := Storage_Address; | |
1593 | Pool.Last_Free_Block := Storage_Address; | |
1594 | end if; | |
1595 | ||
1596 | -- Do not physically release the memory here, but in Alloc. | |
1597 | -- See comment there for details. | |
1598 | end if; | |
dd89dddf | 1599 | end; |
fbf5a39b AC |
1600 | |
1601 | if not Valid then | |
be7e4a40 AC |
1602 | if Storage_Address = System.Null_Address then |
1603 | if Pool.Raise_Exceptions and then | |
1604 | Size_In_Storage_Elements /= Storage_Count'Last | |
1605 | then | |
1606 | raise Freeing_Not_Allocated_Storage; | |
1607 | else | |
1608 | Put (Output_File (Pool), | |
1609 | "error: Freeing Null_Address, at "); | |
1610 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, | |
1611 | Deallocate_Label'Address, | |
1612 | Code_Address_For_Deallocate_End); | |
1613 | return; | |
1614 | end if; | |
1615 | end if; | |
1616 | ||
c23c86bb AC |
1617 | if Allow_Unhandled_Memory |
1618 | and then not Is_Handled (Storage_Address) | |
be7e4a40 AC |
1619 | then |
1620 | System.CRTL.free (Storage_Address); | |
1621 | return; | |
1622 | end if; | |
1623 | ||
c23c86bb AC |
1624 | if Pool.Raise_Exceptions |
1625 | and then Size_In_Storage_Elements /= Storage_Count'Last | |
be7e4a40 | 1626 | then |
fbf5a39b AC |
1627 | raise Freeing_Not_Allocated_Storage; |
1628 | else | |
f38df0e1 VC |
1629 | Put (Output_File (Pool), |
1630 | "error: Freeing not allocated storage, at "); | |
1631 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, | |
fbf5a39b AC |
1632 | Deallocate_Label'Address, |
1633 | Code_Address_For_Deallocate_End); | |
1634 | end if; | |
07fc65c4 | 1635 | |
dd89dddf | 1636 | elsif Header_Block_Size_Was_Less_Than_0 then |
fbf5a39b AC |
1637 | if Pool.Raise_Exceptions then |
1638 | raise Freeing_Deallocated_Storage; | |
1639 | else | |
f38df0e1 VC |
1640 | Put (Output_File (Pool), |
1641 | "error: Freeing already deallocated storage, at "); | |
1642 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, | |
fbf5a39b AC |
1643 | Deallocate_Label'Address, |
1644 | Code_Address_For_Deallocate_End); | |
c96c518f AC |
1645 | Print_Traceback (Output_File (Pool), |
1646 | " Memory already deallocated at ", | |
1647 | To_Traceback (Header.Dealloc_Traceback)); | |
1648 | Print_Traceback (Output_File (Pool), " Memory was allocated at ", | |
1649 | Header.Alloc_Traceback); | |
fbf5a39b | 1650 | end if; |
fbf5a39b | 1651 | end if; |
38cbfe40 RK |
1652 | end Deallocate; |
1653 | ||
fbf5a39b AC |
1654 | -------------------- |
1655 | -- Deallocate_End -- | |
1656 | -------------------- | |
1657 | ||
1658 | -- DO NOT MOVE, this must be right after Deallocate | |
11f03980 | 1659 | |
fbf5a39b AC |
1660 | -- See Allocate_End |
1661 | ||
11f03980 VC |
1662 | -- This is making assumptions about code order that may be invalid ??? |
1663 | ||
fbf5a39b AC |
1664 | procedure Deallocate_End is |
1665 | begin | |
1666 | <<Deallocate_End_Label>> | |
1667 | Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; | |
1668 | end Deallocate_End; | |
1669 | ||
38cbfe40 RK |
1670 | ----------------- |
1671 | -- Dereference -- | |
1672 | ----------------- | |
1673 | ||
1674 | procedure Dereference | |
1675 | (Pool : in out Debug_Pool; | |
1676 | Storage_Address : Address; | |
1677 | Size_In_Storage_Elements : Storage_Count; | |
1678 | Alignment : Storage_Count) | |
1679 | is | |
fbf5a39b | 1680 | pragma Unreferenced (Alignment, Size_In_Storage_Elements); |
07fc65c4 | 1681 | |
fbf5a39b AC |
1682 | Valid : constant Boolean := Is_Valid (Storage_Address); |
1683 | Header : Allocation_Header_Access; | |
38cbfe40 RK |
1684 | |
1685 | begin | |
fbf5a39b AC |
1686 | -- Locking policy: we do not do any locking in this procedure. The |
1687 | -- tables are only read, not written to, and although a problem might | |
1688 | -- appear if someone else is modifying the tables at the same time, this | |
1689 | -- race condition is not intended to be detected by this storage_pool (a | |
1690 | -- now invalid pointer would appear as valid). Instead, we prefer | |
1691 | -- optimum performance for dereferences. | |
38cbfe40 | 1692 | |
fbf5a39b | 1693 | <<Dereference_Label>> |
38cbfe40 | 1694 | |
fbf5a39b AC |
1695 | if not Valid then |
1696 | if Pool.Raise_Exceptions then | |
38cbfe40 | 1697 | raise Accessing_Not_Allocated_Storage; |
fbf5a39b | 1698 | else |
f38df0e1 VC |
1699 | Put (Output_File (Pool), |
1700 | "error: Accessing not allocated storage, at "); | |
1701 | Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, | |
fbf5a39b AC |
1702 | Dereference_Label'Address, |
1703 | Code_Address_For_Dereference_End); | |
1704 | end if; | |
38cbfe40 | 1705 | |
fbf5a39b AC |
1706 | else |
1707 | Header := Header_Of (Storage_Address); | |
38cbfe40 | 1708 | |
fbf5a39b AC |
1709 | if Header.Block_Size < 0 then |
1710 | if Pool.Raise_Exceptions then | |
1711 | raise Accessing_Deallocated_Storage; | |
1712 | else | |
f38df0e1 VC |
1713 | Put (Output_File (Pool), |
1714 | "error: Accessing deallocated storage, at "); | |
fbf5a39b | 1715 | Put_Line |
f38df0e1 | 1716 | (Output_File (Pool), Pool.Stack_Trace_Depth, null, |
fbf5a39b AC |
1717 | Dereference_Label'Address, |
1718 | Code_Address_For_Dereference_End); | |
c96c518f AC |
1719 | Print_Traceback (Output_File (Pool), " First deallocation at ", |
1720 | To_Traceback (Header.Dealloc_Traceback)); | |
1721 | Print_Traceback (Output_File (Pool), " Initial allocation at ", | |
1722 | Header.Alloc_Traceback); | |
fbf5a39b AC |
1723 | end if; |
1724 | end if; | |
1725 | end if; | |
38cbfe40 RK |
1726 | end Dereference; |
1727 | ||
fbf5a39b AC |
1728 | --------------------- |
1729 | -- Dereference_End -- | |
1730 | --------------------- | |
1731 | ||
1732 | -- DO NOT MOVE: this must be right after Dereference | |
11f03980 | 1733 | |
fbf5a39b | 1734 | -- See Allocate_End |
38cbfe40 | 1735 | |
11f03980 VC |
1736 | -- This is making assumptions about code order that may be invalid ??? |
1737 | ||
fbf5a39b | 1738 | procedure Dereference_End is |
38cbfe40 | 1739 | begin |
fbf5a39b AC |
1740 | <<Dereference_End_Label>> |
1741 | Code_Address_For_Dereference_End := Dereference_End_Label'Address; | |
1742 | end Dereference_End; | |
38cbfe40 RK |
1743 | |
1744 | ---------------- | |
1745 | -- Print_Info -- | |
1746 | ---------------- | |
1747 | ||
fbf5a39b AC |
1748 | procedure Print_Info |
1749 | (Pool : Debug_Pool; | |
1750 | Cumulate : Boolean := False; | |
1751 | Display_Slots : Boolean := False; | |
1752 | Display_Leaks : Boolean := False) | |
1753 | is | |
fbf5a39b AC |
1754 | package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable |
1755 | (Header_Num => Header, | |
1756 | Element => Traceback_Htable_Elem, | |
1757 | Elmt_Ptr => Traceback_Htable_Elem_Ptr, | |
1758 | Null_Ptr => null, | |
1759 | Set_Next => Set_Next, | |
1760 | Next => Next, | |
1761 | Key => Tracebacks_Array_Access, | |
1762 | Get_Key => Get_Key, | |
1763 | Hash => Hash, | |
1764 | Equal => Equal); | |
1765 | -- This needs a comment ??? probably some of the ones below do too??? | |
1766 | ||
c23c86bb | 1767 | Current : System.Address; |
fbf5a39b AC |
1768 | Data : Traceback_Htable_Elem_Ptr; |
1769 | Elem : Traceback_Htable_Elem_Ptr; | |
fbf5a39b AC |
1770 | Header : Allocation_Header_Access; |
1771 | K : Traceback_Kind; | |
1772 | ||
38cbfe40 | 1773 | begin |
fbf5a39b AC |
1774 | Put_Line |
1775 | ("Total allocated bytes : " & | |
1776 | Byte_Count'Image (Pool.Allocated)); | |
38cbfe40 | 1777 | |
fbf5a39b AC |
1778 | Put_Line |
1779 | ("Total logically deallocated bytes : " & | |
1780 | Byte_Count'Image (Pool.Logically_Deallocated)); | |
38cbfe40 | 1781 | |
fbf5a39b AC |
1782 | Put_Line |
1783 | ("Total physically deallocated bytes : " & | |
1784 | Byte_Count'Image (Pool.Physically_Deallocated)); | |
1785 | ||
1786 | if Pool.Marked_Blocks_Deallocated then | |
1787 | Put_Line ("Marked blocks were physically deallocated. This is"); | |
ad6b5b00 | 1788 | Put_Line ("potentially dangerous, and you might want to run"); |
fbf5a39b AC |
1789 | Put_Line ("again with a lower value of Minimum_To_Free"); |
1790 | end if; | |
1791 | ||
1792 | Put_Line | |
1793 | ("Current Water Mark: " & | |
be7e4a40 | 1794 | Byte_Count'Image (Pool.Current_Water_Mark)); |
fbf5a39b AC |
1795 | |
1796 | Put_Line | |
1797 | ("High Water Mark: " & | |
1798 | Byte_Count'Image (Pool.High_Water)); | |
38cbfe40 | 1799 | |
38cbfe40 | 1800 | Put_Line (""); |
fbf5a39b | 1801 | |
af4b9434 AC |
1802 | if Display_Slots then |
1803 | Data := Backtrace_Htable.Get_First; | |
1804 | while Data /= null loop | |
1805 | if Data.Kind in Alloc .. Dealloc then | |
1806 | Elem := | |
1807 | new Traceback_Htable_Elem' | |
c23c86bb AC |
1808 | (Traceback => new Tracebacks_Array'(Data.Traceback.all), |
1809 | Count => Data.Count, | |
1810 | Kind => Data.Kind, | |
1811 | Total => Data.Total, | |
1812 | Frees => Data.Frees, | |
1813 | Total_Frees => Data.Total_Frees, | |
1814 | Next => null); | |
af4b9434 AC |
1815 | Backtrace_Htable_Cumulate.Set (Elem); |
1816 | ||
1817 | if Cumulate then | |
e64e5f74 AC |
1818 | K := (if Data.Kind = Alloc then Indirect_Alloc |
1819 | else Indirect_Dealloc); | |
fbf5a39b | 1820 | |
af4b9434 | 1821 | -- Propagate the direct call to all its parents |
fbf5a39b | 1822 | |
af4b9434 AC |
1823 | for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop |
1824 | Elem := Backtrace_Htable_Cumulate.Get | |
1825 | (Data.Traceback | |
1826 | (T .. Data.Traceback'Last)'Unrestricted_Access); | |
fbf5a39b | 1827 | |
af4b9434 | 1828 | -- If not, insert it |
fbf5a39b | 1829 | |
af4b9434 | 1830 | if Elem = null then |
c23c86bb AC |
1831 | Elem := |
1832 | new Traceback_Htable_Elem' | |
1833 | (Traceback => | |
1834 | new Tracebacks_Array' | |
1835 | (Data.Traceback | |
1836 | (T .. Data.Traceback'Last)), | |
1837 | Count => Data.Count, | |
1838 | Kind => K, | |
1839 | Total => Data.Total, | |
1840 | Frees => Data.Frees, | |
1841 | Total_Frees => Data.Total_Frees, | |
1842 | Next => null); | |
af4b9434 | 1843 | Backtrace_Htable_Cumulate.Set (Elem); |
fbf5a39b | 1844 | |
af4b9434 AC |
1845 | -- Properly take into account that the subprograms |
1846 | -- indirectly called might be doing either allocations | |
1847 | -- or deallocations. This needs to be reflected in the | |
1848 | -- counts. | |
fbf5a39b | 1849 | |
af4b9434 AC |
1850 | else |
1851 | Elem.Count := Elem.Count + Data.Count; | |
fbf5a39b | 1852 | |
af4b9434 AC |
1853 | if K = Elem.Kind then |
1854 | Elem.Total := Elem.Total + Data.Total; | |
fbf5a39b | 1855 | |
af4b9434 AC |
1856 | elsif Elem.Total > Data.Total then |
1857 | Elem.Total := Elem.Total - Data.Total; | |
fbf5a39b | 1858 | |
af4b9434 AC |
1859 | else |
1860 | Elem.Kind := K; | |
1861 | Elem.Total := Data.Total - Elem.Total; | |
1862 | end if; | |
fbf5a39b | 1863 | end if; |
af4b9434 AC |
1864 | end loop; |
1865 | end if; | |
fbf5a39b | 1866 | |
af4b9434 AC |
1867 | Data := Backtrace_Htable.Get_Next; |
1868 | end if; | |
1869 | end loop; | |
fbf5a39b | 1870 | |
fbf5a39b AC |
1871 | Put_Line ("List of allocations/deallocations: "); |
1872 | ||
1873 | Data := Backtrace_Htable_Cumulate.Get_First; | |
1874 | while Data /= null loop | |
1875 | case Data.Kind is | |
1876 | when Alloc => Put ("alloc (count:"); | |
1877 | when Indirect_Alloc => Put ("indirect alloc (count:"); | |
1878 | when Dealloc => Put ("free (count:"); | |
1879 | when Indirect_Dealloc => Put ("indirect free (count:"); | |
1880 | end case; | |
1881 | ||
1882 | Put (Natural'Image (Data.Count) & ", total:" & | |
1883 | Byte_Count'Image (Data.Total) & ") "); | |
1884 | ||
1885 | for T in Data.Traceback'Range loop | |
bc38dbb4 | 1886 | Put (Image_C (PC_For (Data.Traceback (T))) & ' '); |
fbf5a39b AC |
1887 | end loop; |
1888 | ||
1889 | Put_Line (""); | |
1890 | ||
1891 | Data := Backtrace_Htable_Cumulate.Get_Next; | |
1892 | end loop; | |
af4b9434 AC |
1893 | |
1894 | Backtrace_Htable_Cumulate.Reset; | |
fbf5a39b AC |
1895 | end if; |
1896 | ||
1897 | if Display_Leaks then | |
1898 | Put_Line (""); | |
1899 | Put_Line ("List of not deallocated blocks:"); | |
1900 | ||
1901 | -- Do not try to group the blocks with the same stack traces | |
1902 | -- together. This is done by the gnatmem output. | |
1903 | ||
1904 | Current := Pool.First_Used_Block; | |
1905 | while Current /= System.Null_Address loop | |
1906 | Header := Header_Of (Current); | |
1907 | ||
1908 | Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: "); | |
1909 | ||
c96c518f AC |
1910 | if Header.Alloc_Traceback /= null then |
1911 | for T in Header.Alloc_Traceback.Traceback'Range loop | |
bc38dbb4 | 1912 | Put (Image_C |
c96c518f AC |
1913 | (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); |
1914 | end loop; | |
1915 | end if; | |
fbf5a39b AC |
1916 | |
1917 | Put_Line (""); | |
1918 | Current := Header.Next; | |
1919 | end loop; | |
1920 | end if; | |
38cbfe40 RK |
1921 | end Print_Info; |
1922 | ||
be7e4a40 AC |
1923 | ---------- |
1924 | -- Dump -- | |
1925 | ---------- | |
1926 | ||
1927 | procedure Dump | |
1928 | (Pool : Debug_Pool; | |
1929 | Size : Positive; | |
c23c86bb AC |
1930 | Report : Report_Type := All_Reports) |
1931 | is | |
be7e4a40 AC |
1932 | procedure Do_Report (Sort : Report_Type); |
1933 | -- Do a specific type of report | |
1934 | ||
c23c86bb AC |
1935 | --------------- |
1936 | -- Do_Report -- | |
1937 | --------------- | |
1938 | ||
be7e4a40 AC |
1939 | procedure Do_Report (Sort : Report_Type) is |
1940 | Elem : Traceback_Htable_Elem_Ptr; | |
1941 | Bigger : Boolean; | |
1942 | Grand_Total : Float; | |
1943 | ||
1944 | Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := | |
1945 | (others => null); | |
1946 | -- Sorted array for the biggest memory users | |
1947 | ||
dd89dddf AC |
1948 | Allocated_In_Pool : Byte_Count; |
1949 | -- safe thread Pool.Allocated | |
1950 | ||
1951 | Elem_Safe : Traceback_Htable_Elem; | |
1952 | -- safe thread current elem.all; | |
1953 | ||
1954 | Max_M_Safe : Traceback_Htable_Elem; | |
1955 | -- safe thread Max(M).all | |
1956 | ||
be7e4a40 | 1957 | begin |
d4b56371 | 1958 | Put_Line (""); |
d8f43ee6 | 1959 | |
be7e4a40 | 1960 | case Sort is |
d8f43ee6 HK |
1961 | when All_Reports |
1962 | | Memory_Usage | |
1963 | => | |
be7e4a40 AC |
1964 | Put_Line (Size'Img & " biggest memory users at this time:"); |
1965 | Put_Line ("Results include bytes and chunks still allocated"); | |
1966 | Grand_Total := Float (Pool.Current_Water_Mark); | |
d8f43ee6 | 1967 | |
be7e4a40 AC |
1968 | when Allocations_Count => |
1969 | Put_Line (Size'Img & " biggest number of live allocations:"); | |
1970 | Put_Line ("Results include bytes and chunks still allocated"); | |
1971 | Grand_Total := Float (Pool.Current_Water_Mark); | |
d8f43ee6 | 1972 | |
be7e4a40 AC |
1973 | when Sort_Total_Allocs => |
1974 | Put_Line (Size'Img & " biggest number of allocations:"); | |
1975 | Put_Line ("Results include total bytes and chunks allocated,"); | |
1976 | Put_Line ("even if no longer allocated - Deallocations are" | |
1977 | & " ignored"); | |
dd89dddf AC |
1978 | |
1979 | declare | |
1980 | Lock : Scope_Lock; | |
1981 | pragma Unreferenced (Lock); | |
1982 | begin | |
1983 | Allocated_In_Pool := Pool.Allocated; | |
1984 | end; | |
1985 | ||
1986 | Grand_Total := Float (Allocated_In_Pool); | |
d8f43ee6 | 1987 | |
be7e4a40 AC |
1988 | when Marked_Blocks => |
1989 | Put_Line ("Special blocks marked by Mark_Traceback"); | |
1990 | Grand_Total := 0.0; | |
1991 | end case; | |
1992 | ||
dd89dddf AC |
1993 | declare |
1994 | Lock : Scope_Lock; | |
1995 | pragma Unreferenced (Lock); | |
1996 | begin | |
1997 | Elem := Backtrace_Htable.Get_First; | |
1998 | end; | |
1999 | ||
be7e4a40 | 2000 | while Elem /= null loop |
dd89dddf AC |
2001 | declare |
2002 | Lock : Scope_Lock; | |
2003 | pragma Unreferenced (Lock); | |
2004 | begin | |
2005 | Elem_Safe := Elem.all; | |
2006 | end; | |
2007 | ||
be7e4a40 | 2008 | -- Handle only alloc elememts |
dd89dddf | 2009 | if Elem_Safe.Kind = Alloc then |
be7e4a40 | 2010 | -- Ignore small blocks (depending on the sorting criteria) to |
5f0a92e5 | 2011 | -- gain speed. |
be7e4a40 AC |
2012 | |
2013 | if (Sort = Memory_Usage | |
c23c86bb | 2014 | and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) |
be7e4a40 | 2015 | or else (Sort = Allocations_Count |
c23c86bb | 2016 | and then Elem_Safe.Count - Elem_Safe.Frees >= 1) |
dd89dddf | 2017 | or else (Sort = Sort_Total_Allocs |
c23c86bb | 2018 | and then Elem_Safe.Count > 1) |
be7e4a40 | 2019 | or else (Sort = Marked_Blocks |
c23c86bb | 2020 | and then Elem_Safe.Total = 0) |
be7e4a40 AC |
2021 | then |
2022 | if Sort = Marked_Blocks then | |
dd89dddf | 2023 | Grand_Total := Grand_Total + Float (Elem_Safe.Count); |
be7e4a40 AC |
2024 | end if; |
2025 | ||
2026 | for M in Max'Range loop | |
2027 | Bigger := Max (M) = null; | |
2028 | if not Bigger then | |
dd89dddf AC |
2029 | declare |
2030 | Lock : Scope_Lock; | |
2031 | pragma Unreferenced (Lock); | |
2032 | begin | |
2033 | Max_M_Safe := Max (M).all; | |
2034 | end; | |
2035 | ||
be7e4a40 | 2036 | case Sort is |
d8f43ee6 HK |
2037 | when All_Reports |
2038 | | Memory_Usage | |
2039 | => | |
2040 | Bigger := | |
dd89dddf AC |
2041 | Max_M_Safe.Total - Max_M_Safe.Total_Frees |
2042 | < Elem_Safe.Total - Elem_Safe.Total_Frees; | |
d8f43ee6 HK |
2043 | |
2044 | when Allocations_Count => | |
2045 | Bigger := | |
dd89dddf AC |
2046 | Max_M_Safe.Count - Max_M_Safe.Frees |
2047 | < Elem_Safe.Count - Elem_Safe.Frees; | |
d8f43ee6 HK |
2048 | |
2049 | when Marked_Blocks | |
2050 | | Sort_Total_Allocs | |
2051 | => | |
dd89dddf | 2052 | Bigger := Max_M_Safe.Count < Elem_Safe.Count; |
be7e4a40 AC |
2053 | end case; |
2054 | end if; | |
2055 | ||
2056 | if Bigger then | |
2057 | Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); | |
2058 | Max (M) := Elem; | |
2059 | exit; | |
2060 | end if; | |
2061 | end loop; | |
2062 | end if; | |
2063 | end if; | |
2064 | ||
dd89dddf AC |
2065 | declare |
2066 | Lock : Scope_Lock; | |
2067 | pragma Unreferenced (Lock); | |
2068 | begin | |
2069 | Elem := Backtrace_Htable.Get_Next; | |
2070 | end; | |
be7e4a40 AC |
2071 | end loop; |
2072 | ||
2073 | if Grand_Total = 0.0 then | |
2074 | Grand_Total := 1.0; | |
2075 | end if; | |
2076 | ||
2077 | for M in Max'Range loop | |
2078 | exit when Max (M) = null; | |
2079 | declare | |
2080 | type Percent is delta 0.1 range 0.0 .. 100.0; | |
c23c86bb AC |
2081 | |
2082 | P : Percent; | |
be7e4a40 | 2083 | Total : Byte_Count; |
dd89dddf | 2084 | |
c23c86bb | 2085 | begin |
dd89dddf AC |
2086 | declare |
2087 | Lock : Scope_Lock; | |
2088 | pragma Unreferenced (Lock); | |
2089 | begin | |
2090 | Max_M_Safe := Max (M).all; | |
2091 | end; | |
2092 | ||
be7e4a40 | 2093 | case Sort is |
d8f43ee6 HK |
2094 | when All_Reports |
2095 | | Allocations_Count | |
2096 | | Memory_Usage | |
2097 | => | |
dd89dddf | 2098 | Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; |
d8f43ee6 | 2099 | |
be7e4a40 | 2100 | when Sort_Total_Allocs => |
dd89dddf | 2101 | Total := Max_M_Safe.Total; |
d8f43ee6 | 2102 | |
be7e4a40 | 2103 | when Marked_Blocks => |
dd89dddf | 2104 | Total := Byte_Count (Max_M_Safe.Count); |
be7e4a40 AC |
2105 | end case; |
2106 | ||
dd89dddf AC |
2107 | declare |
2108 | Normalized_Total : constant Float := Float (Total); | |
2109 | -- In multi tasking configuration, memory deallocations | |
2110 | -- during Do_Report processing can lead to Total > | |
2111 | -- Grand_Total. As Percent requires Total <= Grand_Total | |
c23c86bb | 2112 | |
dd89dddf AC |
2113 | begin |
2114 | if Normalized_Total > Grand_Total then | |
2115 | P := 100.0; | |
2116 | else | |
2117 | P := Percent (100.0 * Normalized_Total / Grand_Total); | |
2118 | end if; | |
2119 | end; | |
be7e4a40 | 2120 | |
13230c68 | 2121 | case Sort is |
c23c86bb AC |
2122 | when All_Reports |
2123 | | Allocations_Count | |
2124 | | Memory_Usage | |
2125 | => | |
13230c68 AC |
2126 | declare |
2127 | Count : constant Natural := | |
dd89dddf | 2128 | Max_M_Safe.Count - Max_M_Safe.Frees; |
13230c68 AC |
2129 | begin |
2130 | Put (P'Img & "%:" & Total'Img & " bytes in" | |
2131 | & Count'Img & " chunks at"); | |
2132 | end; | |
c23c86bb | 2133 | |
13230c68 AC |
2134 | when Sort_Total_Allocs => |
2135 | Put (P'Img & "%:" & Total'Img & " bytes in" | |
dd89dddf | 2136 | & Max_M_Safe.Count'Img & " chunks at"); |
c23c86bb | 2137 | |
13230c68 AC |
2138 | when Marked_Blocks => |
2139 | Put (P'Img & "%:" | |
dd89dddf | 2140 | & Max_M_Safe.Count'Img & " chunks /" |
13230c68 AC |
2141 | & Integer (Grand_Total)'Img & " at"); |
2142 | end case; | |
be7e4a40 AC |
2143 | end; |
2144 | ||
2145 | for J in Max (M).Traceback'Range loop | |
d4b56371 | 2146 | Put (" " & Image_C (PC_For (Max (M).Traceback (J)))); |
be7e4a40 AC |
2147 | end loop; |
2148 | ||
d4b56371 | 2149 | Put_Line (""); |
be7e4a40 AC |
2150 | end loop; |
2151 | end Do_Report; | |
2152 | ||
dd89dddf AC |
2153 | -- Local variables |
2154 | ||
2155 | Total_Freed : Byte_Count; | |
2156 | -- safe thread pool logically & physically deallocated | |
2157 | ||
2158 | Traceback_Elements_Allocated : Byte_Count; | |
2159 | -- safe thread Traceback_Count | |
2160 | ||
2161 | Validity_Elements_Allocated : Byte_Count; | |
2162 | -- safe thread Validity_Count | |
2163 | ||
2164 | Ada_Allocs_Bytes : Byte_Count; | |
2165 | -- safe thread pool Allocated | |
2166 | ||
2167 | Ada_Allocs_Chunks : Byte_Count; | |
2168 | -- safe thread pool Alloc_Count | |
2169 | ||
2170 | Ada_Free_Chunks : Byte_Count; | |
2171 | -- safe thread pool Free_Count | |
2172 | ||
2173 | -- Start of processing for Dump | |
2174 | ||
be7e4a40 | 2175 | begin |
dd89dddf AC |
2176 | declare |
2177 | Lock : Scope_Lock; | |
2178 | pragma Unreferenced (Lock); | |
2179 | begin | |
2180 | Total_Freed := | |
2181 | Pool.Logically_Deallocated + Pool.Physically_Deallocated; | |
2182 | Traceback_Elements_Allocated := Traceback_Count; | |
2183 | Validity_Elements_Allocated := Validity_Count; | |
2184 | Ada_Allocs_Bytes := Pool.Allocated; | |
2185 | Ada_Allocs_Chunks := Pool.Alloc_Count; | |
2186 | Ada_Free_Chunks := Pool.Free_Count; | |
2187 | end; | |
2188 | ||
2189 | Put_Line | |
2190 | ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); | |
2191 | Put_Line | |
2192 | ("Validity elements allocated: " & Validity_Elements_Allocated'Img); | |
1d2d8a8f | 2193 | Put_Line (""); |
be7e4a40 | 2194 | |
dd89dddf AC |
2195 | Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img |
2196 | & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); | |
be7e4a40 | 2197 | Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & |
dd89dddf | 2198 | Ada_Free_Chunks'Img |
be7e4a40 AC |
2199 | & " chunks"); |
2200 | Put_Line ("Ada Current watermark: " | |
2201 | & Byte_Count'Image (Pool.Current_Water_Mark) | |
dd89dddf AC |
2202 | & " in" & Byte_Count'Image (Ada_Allocs_Chunks - |
2203 | Ada_Free_Chunks) & " chunks"); | |
be7e4a40 AC |
2204 | Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); |
2205 | ||
2206 | case Report is | |
2207 | when All_Reports => | |
2208 | for Sort in Report_Type loop | |
2209 | if Sort /= All_Reports then | |
2210 | Do_Report (Sort); | |
2211 | end if; | |
2212 | end loop; | |
2213 | ||
2214 | when others => | |
2215 | Do_Report (Report); | |
2216 | end case; | |
be7e4a40 AC |
2217 | end Dump; |
2218 | ||
2219 | ----------------- | |
2220 | -- Dump_Stdout -- | |
2221 | ----------------- | |
2222 | ||
2223 | procedure Dump_Stdout | |
2224 | (Pool : Debug_Pool; | |
2225 | Size : Positive; | |
2226 | Report : Report_Type := All_Reports) | |
2227 | is | |
be7e4a40 AC |
2228 | procedure Internal is new Dump |
2229 | (Put_Line => Stdout_Put_Line, | |
2230 | Put => Stdout_Put); | |
2231 | ||
2232 | -- Start of processing for Dump_Stdout | |
2233 | ||
2234 | begin | |
2235 | Internal (Pool, Size, Report); | |
2236 | end Dump_Stdout; | |
2237 | ||
2238 | ----------- | |
2239 | -- Reset -- | |
2240 | ----------- | |
2241 | ||
2242 | procedure Reset is | |
2243 | Elem : Traceback_Htable_Elem_Ptr; | |
dd89dddf AC |
2244 | Lock : Scope_Lock; |
2245 | pragma Unreferenced (Lock); | |
be7e4a40 AC |
2246 | begin |
2247 | Elem := Backtrace_Htable.Get_First; | |
2248 | while Elem /= null loop | |
2249 | Elem.Count := 0; | |
2250 | Elem.Frees := 0; | |
2251 | Elem.Total := 0; | |
2252 | Elem.Total_Frees := 0; | |
2253 | Elem := Backtrace_Htable.Get_Next; | |
2254 | end loop; | |
2255 | end Reset; | |
2256 | ||
38cbfe40 RK |
2257 | ------------------ |
2258 | -- Storage_Size -- | |
2259 | ------------------ | |
2260 | ||
2261 | function Storage_Size (Pool : Debug_Pool) return Storage_Count is | |
fbf5a39b | 2262 | pragma Unreferenced (Pool); |
38cbfe40 RK |
2263 | begin |
2264 | return Storage_Count'Last; | |
2265 | end Storage_Size; | |
2266 | ||
be7e4a40 AC |
2267 | --------------------- |
2268 | -- High_Water_Mark -- | |
2269 | --------------------- | |
2270 | ||
c23c86bb | 2271 | function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is |
dd89dddf AC |
2272 | Lock : Scope_Lock; |
2273 | pragma Unreferenced (Lock); | |
be7e4a40 AC |
2274 | begin |
2275 | return Pool.High_Water; | |
2276 | end High_Water_Mark; | |
2277 | ||
2278 | ------------------------ | |
2279 | -- Current_Water_Mark -- | |
2280 | ------------------------ | |
2281 | ||
c23c86bb | 2282 | function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is |
dd89dddf AC |
2283 | Lock : Scope_Lock; |
2284 | pragma Unreferenced (Lock); | |
be7e4a40 AC |
2285 | begin |
2286 | return Pool.Allocated - Pool.Logically_Deallocated - | |
2287 | Pool.Physically_Deallocated; | |
2288 | end Current_Water_Mark; | |
2289 | ||
2290 | ------------------------------ | |
2291 | -- System_Memory_Debug_Pool -- | |
2292 | ------------------------------ | |
2293 | ||
2294 | procedure System_Memory_Debug_Pool | |
c23c86bb AC |
2295 | (Has_Unhandled_Memory : Boolean := True) |
2296 | is | |
dd89dddf AC |
2297 | Lock : Scope_Lock; |
2298 | pragma Unreferenced (Lock); | |
be7e4a40 AC |
2299 | begin |
2300 | System_Memory_Debug_Pool_Enabled := True; | |
2301 | Allow_Unhandled_Memory := Has_Unhandled_Memory; | |
2302 | end System_Memory_Debug_Pool; | |
2303 | ||
fbf5a39b AC |
2304 | --------------- |
2305 | -- Configure -- | |
2306 | --------------- | |
2307 | ||
2308 | procedure Configure | |
2309 | (Pool : in out Debug_Pool; | |
2310 | Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; | |
2311 | Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; | |
2312 | Minimum_To_Free : SSC := Default_Min_Freed; | |
2313 | Reset_Content_On_Free : Boolean := Default_Reset_Content; | |
2314 | Raise_Exceptions : Boolean := Default_Raise_Exceptions; | |
f38df0e1 VC |
2315 | Advanced_Scanning : Boolean := Default_Advanced_Scanning; |
2316 | Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; | |
2317 | Low_Level_Traces : Boolean := Default_Low_Level_Traces) | |
fbf5a39b | 2318 | is |
dd89dddf AC |
2319 | Lock : Scope_Lock; |
2320 | pragma Unreferenced (Lock); | |
fbf5a39b AC |
2321 | begin |
2322 | Pool.Stack_Trace_Depth := Stack_Trace_Depth; | |
2323 | Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory; | |
2324 | Pool.Reset_Content_On_Free := Reset_Content_On_Free; | |
2325 | Pool.Raise_Exceptions := Raise_Exceptions; | |
2326 | Pool.Minimum_To_Free := Minimum_To_Free; | |
2327 | Pool.Advanced_Scanning := Advanced_Scanning; | |
f38df0e1 VC |
2328 | Pool.Errors_To_Stdout := Errors_To_Stdout; |
2329 | Pool.Low_Level_Traces := Low_Level_Traces; | |
fbf5a39b AC |
2330 | end Configure; |
2331 | ||
2332 | ---------------- | |
2333 | -- Print_Pool -- | |
2334 | ---------------- | |
2335 | ||
2336 | procedure Print_Pool (A : System.Address) is | |
2337 | Storage : constant Address := A; | |
2338 | Valid : constant Boolean := Is_Valid (Storage); | |
2339 | Header : Allocation_Header_Access; | |
2340 | ||
2341 | begin | |
c23c86bb AC |
2342 | -- We might get Null_Address if the call from gdb was done incorrectly. |
2343 | -- For instance, doing a "print_pool(my_var)" passes 0x0, instead of | |
2344 | -- passing the value of my_var. | |
fbf5a39b AC |
2345 | |
2346 | if A = System.Null_Address then | |
f38df0e1 VC |
2347 | Put_Line |
2348 | (Standard_Output, "Memory not under control of the storage pool"); | |
fbf5a39b AC |
2349 | return; |
2350 | end if; | |
2351 | ||
2352 | if not Valid then | |
f38df0e1 VC |
2353 | Put_Line |
2354 | (Standard_Output, "Memory not under control of the storage pool"); | |
fbf5a39b AC |
2355 | |
2356 | else | |
2357 | Header := Header_Of (Storage); | |
c96c518f AC |
2358 | Print_Address (Standard_Output, A); |
2359 | Put_Line (Standard_Output, " allocated at:"); | |
2360 | Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); | |
fbf5a39b AC |
2361 | |
2362 | if To_Traceback (Header.Dealloc_Traceback) /= null then | |
c96c518f AC |
2363 | Print_Address (Standard_Output, A); |
2364 | Put_Line (Standard_Output, | |
2365 | " logically freed memory, deallocated at:"); | |
2366 | Print_Traceback (Standard_Output, "", | |
2367 | To_Traceback (Header.Dealloc_Traceback)); | |
fbf5a39b AC |
2368 | end if; |
2369 | end if; | |
2370 | end Print_Pool; | |
2371 | ||
2372 | ----------------------- | |
2373 | -- Print_Info_Stdout -- | |
2374 | ----------------------- | |
2375 | ||
2376 | procedure Print_Info_Stdout | |
2377 | (Pool : Debug_Pool; | |
2378 | Cumulate : Boolean := False; | |
2379 | Display_Slots : Boolean := False; | |
2380 | Display_Leaks : Boolean := False) | |
2381 | is | |
2382 | procedure Internal is new Print_Info | |
f38df0e1 VC |
2383 | (Put_Line => Stdout_Put_Line, |
2384 | Put => Stdout_Put); | |
2385 | ||
f38df0e1 VC |
2386 | -- Start of processing for Print_Info_Stdout |
2387 | ||
fbf5a39b AC |
2388 | begin |
2389 | Internal (Pool, Cumulate, Display_Slots, Display_Leaks); | |
2390 | end Print_Info_Stdout; | |
2391 | ||
2392 | ------------------ | |
2393 | -- Dump_Gnatmem -- | |
2394 | ------------------ | |
2395 | ||
2396 | procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is | |
2397 | type File_Ptr is new System.Address; | |
2398 | ||
2399 | function fopen (Path : String; Mode : String) return File_Ptr; | |
2400 | pragma Import (C, fopen); | |
2401 | ||
2402 | procedure fwrite | |
2403 | (Ptr : System.Address; | |
2404 | Size : size_t; | |
2405 | Nmemb : size_t; | |
2406 | Stream : File_Ptr); | |
2407 | ||
2408 | procedure fwrite | |
2409 | (Str : String; | |
2410 | Size : size_t; | |
2411 | Nmemb : size_t; | |
2412 | Stream : File_Ptr); | |
2413 | pragma Import (C, fwrite); | |
2414 | ||
2415 | procedure fputc (C : Integer; Stream : File_Ptr); | |
2416 | pragma Import (C, fputc); | |
2417 | ||
2418 | procedure fclose (Stream : File_Ptr); | |
2419 | pragma Import (C, fclose); | |
2420 | ||
2421 | Address_Size : constant size_t := | |
2422 | System.Address'Max_Size_In_Storage_Elements; | |
2423 | -- Size in bytes of a pointer | |
2424 | ||
2425 | File : File_Ptr; | |
2426 | Current : System.Address; | |
2427 | Header : Allocation_Header_Access; | |
2428 | Actual_Size : size_t; | |
2429 | Num_Calls : Integer; | |
2430 | Tracebk : Tracebacks_Array_Access; | |
f91c36dc | 2431 | Dummy_Time : Duration := 1.0; |
fbf5a39b AC |
2432 | |
2433 | begin | |
2434 | File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); | |
2435 | fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); | |
3b2249aa HK |
2436 | |
2437 | fwrite | |
2438 | (Ptr => Dummy_Time'Address, | |
2439 | Size => Duration'Max_Size_In_Storage_Elements, | |
2440 | Nmemb => 1, | |
2441 | Stream => File); | |
fbf5a39b AC |
2442 | |
2443 | -- List of not deallocated blocks (see Print_Info) | |
2444 | ||
2445 | Current := Pool.First_Used_Block; | |
2446 | while Current /= System.Null_Address loop | |
2447 | Header := Header_Of (Current); | |
2448 | ||
2449 | Actual_Size := size_t (Header.Block_Size); | |
fbf5a39b | 2450 | |
c96c518f | 2451 | if Header.Alloc_Traceback /= null then |
3b2249aa | 2452 | Tracebk := Header.Alloc_Traceback.Traceback; |
c96c518f | 2453 | Num_Calls := Tracebk'Length; |
2989065e | 2454 | |
c96c518f | 2455 | -- (Code taken from memtrack.adb in GNAT's sources) |
2989065e | 2456 | |
c96c518f | 2457 | -- Logs allocation call using the format: |
fbf5a39b | 2458 | |
c96c518f | 2459 | -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> |
fbf5a39b | 2460 | |
c96c518f AC |
2461 | fputc (Character'Pos ('A'), File); |
2462 | fwrite (Current'Address, Address_Size, 1, File); | |
3b2249aa HK |
2463 | |
2464 | fwrite | |
2465 | (Ptr => Actual_Size'Address, | |
2466 | Size => size_t'Max_Size_In_Storage_Elements, | |
2467 | Nmemb => 1, | |
2468 | Stream => File); | |
2469 | ||
2470 | fwrite | |
2471 | (Ptr => Dummy_Time'Address, | |
2472 | Size => Duration'Max_Size_In_Storage_Elements, | |
2473 | Nmemb => 1, | |
2474 | Stream => File); | |
2475 | ||
2476 | fwrite | |
2477 | (Ptr => Num_Calls'Address, | |
2478 | Size => Integer'Max_Size_In_Storage_Elements, | |
2479 | Nmemb => 1, | |
2480 | Stream => File); | |
c96c518f AC |
2481 | |
2482 | for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop | |
2483 | declare | |
2484 | Ptr : System.Address := PC_For (Tracebk (J)); | |
2485 | begin | |
2486 | fwrite (Ptr'Address, Address_Size, 1, File); | |
2487 | end; | |
2488 | end loop; | |
c96c518f | 2489 | end if; |
fbf5a39b AC |
2490 | |
2491 | Current := Header.Next; | |
2492 | end loop; | |
2493 | ||
2494 | fclose (File); | |
2495 | end Dump_Gnatmem; | |
2496 | ||
be7e4a40 AC |
2497 | ---------------- |
2498 | -- Stdout_Put -- | |
2499 | ---------------- | |
2500 | ||
2501 | procedure Stdout_Put (S : String) is | |
2502 | begin | |
2503 | Put (Standard_Output, S); | |
2504 | end Stdout_Put; | |
2505 | ||
2506 | --------------------- | |
2507 | -- Stdout_Put_Line -- | |
2508 | --------------------- | |
2509 | ||
2510 | procedure Stdout_Put_Line (S : String) is | |
2511 | begin | |
2512 | Put_Line (Standard_Output, S); | |
2513 | end Stdout_Put_Line; | |
2514 | ||
11f03980 VC |
2515 | -- Package initialization |
2516 | ||
fbf5a39b AC |
2517 | begin |
2518 | Allocate_End; | |
2519 | Deallocate_End; | |
2520 | Dereference_End; | |
38cbfe40 | 2521 | end GNAT.Debug_Pools; |