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-2014, 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
69pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
70
71with Ada.Exceptions;
72with System.Soft_Links;
73with System.Traceback;
74with System.Traceback_Entries;
75with GNAT.IO;
76with System.OS_Primitives;
77
78package 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
401end System.Memory;
402