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-2004 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34--  This version contains allocation tracking capability.
35
36--  The object file corresponding to this instrumented version is to be found
37--  in libgmem.
38
39--  When enabled, the subsystem logs all the calls to __gnat_malloc and
40--  __gnat_free. This log can then be processed by gnatmem to detect
41--  dynamic memory leaks.
42
43--  To use this functionality, you must compile your application with -g
44--  and then link with this object file:
45
46--     gnatmake -g program -largs -lgmem
47
48--  After compilation, you may use your program as usual except that upon
49--  completion, it will generate in the current directory the file gmem.out.
50
51--  You can then investigate for possible memory leaks and mismatch by calling
52--  gnatmem with this file as an input:
53
54--    gnatmem -i gmem.out program
55
56--  See gnatmem section in the GNAT User's Guide for more details.
57
58--  NOTE: This capability is currently supported on the following targets:
59
60--    Windows
61--    AIX
62--    GNU/Linux
63--    HP-UX
64--    Irix
65--    Solaris
66--    Tru64
67
68pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
69
70with Ada.Exceptions;
71with System.Soft_Links;
72with System.Traceback;
73with System.Traceback_Entries;
74with GNAT.IO;
75
76package body System.Memory is
77
78   use Ada.Exceptions;
79   use System.Soft_Links;
80   use System.Traceback;
81   use System.Traceback_Entries;
82   use GNAT.IO;
83
84   function c_malloc (Size : size_t) return System.Address;
85   pragma Import (C, c_malloc, "malloc");
86
87   procedure c_free (Ptr : System.Address);
88   pragma Import (C, c_free, "free");
89
90   function c_realloc
91     (Ptr : System.Address; Size : size_t) return System.Address;
92   pragma Import (C, c_realloc, "realloc");
93
94   subtype File_Ptr is System.Address;
95
96   function fopen (Path : String; Mode : String) return File_Ptr;
97   pragma Import (C, fopen);
98
99   procedure OS_Exit (Status : Integer);
100   pragma Import (C, OS_Exit, "__gnat_os_exit");
101   pragma No_Return (OS_Exit);
102
103   procedure fwrite
104     (Ptr    : System.Address;
105      Size   : size_t;
106      Nmemb  : size_t;
107      Stream : File_Ptr);
108
109   procedure fwrite
110     (Str    : String;
111      Size   : size_t;
112      Nmemb  : size_t;
113      Stream : File_Ptr);
114   pragma Import (C, fwrite);
115
116   procedure fputc (C : Integer; Stream : File_Ptr);
117   pragma Import (C, fputc);
118
119   procedure fclose (Stream : File_Ptr);
120   pragma Import (C, fclose);
121
122   procedure Finalize;
123   --  Replace the default __gnat_finalize to properly close the log file.
124   pragma Export (C, Finalize, "__gnat_finalize");
125
126   Address_Size    : constant := System.Address'Max_Size_In_Storage_Elements;
127   --  Size in bytes of a pointer
128
129   Max_Call_Stack  : constant := 200;
130   --  Maximum number of frames supported
131
132   Tracebk   : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
133   Num_Calls : aliased Integer := 0;
134
135   Gmemfname : constant String := "gmem.out" & ASCII.NUL;
136   --  Allocation log of a program is saved in a file gmem.out
137   --  ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
138   --  gmem.out
139
140   Gmemfile  : File_Ptr;
141   --  Global C file pointer to the allocation log
142
143   procedure Gmem_Initialize;
144   --  Initialization routine; opens the file and writes a header string. This
145   --  header string is used as a magic-tag to know if the .out file is to be
146   --  handled by GDB or by the GMEM (instrumented malloc/free) implementation.
147
148   First_Call : Boolean := True;
149   --  Depending on implementation, some of the traceback routines may
150   --  themselves do dynamic allocation. We use First_Call flag to avoid
151   --  infinite recursion
152
153   -----------
154   -- Alloc --
155   -----------
156
157   function Alloc (Size : size_t) return System.Address is
158      Result      : aliased System.Address;
159      Actual_Size : aliased size_t := Size;
160
161   begin
162      if Size = size_t'Last then
163         Raise_Exception (Storage_Error'Identity, "object too large");
164      end if;
165
166      --  Change size from zero to non-zero. We still want a proper pointer
167      --  for the zero case because pointers to zero length objects have to
168      --  be distinct, but we can't just go ahead and allocate zero bytes,
169      --  since some malloc's return zero for a zero argument.
170
171      if Size = 0 then
172         Actual_Size := 1;
173      end if;
174
175      Lock_Task.all;
176
177      Result := c_malloc (Actual_Size);
178
179      if First_Call then
180
181         --  Logs allocation call
182         --  format is:
183         --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
184
185         First_Call := False;
186
187         Gmem_Initialize;
188         Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
189                     Skip_Frames => 2);
190         fputc (Character'Pos ('A'), Gmemfile);
191         fwrite (Result'Address, Address_Size, 1, Gmemfile);
192         fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
193                 Gmemfile);
194         fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
195                 Gmemfile);
196
197         for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
198            declare
199               Ptr : System.Address := PC_For (Tracebk (J));
200            begin
201               fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
202            end;
203         end loop;
204
205         First_Call := True;
206
207      end if;
208
209      Unlock_Task.all;
210
211      if Result = System.Null_Address then
212         Raise_Exception (Storage_Error'Identity, "heap exhausted");
213      end if;
214
215      return Result;
216   end Alloc;
217
218   --------------
219   -- Finalize --
220   --------------
221
222   Needs_Init : Boolean := True;
223   --  Reset after first call to Gmem_Initialize
224
225   procedure Finalize is
226   begin
227      if not Needs_Init then
228         fclose (Gmemfile);
229      end if;
230   end Finalize;
231
232   ----------
233   -- Free --
234   ----------
235
236   procedure Free (Ptr : System.Address) is
237      Addr : aliased constant System.Address := Ptr;
238   begin
239      Lock_Task.all;
240
241      if First_Call then
242
243         --  Logs deallocation call
244         --  format is:
245         --   'D' <mem addr> <len backtrace> <addr1> ... <addrn>
246
247         First_Call := False;
248
249         Gmem_Initialize;
250         Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
251                     Skip_Frames => 2);
252         fputc (Character'Pos ('D'), Gmemfile);
253         fwrite (Addr'Address, Address_Size, 1, Gmemfile);
254         fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
255                 Gmemfile);
256
257         for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
258            declare
259               Ptr : System.Address := PC_For (Tracebk (J));
260            begin
261               fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
262            end;
263         end loop;
264
265         c_free (Ptr);
266
267         First_Call := True;
268
269      end if;
270
271      Unlock_Task.all;
272   end Free;
273
274   ---------------------
275   -- Gmem_Initialize --
276   ---------------------
277
278   procedure Gmem_Initialize is
279   begin
280      if Needs_Init then
281         Needs_Init := False;
282         Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
283         if Gmemfile = System.Null_Address then
284            Put_Line ("Couldn't open gnatmem log file for writing");
285            OS_Exit (255);
286         end if;
287         fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
288      end if;
289   end Gmem_Initialize;
290
291   -------------
292   -- Realloc --
293   -------------
294
295   function Realloc
296     (Ptr : System.Address; Size : size_t) return System.Address
297   is
298      Result : System.Address;
299   begin
300      if Size = size_t'Last then
301         Raise_Exception (Storage_Error'Identity, "object too large");
302      end if;
303
304      Abort_Defer.all;
305      Result := c_realloc (Ptr, Size);
306      Abort_Undefer.all;
307
308      if Result = System.Null_Address then
309         Raise_Exception (Storage_Error'Identity, "heap exhausted");
310      end if;
311
312      return Result;
313   end Realloc;
314
315end System.Memory;
316