gcc/ada/libgnat/memtrack.adb

   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-2023, 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
  69 pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
  70
  71 with Ada.Exceptions;
  72 with GNAT.IO;
  73
  74 with System.Soft_Links;
  75 with System.Traceback;
  76 with System.Traceback_Entries;
  77 with System.CRTL;
  78 with System.OS_Lib;
  79 with System.OS_Primitives;
  80
  81 package 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
 421 end System.Memory;