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