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