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