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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This version contains allocation tracking capability
  35
  36 --  The object file corresponding to this instrumented version is to be found
  37 --  in libgmem.
  38
  39 --  When enabled, the subsystem logs all the calls to __gnat_malloc and
  40 --  __gnat_free. This log can then be processed by gnatmem to detect
  41 --  dynamic memory leaks.
  42
  43 --  To use this functionality, you must compile your application with -g
  44 --  and then link with this object file:
  45
  46 --     gnatmake -g program -largs -lgmem
  47
  48 --  After compilation, you may use your program as usual except that upon
  49 --  completion, it will generate in the current directory the file gmem.out.
  50
  51 --  You can then investigate for possible memory leaks and mismatch by calling
  52 --  gnatmem with this file as an input:
  53
  54 --    gnatmem -i gmem.out program
  55
  56 --  See gnatmem section in the GNAT User's Guide for more details
  57
  58 --  NOTE: This capability is currently supported on the following targets:
  59
  60 --    Windows
  61 --    AIX
  62 --    GNU/Linux
  63 --    HP-UX
  64 --    Irix
  65 --    Solaris
  66 --    Tru64
  67 --    Alpha OpenVMS
  68
  69 --  NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is
  70 --  64 bit. If the need arises to support architectures where this assumption
  71 --  is incorrect, it will require changing the way timestamps of allocation
  72 --  events are recorded.
  73
  74 pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
  75
  76 with Ada.Exceptions;
  77 with System.Soft_Links;
  78 with System.Traceback;
  79 with System.Traceback_Entries;
  80 with GNAT.IO;
  81 with System.OS_Primitives;
  82
  83 package body System.Memory is
  84
  85    use Ada.Exceptions;
  86    use System.Soft_Links;
  87    use System.Traceback;
  88    use System.Traceback_Entries;
  89    use GNAT.IO;
  90
  91    function c_malloc (Size : size_t) return System.Address;
  92    pragma Import (C, c_malloc, "malloc");
  93
  94    procedure c_free (Ptr : System.Address);
  95    pragma Import (C, c_free, "free");
  96
  97    function c_realloc
  98      (Ptr : System.Address; Size : size_t) return System.Address;
  99    pragma Import (C, c_realloc, "realloc");
 100
 101    subtype File_Ptr is System.Address;
 102
 103    function fopen (Path : String; Mode : String) return File_Ptr;
 104    pragma Import (C, fopen);
 105
 106    procedure OS_Exit (Status : Integer);
 107    pragma Import (C, OS_Exit, "__gnat_os_exit");
 108    pragma No_Return (OS_Exit);
 109
 110    procedure fwrite
 111      (Ptr    : System.Address;
 112       Size   : size_t;
 113       Nmemb  : size_t;
 114       Stream : File_Ptr);
 115
 116    procedure fwrite
 117      (Str    : String;
 118       Size   : size_t;
 119       Nmemb  : size_t;
 120       Stream : File_Ptr);
 121    pragma Import (C, fwrite);
 122
 123    procedure fputc (C : Integer; Stream : File_Ptr);
 124    pragma Import (C, fputc);
 125
 126    procedure fclose (Stream : File_Ptr);
 127    pragma Import (C, fclose);
 128
 129    procedure Finalize;
 130    pragma Export (C, Finalize, "__gnat_finalize");
 131    --  Replace the default __gnat_finalize to properly close the log file
 132
 133    Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
 134    --  Size in bytes of a pointer
 135
 136    Max_Call_Stack : constant := 200;
 137    --  Maximum number of frames supported
 138
 139    Tracebk   : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
 140    Num_Calls : aliased Integer := 0;
 141
 142    Gmemfname : constant String := "gmem.out" & ASCII.NUL;
 143    --  Allocation log of a program is saved in a file gmem.out
 144    --  ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
 145    --  gmem.out
 146
 147    Gmemfile : File_Ptr;
 148    --  Global C file pointer to the allocation log
 149
 150    Needs_Init : Boolean := True;
 151    --  Reset after first call to Gmem_Initialize
 152
 153    procedure Gmem_Initialize;
 154    --  Initialization routine; opens the file and writes a header string. This
 155    --  header string is used as a magic-tag to know if the .out file is to be
 156    --  handled by GDB or by the GMEM (instrumented malloc/free) implementation.
 157
 158    First_Call : Boolean := True;
 159    --  Depending on implementation, some of the traceback routines may
 160    --  themselves do dynamic allocation. We use First_Call flag to avoid
 161    --  infinite recursion
 162
 163    -----------
 164    -- Alloc --
 165    -----------
 166
 167    function Alloc (Size : size_t) return System.Address is
 168       Result      : aliased System.Address;
 169       Actual_Size : aliased size_t := Size;
 170       Timestamp   : aliased Duration;
 171
 172    begin
 173       if Size = size_t'Last then
 174          Raise_Exception (Storage_Error'Identity, "object too large");
 175       end if;
 176
 177       --  Change size from zero to non-zero. We still want a proper pointer
 178       --  for the zero case because pointers to zero length objects have to
 179       --  be distinct, but we can't just go ahead and allocate zero bytes,
 180       --  since some malloc's return zero for a zero argument.
 181
 182       if Size = 0 then
 183          Actual_Size := 1;
 184       end if;
 185
 186       Lock_Task.all;
 187
 188       Result := c_malloc (Actual_Size);
 189
 190       if First_Call then
 191
 192          --  Logs allocation call
 193          --  format is:
 194          --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
 195
 196          First_Call := False;
 197
 198          if Needs_Init then
 199             Gmem_Initialize;
 200          end if;
 201
 202          Timestamp := System.OS_Primitives.Clock;
 203          Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
 204                      Skip_Frames => 2);
 205          fputc (Character'Pos ('A'), Gmemfile);
 206          fwrite (Result'Address, Address_Size, 1, Gmemfile);
 207          fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
 208                  Gmemfile);
 209          fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
 210                  Gmemfile);
 211          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 212                  Gmemfile);
 213
 214          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
 215             declare
 216                Ptr : System.Address := PC_For (Tracebk (J));
 217             begin
 218                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 219             end;
 220          end loop;
 221
 222          First_Call := True;
 223
 224       end if;
 225
 226       Unlock_Task.all;
 227
 228       if Result = System.Null_Address then
 229          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 230       end if;
 231
 232       return Result;
 233    end Alloc;
 234
 235    --------------
 236    -- Finalize --
 237    --------------
 238
 239    procedure Finalize is
 240    begin
 241       if not Needs_Init then
 242          fclose (Gmemfile);
 243       end if;
 244    end Finalize;
 245
 246    ----------
 247    -- Free --
 248    ----------
 249
 250    procedure Free (Ptr : System.Address) is
 251       Addr      : aliased constant System.Address := Ptr;
 252       Timestamp : aliased Duration;
 253
 254    begin
 255       Lock_Task.all;
 256
 257       if First_Call then
 258
 259          --  Logs deallocation call
 260          --  format is:
 261          --   'D' <mem addr> <len backtrace> <addr1> ... <addrn>
 262
 263          First_Call := False;
 264
 265          if Needs_Init then
 266             Gmem_Initialize;
 267          end if;
 268
 269          Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
 270                      Skip_Frames => 2);
 271          Timestamp := System.OS_Primitives.Clock;
 272          fputc (Character'Pos ('D'), Gmemfile);
 273          fwrite (Addr'Address, Address_Size, 1, Gmemfile);
 274          fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
 275                  Gmemfile);
 276          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 277                  Gmemfile);
 278
 279          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
 280             declare
 281                Ptr : System.Address := PC_For (Tracebk (J));
 282             begin
 283                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 284             end;
 285          end loop;
 286
 287          c_free (Ptr);
 288
 289          First_Call := True;
 290       end if;
 291
 292       Unlock_Task.all;
 293    end Free;
 294
 295    ---------------------
 296    -- Gmem_Initialize --
 297    ---------------------
 298
 299    procedure Gmem_Initialize is
 300       Timestamp : aliased Duration;
 301
 302    begin
 303       if Needs_Init then
 304          Needs_Init := False;
 305          System.OS_Primitives.Initialize;
 306          Timestamp := System.OS_Primitives.Clock;
 307          Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
 308
 309          if Gmemfile = System.Null_Address then
 310             Put_Line ("Couldn't open gnatmem log file for writing");
 311             OS_Exit (255);
 312          end if;
 313
 314          fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
 315          fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
 316                  Gmemfile);
 317       end if;
 318    end Gmem_Initialize;
 319
 320    -------------
 321    -- Realloc --
 322    -------------
 323
 324    function Realloc
 325      (Ptr  : System.Address;
 326       Size : size_t) return System.Address
 327    is
 328       Addr      : aliased constant System.Address := Ptr;
 329       Result    : aliased System.Address;
 330       Timestamp : aliased Duration;
 331
 332    begin
 333       --  For the purposes of allocations logging, we treat realloc as a free
 334       --  followed by malloc. This is not exactly accurate, but is a good way
 335       --  to fit it into malloc/free-centered reports.
 336
 337       if Size = size_t'Last then
 338          Raise_Exception (Storage_Error'Identity, "object too large");
 339       end if;
 340
 341       Abort_Defer.all;
 342       Lock_Task.all;
 343
 344       if First_Call then
 345          First_Call := False;
 346
 347          --  We first log deallocation call
 348
 349          if Needs_Init then
 350             Gmem_Initialize;
 351          end if;
 352          Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
 353                      Skip_Frames => 2);
 354          Timestamp := System.OS_Primitives.Clock;
 355          fputc (Character'Pos ('D'), Gmemfile);
 356          fwrite (Addr'Address, Address_Size, 1, Gmemfile);
 357          fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
 358                  Gmemfile);
 359          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 360                  Gmemfile);
 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                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 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          fputc (Character'Pos ('A'), Gmemfile);
 377          fwrite (Result'Address, Address_Size, 1, Gmemfile);
 378          fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
 379                  Gmemfile);
 380          fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
 381                  Gmemfile);
 382          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 383                  Gmemfile);
 384
 385          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
 386             declare
 387                Ptr : System.Address := PC_For (Tracebk (J));
 388             begin
 389                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 390             end;
 391          end loop;
 392
 393          First_Call := True;
 394       end if;
 395
 396       Unlock_Task.all;
 397       Abort_Undefer.all;
 398
 399       if Result = System.Null_Address then
 400          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 401       end if;
 402
 403       return Result;
 404    end Realloc;
 405
 406 end System.Memory;