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-2003 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  68 pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
  69
  70 with Ada.Exceptions;
  71 with System.Soft_Links;
  72 with System.Traceback;
  73 with System.Traceback_Entries;
  74
  75 package body System.Memory is
  76
  77    use Ada.Exceptions;
  78    use System.Soft_Links;
  79    use System.Traceback;
  80    use System.Traceback_Entries;
  81
  82    function c_malloc (Size : size_t) return System.Address;
  83    pragma Import (C, c_malloc, "malloc");
  84
  85    procedure c_free (Ptr : System.Address);
  86    pragma Import (C, c_free, "free");
  87
  88    function c_realloc
  89      (Ptr : System.Address; Size : size_t) return System.Address;
  90    pragma Import (C, c_realloc, "realloc");
  91
  92    type File_Ptr is new System.Address;
  93
  94    function fopen (Path : String; Mode : String) return File_Ptr;
  95    pragma Import (C, fopen);
  96
  97    procedure fwrite
  98      (Ptr    : System.Address;
  99       Size   : size_t;
 100       Nmemb  : size_t;
 101       Stream : File_Ptr);
 102
 103    procedure fwrite
 104      (Str    : String;
 105       Size   : size_t;
 106       Nmemb  : size_t;
 107       Stream : File_Ptr);
 108    pragma Import (C, fwrite);
 109
 110    procedure fputc (C : Integer; Stream : File_Ptr);
 111    pragma Import (C, fputc);
 112
 113    procedure fclose (Stream : File_Ptr);
 114    pragma Import (C, fclose);
 115
 116    procedure Finalize;
 117    --  Replace the default __gnat_finalize to properly close the log file.
 118    pragma Export (C, Finalize, "__gnat_finalize");
 119
 120    Address_Size    : constant := System.Address'Max_Size_In_Storage_Elements;
 121    --  Size in bytes of a pointer
 122
 123    Max_Call_Stack  : constant := 200;
 124    --  Maximum number of frames supported
 125
 126    Tracebk   : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
 127    Num_Calls : aliased Integer := 0;
 128
 129    Gmemfname : constant String := "gmem.out" & ASCII.NUL;
 130    --  Allocation log of a program is saved in a file gmem.out
 131    --  ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
 132    --  gmem.out
 133
 134    Gmemfile  : File_Ptr;
 135    --  Global C file pointer to the allocation log
 136
 137    procedure Gmem_Initialize;
 138    --  Initialization routine; opens the file and writes a header string. This
 139    --  header string is used as a magic-tag to know if the .out file is to be
 140    --  handled by GDB or by the GMEM (instrumented malloc/free) implementation.
 141
 142    First_Call : Boolean := True;
 143    --  Depending on implementation, some of the traceback routines may
 144    --  themselves do dynamic allocation. We use First_Call flag to avoid
 145    --  infinite recursion
 146
 147    -----------
 148    -- Alloc --
 149    -----------
 150
 151    function Alloc (Size : size_t) return System.Address is
 152       Result      : aliased System.Address;
 153       Actual_Size : aliased size_t := Size;
 154
 155    begin
 156       if Size = size_t'Last then
 157          Raise_Exception (Storage_Error'Identity, "object too large");
 158       end if;
 159
 160       --  Change size from zero to non-zero. We still want a proper pointer
 161       --  for the zero case because pointers to zero length objects have to
 162       --  be distinct, but we can't just go ahead and allocate zero bytes,
 163       --  since some malloc's return zero for a zero argument.
 164
 165       if Size = 0 then
 166          Actual_Size := 1;
 167       end if;
 168
 169       Lock_Task.all;
 170
 171       Result := c_malloc (Actual_Size);
 172
 173       if First_Call then
 174
 175          --  Logs allocation call
 176          --  format is:
 177          --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
 178
 179          First_Call := False;
 180
 181          Gmem_Initialize;
 182          Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
 183                      Skip_Frames => 2);
 184          fputc (Character'Pos ('A'), Gmemfile);
 185          fwrite (Result'Address, Address_Size, 1, Gmemfile);
 186          fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
 187                  Gmemfile);
 188          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 189                  Gmemfile);
 190
 191          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
 192             declare
 193                Ptr : System.Address := PC_For (Tracebk (J));
 194             begin
 195                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 196             end;
 197          end loop;
 198
 199          First_Call := True;
 200
 201       end if;
 202
 203       Unlock_Task.all;
 204
 205       if Result = System.Null_Address then
 206          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 207       end if;
 208
 209       return Result;
 210    end Alloc;
 211
 212    --------------
 213    -- Finalize --
 214    --------------
 215
 216    Needs_Init : Boolean := True;
 217    --  Reset after first call to Gmem_Initialize
 218
 219    procedure Finalize is
 220    begin
 221       if not Needs_Init then
 222          fclose (Gmemfile);
 223       end if;
 224    end Finalize;
 225
 226    ----------
 227    -- Free --
 228    ----------
 229
 230    procedure Free (Ptr : System.Address) is
 231       Addr : aliased constant System.Address := Ptr;
 232    begin
 233       Lock_Task.all;
 234
 235       if First_Call then
 236
 237          --  Logs deallocation call
 238          --  format is:
 239          --   'D' <mem addr> <len backtrace> <addr1> ... <addrn>
 240
 241          First_Call := False;
 242
 243          Gmem_Initialize;
 244          Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
 245                      Skip_Frames => 2);
 246          fputc (Character'Pos ('D'), Gmemfile);
 247          fwrite (Addr'Address, Address_Size, 1, Gmemfile);
 248          fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 249                  Gmemfile);
 250
 251          for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
 252             declare
 253                Ptr : System.Address := PC_For (Tracebk (J));
 254             begin
 255                fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
 256             end;
 257          end loop;
 258
 259          c_free (Ptr);
 260
 261          First_Call := True;
 262
 263       end if;
 264
 265       Unlock_Task.all;
 266    end Free;
 267
 268    ---------------------
 269    -- Gmem_Initialize --
 270    ---------------------
 271
 272    procedure Gmem_Initialize is
 273    begin
 274       if Needs_Init then
 275          Needs_Init := False;
 276          Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
 277          fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
 278       end if;
 279    end Gmem_Initialize;
 280
 281    -------------
 282    -- Realloc --
 283    -------------
 284
 285    function Realloc
 286      (Ptr : System.Address; Size : size_t) return System.Address
 287    is
 288       Result : System.Address;
 289    begin
 290       if Size = size_t'Last then
 291          Raise_Exception (Storage_Error'Identity, "object too large");
 292       end if;
 293
 294       Abort_Defer.all;
 295       Result := c_realloc (Ptr, Size);
 296       Abort_Undefer.all;
 297
 298       if Result = System.Null_Address then
 299          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 300       end if;
 301
 302       return Result;
 303    end Realloc;
 304
 305 end System.Memory;