|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . M E M O R Y --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 -- This version contains allocation tracking capability
|
|
|
33
|
|
|
34 -- The object file corresponding to this instrumented version is to be found
|
|
|
35 -- in libgmem.
|
|
|
36
|
|
|
37 -- When enabled, the subsystem logs all the calls to __gnat_malloc and
|
|
|
38 -- __gnat_free. This log can then be processed by gnatmem to detect
|
|
|
39 -- dynamic memory leaks.
|
|
|
40
|
|
|
41 -- To use this functionality, you must compile your application with -g
|
|
|
42 -- and then link with this object file:
|
|
|
43
|
|
|
44 -- gnatmake -g program -largs -lgmem
|
|
|
45
|
|
|
46 -- After compilation, you may use your program as usual except that upon
|
|
|
47 -- completion, it will generate in the current directory the file gmem.out.
|
|
|
48
|
|
|
49 -- You can then investigate for possible memory leaks and mismatch by calling
|
|
|
50 -- gnatmem with this file as an input:
|
|
|
51
|
|
|
52 -- gnatmem -i gmem.out program
|
|
|
53
|
|
|
54 -- See gnatmem section in the GNAT User's Guide for more details
|
|
|
55
|
|
|
56 -- NOTE: This capability is currently supported on the following targets:
|
|
|
57
|
|
|
58 -- Windows
|
|
|
59 -- AIX
|
|
|
60 -- GNU/Linux
|
|
|
61 -- HP-UX
|
|
|
62 -- Solaris
|
|
|
63
|
|
|
64 -- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is
|
|
|
65 -- 64 bit. If the need arises to support architectures where this assumption
|
|
|
66 -- is incorrect, it will require changing the way timestamps of allocation
|
|
|
67 -- events are recorded.
|
|
|
68
|
|
|
69 pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
|
|
|
70
|
|
|
71 with Ada.Exceptions;
|
|
|
72 with System.Soft_Links;
|
|
|
73 with System.Traceback;
|
|
|
74 with System.Traceback_Entries;
|
|
|
75 with GNAT.IO;
|
|
|
76 with System.OS_Primitives;
|
|
|
77
|
|
|
78 package body System.Memory is
|
|
|
79
|
|
|
80 use Ada.Exceptions;
|
|
|
81 use System.Soft_Links;
|
|
|
82 use System.Traceback;
|
|
|
83 use System.Traceback_Entries;
|
|
|
84 use GNAT.IO;
|
|
|
85
|
|
|
86 function c_malloc (Size : size_t) return System.Address;
|
|
|
87 pragma Import (C, c_malloc, "malloc");
|
|
|
88
|
|
|
89 procedure c_free (Ptr : System.Address);
|
|
|
90 pragma Import (C, c_free, "free");
|
|
|
91
|
|
|
92 function c_realloc
|
|
|
93 (Ptr : System.Address; Size : size_t) return System.Address;
|
|
|
94 pragma Import (C, c_realloc, "realloc");
|
|
|
95
|
|
|
96 subtype File_Ptr is System.Address;
|
|
|
97
|
|
|
98 function fopen (Path : String; Mode : String) return File_Ptr;
|
|
|
99 pragma Import (C, fopen);
|
|
|
100
|
|
|
101 procedure OS_Exit (Status : Integer);
|
|
|
102 pragma Import (C, OS_Exit, "__gnat_os_exit");
|
|
|
103 pragma No_Return (OS_Exit);
|
|
|
104
|
|
|
105 procedure fwrite
|
|
|
106 (Ptr : System.Address;
|
|
|
107 Size : size_t;
|
|
|
108 Nmemb : size_t;
|
|
|
109 Stream : File_Ptr);
|
|
|
110
|
|
|
111 procedure fwrite
|
|
|
112 (Str : String;
|
|
|
113 Size : size_t;
|
|
|
114 Nmemb : size_t;
|
|
|
115 Stream : File_Ptr);
|
|
|
116 pragma Import (C, fwrite);
|
|
|
117
|
|
|
118 procedure fputc (C : Integer; Stream : File_Ptr);
|
|
|
119 pragma Import (C, fputc);
|
|
|
120
|
|
|
121 procedure fclose (Stream : File_Ptr);
|
|
|
122 pragma Import (C, fclose);
|
|
|
123
|
|
|
124 procedure Finalize;
|
|
|
125 pragma Export (C, Finalize, "__gnat_finalize");
|
|
|
126 -- Replace the default __gnat_finalize to properly close the log file
|
|
|
127
|
|
|
128 Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
|
|
|
129 -- Size in bytes of a pointer
|
|
|
130
|
|
|
131 Max_Call_Stack : constant := 200;
|
|
|
132 -- Maximum number of frames supported
|
|
|
133
|
|
|
134 Tracebk : Tracebacks_Array (1 .. Max_Call_Stack);
|
|
|
135 Num_Calls : aliased Integer := 0;
|
|
|
136
|
|
|
137 Gmemfname : constant String := "gmem.out" & ASCII.NUL;
|
|
|
138 -- Allocation log of a program is saved in a file gmem.out
|
|
|
139 -- ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
|
|
|
140 -- gmem.out
|
|
|
141
|
|
|
142 Gmemfile : File_Ptr;
|
|
|
143 -- Global C file pointer to the allocation log
|
|
|
144
|
|
|
145 Needs_Init : Boolean := True;
|
|
|
146 -- Reset after first call to Gmem_Initialize
|
|
|
147
|
|
|
148 procedure Gmem_Initialize;
|
|
|
149 -- Initialization routine; opens the file and writes a header string. This
|
|
|
150 -- header string is used as a magic-tag to know if the .out file is to be
|
|
|
151 -- handled by GDB or by the GMEM (instrumented malloc/free) implementation.
|
|
|
152
|
|
|
153 First_Call : Boolean := True;
|
|
|
154 -- Depending on implementation, some of the traceback routines may
|
|
|
155 -- themselves do dynamic allocation. We use First_Call flag to avoid
|
|
|
156 -- infinite recursion
|
|
|
157
|
|
|
158 -----------
|
|
|
159 -- Alloc --
|
|
|
160 -----------
|
|
|
161
|
|
|
162 function Alloc (Size : size_t) return System.Address is
|
|
|
163 Result : aliased System.Address;
|
|
|
164 Actual_Size : aliased size_t := Size;
|
|
|
165 Timestamp : aliased Duration;
|
|
|
166
|
|
|
167 begin
|
|
|
168 if Size = size_t'Last then
|
|
|
169 Raise_Exception (Storage_Error'Identity, "object too large");
|
|
|
170 end if;
|
|
|
171
|
|
|
172 -- Change size from zero to non-zero. We still want a proper pointer
|
|
|
173 -- for the zero case because pointers to zero length objects have to
|
|
|
174 -- be distinct, but we can't just go ahead and allocate zero bytes,
|
|
|
175 -- since some malloc's return zero for a zero argument.
|
|
|
176
|
|
|
177 if Size = 0 then
|
|
|
178 Actual_Size := 1;
|
|
|
179 end if;
|
|
|
180
|
|
|
181 Lock_Task.all;
|
|
|
182
|
|
|
183 Result := c_malloc (Actual_Size);
|
|
|
184
|
|
|
185 if First_Call then
|
|
|
186
|
|
|
187 -- Logs allocation call
|
|
|
188 -- format is:
|
|
|
189 -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
|
|
|
190
|
|
|
191 First_Call := False;
|
|
|
192
|
|
|
193 if Needs_Init then
|
|
|
194 Gmem_Initialize;
|
|
|
195 end if;
|
|
|
196
|
|
|
197 Timestamp := System.OS_Primitives.Clock;
|
|
|
198 Call_Chain
|
|
|
199 (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2);
|
|
|
200 fputc (Character'Pos ('A'), Gmemfile);
|
|
|
201 fwrite (Result'Address, Address_Size, 1, Gmemfile);
|
|
|
202 fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
|
|
|
203 Gmemfile);
|
|
|
204 fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
|
|
|
205 Gmemfile);
|
|
|
206 fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
|
|
|
207 Gmemfile);
|
|
|
208
|
|
|
209 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
|
|
|
210 declare
|
|
|
211 Ptr : System.Address := PC_For (Tracebk (J));
|
|
|
212 begin
|
|
|
213 fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
|
|
|
214 end;
|
|
|
215 end loop;
|
|
|
216
|
|
|
217 First_Call := True;
|
|
|
218
|
|
|
219 end if;
|
|
|
220
|
|
|
221 Unlock_Task.all;
|
|
|
222
|
|
|
223 if Result = System.Null_Address then
|
|
|
224 Raise_Exception (Storage_Error'Identity, "heap exhausted");
|
|
|
225 end if;
|
|
|
226
|
|
|
227 return Result;
|
|
|
228 end Alloc;
|
|
|
229
|
|
|
230 --------------
|
|
|
231 -- Finalize --
|
|
|
232 --------------
|
|
|
233
|
|
|
234 procedure Finalize is
|
|
|
235 begin
|
|
|
236 if not Needs_Init then
|
|
|
237 fclose (Gmemfile);
|
|
|
238 end if;
|
|
|
239 end Finalize;
|
|
|
240
|
|
|
241 ----------
|
|
|
242 -- Free --
|
|
|
243 ----------
|
|
|
244
|
|
|
245 procedure Free (Ptr : System.Address) is
|
|
|
246 Addr : aliased constant System.Address := Ptr;
|
|
|
247 Timestamp : aliased Duration;
|
|
|
248
|
|
|
249 begin
|
|
|
250 Lock_Task.all;
|
|
|
251
|
|
|
252 if First_Call then
|
|
|
253
|
|
|
254 -- Logs deallocation call
|
|
|
255 -- format is:
|
|
|
256 -- 'D' <mem addr> <len backtrace> <addr1> ... <addrn>
|
|
|
257
|
|
|
258 First_Call := False;
|
|
|
259
|
|
|
260 if Needs_Init then
|
|
|
261 Gmem_Initialize;
|
|
|
262 end if;
|
|
|
263
|
|
|
264 Call_Chain
|
|
|
265 (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2);
|
|
|
266 Timestamp := System.OS_Primitives.Clock;
|
|
|
267 fputc (Character'Pos ('D'), Gmemfile);
|
|
|
268 fwrite (Addr'Address, Address_Size, 1, Gmemfile);
|
|
|
269 fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
|
|
|
270 Gmemfile);
|
|
|
271 fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
|
|
|
272 Gmemfile);
|
|
|
273
|
|
|
274 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
|
|
|
275 declare
|
|
|
276 Ptr : System.Address := PC_For (Tracebk (J));
|
|
|
277 begin
|
|
|
278 fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
|
|
|
279 end;
|
|
|
280 end loop;
|
|
|
281
|
|
|
282 c_free (Ptr);
|
|
|
283
|
|
|
284 First_Call := True;
|
|
|
285 end if;
|
|
|
286
|
|
|
287 Unlock_Task.all;
|
|
|
288 end Free;
|
|
|
289
|
|
|
290 ---------------------
|
|
|
291 -- Gmem_Initialize --
|
|
|
292 ---------------------
|
|
|
293
|
|
|
294 procedure Gmem_Initialize is
|
|
|
295 Timestamp : aliased Duration;
|
|
|
296
|
|
|
297 begin
|
|
|
298 if Needs_Init then
|
|
|
299 Needs_Init := False;
|
|
|
300 System.OS_Primitives.Initialize;
|
|
|
301 Timestamp := System.OS_Primitives.Clock;
|
|
|
302 Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
|
|
|
303
|
|
|
304 if Gmemfile = System.Null_Address then
|
|
|
305 Put_Line ("Couldn't open gnatmem log file for writing");
|
|
|
306 OS_Exit (255);
|
|
|
307 end if;
|
|
|
308
|
|
|
309 fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
|
|
|
310 fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
|
|
|
311 Gmemfile);
|
|
|
312 end if;
|
|
|
313 end Gmem_Initialize;
|
|
|
314
|
|
|
315 -------------
|
|
|
316 -- Realloc --
|
|
|
317 -------------
|
|
|
318
|
|
|
319 function Realloc
|
|
|
320 (Ptr : System.Address;
|
|
|
321 Size : size_t) return System.Address
|
|
|
322 is
|
|
|
323 Addr : aliased constant System.Address := Ptr;
|
|
|
324 Result : aliased System.Address;
|
|
|
325 Timestamp : aliased Duration;
|
|
|
326
|
|
|
327 begin
|
|
|
328 -- For the purposes of allocations logging, we treat realloc as a free
|
|
|
329 -- followed by malloc. This is not exactly accurate, but is a good way
|
|
|
330 -- to fit it into malloc/free-centered reports.
|
|
|
331
|
|
|
332 if Size = size_t'Last then
|
|
|
333 Raise_Exception (Storage_Error'Identity, "object too large");
|
|
|
334 end if;
|
|
|
335
|
|
|
336 Abort_Defer.all;
|
|
|
337 Lock_Task.all;
|
|
|
338
|
|
|
339 if First_Call then
|
|
|
340 First_Call := False;
|
|
|
341
|
|
|
342 -- We first log deallocation call
|
|
|
343
|
|
|
344 if Needs_Init then
|
|
|
345 Gmem_Initialize;
|
|
|
346 end if;
|
|
|
347 Call_Chain
|
|
|
348 (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2);
|
|
|
349 Timestamp := System.OS_Primitives.Clock;
|
|
|
350 fputc (Character'Pos ('D'), Gmemfile);
|
|
|
351 fwrite (Addr'Address, Address_Size, 1, Gmemfile);
|
|
|
352 fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
|
|
|
353 Gmemfile);
|
|
|
354 fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
|
|
|
355 Gmemfile);
|
|
|
356
|
|
|
357 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
|
|
|
358 declare
|
|
|
359 Ptr : System.Address := PC_For (Tracebk (J));
|
|
|
360 begin
|
|
|
361 fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
|
|
|
362 end;
|
|
|
363 end loop;
|
|
|
364
|
|
|
365 -- Now perform actual realloc
|
|
|
366
|
|
|
367 Result := c_realloc (Ptr, Size);
|
|
|
368
|
|
|
369 -- Log allocation call using the same backtrace
|
|
|
370
|
|
|
371 fputc (Character'Pos ('A'), Gmemfile);
|
|
|
372 fwrite (Result'Address, Address_Size, 1, Gmemfile);
|
|
|
373 fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
|
|
|
374 Gmemfile);
|
|
|
375 fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
|
|
|
376 Gmemfile);
|
|
|
377 fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
|
|
|
378 Gmemfile);
|
|
|
379
|
|
|
380 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
|
|
|
381 declare
|
|
|
382 Ptr : System.Address := PC_For (Tracebk (J));
|
|
|
383 begin
|
|
|
384 fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
|
|
|
385 end;
|
|
|
386 end loop;
|
|
|
387
|
|
|
388 First_Call := True;
|
|
|
389 end if;
|
|
|
390
|
|
|
391 Unlock_Task.all;
|
|
|
392 Abort_Undefer.all;
|
|
|
393
|
|
|
394 if Result = System.Null_Address then
|
|
|
395 Raise_Exception (Storage_Error'Identity, "heap exhausted");
|
|
|
396 end if;
|
|
|
397
|
|
|
398 return Result;
|
|
|
399 end Realloc;
|
|
|
400
|
|
|
401 end System.Memory;
|
