Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/memtrack.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;