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-2018, 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