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 --                                 S p e c                                  --
   8 --                                                                          --
   9 --                            $Revision$
  10 --                                                                          --
  11 --             Copyright (C) 2001 Free Software Foundation, Inc.            --
  12 --                                                                          --
  13 -- This specification is derived from the Ada Reference Manual for use with --
  14 -- GNAT. The copyright notice above, and the license provisions that follow --
  15 -- apply solely to the  contents of the part following the private keyword. --
  16 --                                                                          --
  17 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  18 -- terms of the  GNU General Public License as published  by the Free Soft- --
  19 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  20 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  21 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  22 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  23 -- for  more details.  You should have  received  a copy of the GNU General --
  24 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  25 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  26 -- MA 02111-1307, USA.                                                      --
  27 --                                                                          --
  28 -- As a special exception,  if other files  instantiate  generics from this --
  29 -- unit, or you link  this unit with other files  to produce an executable, --
  30 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  31 -- covered  by the  GNU  General  Public  License.  This exception does not --
  32 -- however invalidate  any other reasons why  the executable file  might be --
  33 -- covered by the  GNU Public License.                                      --
  34 --                                                                          --
  35 -- GNAT was originally developed  by the GNAT team at  New York University. --
  36 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  37 --                                                                          --
  38 ------------------------------------------------------------------------------
  39
  40 --  This version contains allocation tracking capability.
  41 --  The object file corresponding to this instrumented version is to be found
  42 --  in libgmem.
  43 --  When enabled, the subsystem logs all the calls to __gnat_malloc and
  44 --  __gnat_free. This log can then be processed by gnatmem to detect
  45 --  dynamic memory leaks.
  46 --
  47 --  To use this functionality, you must compile your application with -g
  48 --  and then link with this object file:
  49 --
  50 --     gnatmake -g program -largs -lgmem
  51 --
  52 --  After compilation, you may use your program as usual except that upon
  53 --  completion, it will generate in the current directory the file gmem.out.
  54 --
  55 --  You can then investigate for possible memory leaks and mismatch by calling
  56 --  gnatmem with this file as an input:
  57 --
  58 --    gnatmem -i gmem.out program
  59 --
  60 --  See gnatmem section in the GNAT User's Guide for more details.
  61 --
  62 --  NOTE: This capability is currently supported on the following targets:
  63 --
  64 --    Windows
  65 --    GNU/Linux
  66 --    HP-UX
  67 --    Irix
  68 --    Solaris
  69 --    Tru64
  70
  71 pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
  72
  73 with Ada.Exceptions;
  74 with System.Soft_Links;
  75 with System.Traceback;
  76
  77 package body System.Memory is
  78
  79    use Ada.Exceptions;
  80    use System.Soft_Links;
  81    use System.Traceback;
  82
  83    function c_malloc (Size : size_t) return System.Address;
  84    pragma Import (C, c_malloc, "malloc");
  85
  86    procedure c_free (Ptr : System.Address);
  87    pragma Import (C, c_free, "free");
  88
  89    function c_realloc
  90      (Ptr : System.Address; Size : size_t) return System.Address;
  91    pragma Import (C, c_realloc, "realloc");
  92
  93    type File_Ptr is new System.Address;
  94
  95    function fopen (Path : String; Mode : String) return File_Ptr;
  96    pragma Import (C, fopen);
  97
  98    procedure fwrite
  99      (Ptr    : System.Address;
 100       Size   : size_t;
 101       Nmemb  : size_t;
 102       Stream : File_Ptr);
 103
 104    procedure fwrite
 105      (Str    : String;
 106       Size   : size_t;
 107       Nmemb  : size_t;
 108       Stream : File_Ptr);
 109    pragma Import (C, fwrite);
 110
 111    procedure fputc (C : Integer; Stream : File_Ptr);
 112    pragma Import (C, fputc);
 113
 114    procedure fclose (Stream : File_Ptr);
 115    pragma Import (C, fclose);
 116
 117    procedure Finalize;
 118    --  Replace the default __gnat_finalize to properly close the log file.
 119    pragma Export (C, Finalize, "__gnat_finalize");
 120
 121    Address_Size    : constant := System.Address'Max_Size_In_Storage_Elements;
 122    --  Size in bytes of a pointer
 123
 124    Max_Call_Stack  : constant := 200;
 125    --  Maximum number of frames supported
 126
 127    Skip_Frame : constant := 1;
 128    --  Number of frames to remove from the call stack to hide functions from
 129    --  this unit.
 130
 131    Tracebk   : aliased array (0 .. Max_Call_Stack) of System.Address;
 132    Num_Calls : aliased Integer := 0;
 133    --  Store the current call stack from Alloc and Free
 134
 135    Gmemfname : constant String := "gmem.out" & ASCII.NUL;
 136    --  Allocation log of a program is saved in a file gmem.out
 137    --  ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
 138    --  gmem.out
 139
 140    Gmemfile  : File_Ptr;
 141    --  Global C file pointer to the allocation log
 142
 143    procedure Gmem_Initialize;
 144    --  Initialization routine; opens the file and writes a header string. This
 145    --  header string is used as a magic-tag to know if the .out file is to be
 146    --  handled by GDB or by the GMEM (instrumented malloc/free) implementation.
 147
 148    -----------
 149    -- Alloc --
 150    -----------
 151
 152    function Alloc (Size : size_t) return System.Address is
 153       Result      : aliased System.Address;
 154       Actual_Size : aliased size_t := Size;
 155
 156    begin
 157       if Size = size_t'Last then
 158          Raise_Exception (Storage_Error'Identity, "object too large");
 159       end if;
 160
 161       --  Change size from zero to non-zero. We still want a proper pointer
 162       --  for the zero case because pointers to zero length objects have to
 163       --  be distinct, but we can't just go ahead and allocate zero bytes,
 164       --  since some malloc's return zero for a zero argument.
 165
 166       if Size = 0 then
 167          Actual_Size := 1;
 168       end if;
 169
 170       Lock_Task.all;
 171
 172       Result := c_malloc (Actual_Size);
 173
 174       --  Logs allocation call
 175       --  format is:
 176       --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
 177
 178       Gmem_Initialize;
 179       Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
 180       Num_Calls := Num_Calls - Skip_Frame;
 181       fputc (Character'Pos ('A'), Gmemfile);
 182       fwrite (Result'Address, Address_Size, 1, Gmemfile);
 183       fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
 184               Gmemfile);
 185       fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 186               Gmemfile);
 187       fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
 188               Gmemfile);
 189
 190       Unlock_Task.all;
 191
 192       if Result = System.Null_Address then
 193          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 194       end if;
 195
 196       return Result;
 197    end Alloc;
 198
 199    --------------
 200    -- Finalize --
 201    --------------
 202
 203    Needs_Init : Boolean := True;
 204    --  Reset after first call to Gmem_Initialize
 205
 206    procedure Finalize is
 207    begin
 208       if not Needs_Init then
 209          fclose (Gmemfile);
 210       end if;
 211    end Finalize;
 212
 213    ----------
 214    -- Free --
 215    ----------
 216
 217    procedure Free (Ptr : System.Address) is
 218       Addr : aliased constant System.Address := Ptr;
 219    begin
 220       Lock_Task.all;
 221
 222       --  Logs deallocation call
 223       --  format is:
 224       --   'D' <mem addr> <len backtrace> <addr1> ... <addrn>
 225
 226       Gmem_Initialize;
 227       Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
 228       Num_Calls := Num_Calls - Skip_Frame;
 229       fputc (Character'Pos ('D'), Gmemfile);
 230       fwrite (Addr'Address, Address_Size, 1, Gmemfile);
 231       fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
 232               Gmemfile);
 233       fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
 234               Gmemfile);
 235
 236       c_free (Ptr);
 237
 238       Unlock_Task.all;
 239    end Free;
 240
 241    ---------------------
 242    -- Gmem_Initialize --
 243    ---------------------
 244
 245    procedure Gmem_Initialize is
 246    begin
 247       if Needs_Init then
 248          Needs_Init := False;
 249          Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
 250          fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
 251       end if;
 252    end Gmem_Initialize;
 253
 254    -------------
 255    -- Realloc --
 256    -------------
 257
 258    function Realloc
 259      (Ptr : System.Address; Size : size_t) return System.Address
 260    is
 261       Result : System.Address;
 262    begin
 263       if Size = size_t'Last then
 264          Raise_Exception (Storage_Error'Identity, "object too large");
 265       end if;
 266
 267       Abort_Defer.all;
 268       Result := c_realloc (Ptr, Size);
 269       Abort_Undefer.all;
 270
 271       if Result = System.Null_Address then
 272          Raise_Exception (Storage_Error'Identity, "heap exhausted");
 273       end if;
 274
 275       return Result;
 276    end Realloc;
 277
 278 end System.Memory;