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