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