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