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