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