-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
--- --
--- Copyright (C) 1997-2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2007, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- GNATMEM is a utility that tracks memory leaks. It is based on a simple
-- idea:
--- - run the application under gdb
--- - set a breakpoint on __gnat_malloc and __gnat_free
--- - record a reference to the allocated memory on each allocation call
--- - suppress this reference on deallocation
--- - at the end of the program, remaining references are potential leaks.
+
+-- - Read the allocation log generated by the application linked using
+-- instrumented memory allocation and deallocation (see memtrack.adb for
+-- this circuitry). To get access to this functionality, the application
+-- must be relinked with library libgmem.a:
+
+-- $ gnatmake my_prog -largs -lgmem
+
+-- The running my_prog will produce a file named gmem.out that will be
+-- parsed by gnatmem.
+
+-- - Record a reference to the allocated memory on each allocation call
+
+-- - Suppress this reference on deallocation
+
+-- - At the end of the program, remaining references are potential leaks.
-- sort them out the best possible way in order to locate the root of
-- the leak.
---
--- GNATMEM can also be used with instrumented allocation/deallocation
--- routine (see a-raise.c with symbol GMEM defined). This is not supported
--- in all platforms, again refer to a-raise.c for further information.
--- In this case the application must be relinked with library libgmem.a:
---
--- $ gnatmake my_prog -largs -lgmem
---
--- The running my_prog will produce a file named gmem.out that will be
--- parsed by gnatmem.
---
+
+-- This capability is not supported on all platforms, please refer to
+-- memtrack.adb for further information.
+
-- In order to help finding out the real leaks, the notion of "allocation
-- root" is defined. An allocation root is a specific point in the program
-- execution generating memory allocation where data is collected (such as
--- number of allocations, quantify of memory allocated, high water mark,
--- etc.).
+-- number of allocations, amount of memory allocated, high water mark, etc.)
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Text_IO.C_Streams;
with Ada.Float_Text_IO;
with Ada.Integer_Text_IO;
-with Gnatvsn; use Gnatvsn;
-with GNAT.Heap_Sort_G;
-with GNAT.OS_Lib;
-with GNAT.HTable; use GNAT.HTable;
-with Interfaces.C_Streams; use Interfaces.C_Streams;
+with Ada.Text_IO; use Ada.Text_IO;
+
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.Heap_Sort_G;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.HTable; use GNAT.HTable;
+
+with Gnatvsn; use Gnatvsn;
with Memroot; use Memroot;
procedure Gnatmem is
- ------------------------------------------------
- -- Potentially Target Dependent Subprograms. --
- ------------------------------------------------
-
- function Get_Current_TTY return String;
- -- Give the current tty on which the program is run. This is needed to
- -- separate the output of the debugger from the output of the program.
- -- The output of this function will be used to call the gdb command "tty"
- -- in the gdb script in order to get the program output on the current tty
- -- while the gdb output is redirected and processed by gnatmem.
-
- function popen (File, Mode : System.Address) return FILEs;
- pragma Import (C, popen, "popen");
- -- Execute the program 'File'. If the mode is "r" the standard output
- -- of the program is redirected and the FILEs handler of the
- -- redirection is returned.
-
- procedure System_Cmd (X : System.Address);
- pragma Import (C, System_Cmd, "system");
- -- Execute the program "X".
-
- subtype Cstring is String (1 .. Integer'Last);
- type Cstring_Ptr is access all Cstring;
-
- function ttyname (Dec : Integer) return Cstring_Ptr;
- pragma Import (C, ttyname, "__gnat_ttyname");
- -- Return a null-terminated string containing the current tty
-
- Dir_Sep : constant Character := '/';
+ package Int_IO renames Ada.Integer_Text_IO;
------------------------
-- Other Declarations --
------------------------
- type Gdb_Output_Elmt is (Eof, Alloc, Deall);
- -- Eof = End of gdb output file
- -- Alloc = found a ALLOC mark in the gdb output
- -- Deall = found a DEALL mark in the gdb output
- Gdb_Output_Format_Error : exception;
+ type Storage_Elmt is record
+ Elmt : Character;
+ -- * = End of log file
+ -- A = found a ALLOC mark in the log
+ -- D = found a DEALL mark in the log
+
+ Address : Integer_Address;
+ Size : Storage_Count;
+ Timestamp : Duration;
+ end record;
+ -- This type is used to read heap operations from the log file.
+ -- Elmt contains the type of the operation, which can be either
+ -- allocation, deallocation, or a special mark indicating the
+ -- end of the log file. Address is used to store address on the
+ -- heap where a chunk was allocated/deallocated, size is only
+ -- for A event and contains size of the allocation, and Timestamp
+ -- is the clock value at the moment of allocation
+
+ Log_Name : String_Access;
+ -- Holds the name of the heap operations log file
- function Read_Next return Gdb_Output_Elmt;
- -- Read the output of the debugger till it finds either the end of the
- -- output, or the 'ALLOC' mark or the 'DEALL' mark. In the second case,
- -- it sets the Tmp_Size and Tmp_Address global variables, in the
- -- third case it sets the Tmp_Address variable.
+ Program_Name : String_Access;
+ -- Holds the name of the user executable
- procedure Create_Gdb_Script;
- -- Create the GDB script and save it in a temporary file
+ function Read_Next return Storage_Elmt;
+ -- Reads next dynamic storage operation from the log file
function Mem_Image (X : Storage_Count) return String;
-- X is a size in storage_element. Returns a value
- -- in Megabytes, Kiloytes or Bytes as appropriate.
+ -- in Megabytes, Kilobytes or Bytes as appropriate.
procedure Process_Arguments;
- -- Read command line arguments;
+ -- Read command line arguments
procedure Usage;
-- Prints out the option help
-- Initialises the convert_addresses interface by supplying it with
-- the name of the executable file Exename
- procedure Gmem_Read_Next (Buf : out String; Last : out Natural);
- -- Reads the next allocation/deallocation entry and its backtrace
- -- and prepares in the string Buf (up to the position of Last) the
- -- expression compatible with gnatmem parser:
- -- Allocation entry produces the expression "ALLOC^[size]^0x[address]^"
- -- Deallocation entry produces the expression "DEALLOC^0x[address]^"
-
- Argc : constant Integer := Argument_Count;
- Gnatmem_Tmp : aliased constant String := "gnatmem.tmp";
-
- Mode_R : aliased constant String (1 .. 2) := 'r' & ASCII.NUL;
- Mode_W : aliased constant String (1 .. 3) := "w+" & ASCII.NUL;
-
-----------------------------------
-- HTable address --> Allocation --
-----------------------------------
Equal => "=");
BT_Depth : Integer := 1;
- FD : FILEs;
- FT : File_Type;
- File_Pos : Integer := 0;
- Exec_Pos : Integer := 0;
- Target_Pos : Integer := 0;
- Run_Gdb : Boolean := True;
-
- Global_Alloc_Size : Storage_Count := 0;
- Global_High_Water_Mark : Storage_Count := 0;
- Global_Nb_Alloc : Integer := 0;
- Global_Nb_Dealloc : Integer := 0;
- Nb_Root : Integer := 0;
- Nb_Wrong_Deall : Integer := 0;
- Target_Name : String (1 .. 80);
- Target_Protocol : String (1 .. 80);
- Target_Name_Len : Integer;
- Target_Protocol_Len : Integer;
- Cross_Case : Boolean := False;
-
- Tmp_Size : Storage_Count := 0;
- Tmp_Address : Integer_Address;
- Tmp_Alloc : Allocation;
- Quiet_Mode : Boolean := False;
+
+ -- Some global statistics
+
+ Global_Alloc_Size : Storage_Count := 0;
+ -- Total number of bytes allocated during the lifetime of a program
+
+ Global_High_Water_Mark : Storage_Count := 0;
+ -- Largest amount of storage ever in use during the lifetime
+
+ Global_Nb_Alloc : Integer := 0;
+ -- Total number of allocations
+
+ Global_Nb_Dealloc : Integer := 0;
+ -- Total number of deallocations
+
+ Nb_Root : Integer := 0;
+ -- Total number of allocation roots
+
+ Nb_Wrong_Deall : Integer := 0;
+ -- Total number of wrong deallocations (i.e. without matching alloc)
+
+ Minimum_Nb_Leaks : Integer := 1;
+ -- How many unfreed allocs should be in a root for it to count as leak
+
+ T0 : Duration := 0.0;
+ -- The moment at which memory allocation routines initialized (should
+ -- be pretty close to the moment the program started since there are
+ -- always some allocations at RTL elaboration
+
+ Tmp_Alloc : Allocation;
+ Dump_Log_Mode : Boolean := False;
+ Quiet_Mode : Boolean := False;
+
+ ------------------------------
+ -- Allocation Roots Sorting --
+ ------------------------------
+
+ Sort_Order : String (1 .. 3) := "nwh";
+ -- This is the default order in which sorting criteria will be applied
+ -- n - Total number of unfreed allocations
+ -- w - Final watermark
+ -- h - High watermark
--------------------------------
-- GMEM functionality binding --
--------------------------------
+ ---------------------
+ -- Gmem_Initialize --
+ ---------------------
+
function Gmem_Initialize (Dumpname : String) return Boolean is
- function Initialize (Dumpname : System.Address) return Boolean;
+ function Initialize (Dumpname : System.Address) return Duration;
pragma Import (C, Initialize, "__gnat_gmem_initialize");
+
S : aliased String := Dumpname & ASCII.NUL;
+
begin
- return Initialize (S'Address);
+ T0 := Initialize (S'Address);
+ return T0 > 0.0;
end Gmem_Initialize;
+ -------------------------
+ -- Gmem_A2l_Initialize --
+ -------------------------
+
procedure Gmem_A2l_Initialize (Exename : String) is
procedure A2l_Initialize (Exename : System.Address);
pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
+
S : aliased String := Exename & ASCII.NUL;
+
begin
A2l_Initialize (S'Address);
end Gmem_A2l_Initialize;
- procedure Gmem_Read_Next (Buf : out String; Last : out Natural) is
+ ---------------
+ -- Read_Next --
+ ---------------
+
+ function Read_Next return Storage_Elmt is
procedure Read_Next (buf : System.Address);
pragma Import (C, Read_Next, "__gnat_gmem_read_next");
- function Strlen (str : System.Address) return Natural;
- pragma Import (C, Strlen, "strlen");
-
- S : String (1 .. 1000);
- begin
- Read_Next (S'Address);
- Last := Strlen (S'Address);
- Buf (1 .. Last) := S (1 .. Last);
- end Gmem_Read_Next;
-
- ---------------------
- -- Get_Current_TTY --
- ---------------------
- function Get_Current_TTY return String is
- Res : Cstring_Ptr;
- stdout : constant Integer := 1;
- Max_TTY_Name : constant Integer := 500;
+ S : Storage_Elmt;
begin
- if isatty (stdout) /= 1 then
- return "";
- end if;
-
- Res := ttyname (1);
- if Res /= null then
- for J in Cstring'First .. Max_TTY_Name loop
- if Res (J) = ASCII.NUL then
- return Res (Cstring'First .. J - 1);
- end if;
- end loop;
- end if;
-
- -- if we fall thru the ttyname result was dubious. Just forget it.
-
- return "";
- end Get_Current_TTY;
+ Read_Next (S'Address);
+ return S;
+ end Read_Next;
-------
-- H --
return Address_Range (A mod Integer_Address (Address_Range'Last));
end H;
- -----------------------
- -- Create_Gdb_Script --
- -----------------------
-
- procedure Create_Gdb_Script is
- FD : File_Type;
-
- begin
- begin
- Create (FD, Out_File, Gnatmem_Tmp);
- exception
- when others =>
- Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp);
- GNAT.OS_Lib.OS_Exit (1);
- end;
-
- declare
- TTY : constant String := Get_Current_TTY;
- begin
- if TTY'Length > 0 then
- Put_Line (FD, "tty " & TTY);
- end if;
- end;
-
- if Cross_Case then
- Put (FD, "target ");
- Put (FD, Target_Protocol (1 .. Target_Protocol_Len));
- Put (FD, " ");
- Put (FD, Argument (Target_Pos));
- New_Line (FD);
- Put (FD, "load ");
- Put_Line (FD, Argument (Exec_Pos));
-
- else
- -- In the native case, run the program before setting the
- -- breakpoints so that gnatmem will also work with shared
- -- libraries.
-
- Put_Line (FD, "set lang c");
- Put_Line (FD, "break main");
- Put_Line (FD, "set lang auto");
- Put (FD, "run");
- for J in Exec_Pos + 1 .. Argc loop
- Put (FD, " ");
- Put (FD, Argument (J));
- end loop;
- New_Line (FD);
-
- -- At this point, gdb knows about __gnat_malloc and __gnat_free
- end if;
-
- -- Make sure that outputing long backtraces do not pause
-
- Put_Line (FD, "set height 0");
- Put_Line (FD, "set width 0");
-
- if Quiet_Mode then
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " finish");
- Put_Line (FD, " set $gm_addr = $");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- else
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set $gm_size = size");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " finish");
- Put_Line (FD, " set $gm_addr = $");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- end if;
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "break __gnat_free");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " finish");
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
-
- if Cross_Case then
- Put (FD, "run ");
- Put_Line (FD, Argument (Exec_Pos));
-
- if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then
- Put (FD, "unload ");
- Put_Line (FD, Argument (Exec_Pos));
- end if;
- else
- Put_Line (FD, "continue");
- end if;
-
- Close (FD);
- end Create_Gdb_Script;
-
---------------
-- Mem_Image --
---------------
function Mem_Image (X : Storage_Count) return String is
- Ks : constant Storage_Count := X / 1024;
- Megs : constant Storage_Count := Ks / 1024;
- Buff : String (1 .. 7);
+ Ks : constant Storage_Count := X / 1024;
+ Megs : constant Storage_Count := Ks / 1024;
+ Buff : String (1 .. 7);
begin
if Megs /= 0 then
else
Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
- return Buff (1 .. 4) & " Bytes";
+ return Buff (1 .. 4) & " Bytes";
end if;
end Mem_Image;
begin
New_Line;
Put ("GNATMEM ");
- Put (Gnat_Version_String);
- Put_Line (" Copyright 1997-2000 Free Software Foundation, Inc.");
+ Put_Line (Gnat_Version_String);
+ Put_Line ("Copyright 1997-2007, Free Software Foundation, Inc.");
New_Line;
- if Cross_Case then
- Put_Line (Command_Name
- & " [-q] [n] [-o file] target entry_point ...");
- Put_Line (Command_Name & " [-q] [n] [-i file]");
-
- else
- Put_Line ("GDB mode");
- Put_Line (" " & Command_Name
- & " [-q] [n] [-o file] program arg1 arg2 ...");
- Put_Line (" " & Command_Name
- & " [-q] [n] [-i file]");
- New_Line;
- Put_Line ("GMEM mode");
- Put_Line (" " & Command_Name
- & " [-q] [n] -i gmem.out program arg1 arg2 ...");
- New_Line;
- end if;
-
+ Put_Line ("Usage: gnatmem switches [depth] exename");
+ New_Line;
+ Put_Line (" depth backtrace depth to take into account, default is"
+ & Integer'Image (BT_Depth));
+ Put_Line (" exename the name of the executable to be analyzed");
+ New_Line;
+ Put_Line ("Switches:");
+ Put_Line (" -b n same as depth parameter");
+ Put_Line (" -i file read the allocation log from specific file");
+ Put_Line (" default is gmem.out in the current directory");
+ Put_Line (" -m n masks roots with less than n leaks, default is 1");
+ Put_Line (" specify 0 to see even released allocation roots");
Put_Line (" -q quiet, minimum output");
- Put_Line (" n number of frames for allocation root backtraces");
- Put_Line (" default is 1.");
- Put_Line (" -o file save gdb output in 'file' and process data");
- Put_Line (" post mortem. also keep the gdb script around");
- Put_Line (" -i file don't run gdb output. Do only post mortem");
- Put_Line (" processing from file");
+ Put_Line (" -s order sort allocation roots according to an order of");
+ Put_Line (" sort criteria");
GNAT.OS_Lib.OS_Exit (1);
end Usage;
-----------------------
procedure Process_Arguments is
- Arg : Integer;
-
- procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False);
- -- Check that Argument (Arg_Pos) is an existing file if For_Creat is
- -- false or if it is possible to create it if For_Creat is true
-
- procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False) is
- Name : aliased constant String := Argument (Arg_Pos) & ASCII.NUL;
- X : int;
-
- begin
- if For_Creat then
- FD := fopen (Name'Address, Mode_W'Address);
- else
- FD := fopen (Name'Address, Mode_R'Address);
- end if;
-
- if FD = NULL_Stream then
- New_Line;
- if For_Creat then
- Put_Line ("Cannot create file : " & Argument (Arg_Pos));
- else
- Put_Line ("Cannot locate file : " & Argument (Arg_Pos));
- end if;
- New_Line;
- Usage;
- else
- X := fclose (FD);
- end if;
- end Check_File;
-
- -- Start of processing for Process_Arguments
-
begin
+ -- Parse the options first
- -- Is it a cross version?
-
- declare
- Std_Name : constant String := "gnatmem";
- Name : constant String := Command_Name;
- End_Pref : constant Integer := Name'Last - Std_Name'Length;
-
- begin
- if Name'Length > Std_Name'Length + 9
- and then
- Name (End_Pref + 1 .. Name'Last) = Std_Name
- and then
- Name (End_Pref - 8 .. End_Pref) = "-vxworks-"
- then
- Cross_Case := True;
-
- Target_Name_Len := End_Pref - 1;
- for J in reverse Name'First .. End_Pref - 1 loop
- if Name (J) = Dir_Sep then
- Target_Name_Len := Target_Name_Len - J;
- exit;
- end if;
- end loop;
-
- Target_Name (1 .. Target_Name_Len)
- := Name (End_Pref - Target_Name_Len .. End_Pref - 1);
-
- if Target_Name (1 .. 5) = "alpha" then
- Target_Protocol (1 .. 7) := "vxworks";
- Target_Protocol_Len := 7;
- else
- Target_Protocol (1 .. 3) := "wtx";
- Target_Protocol_Len := 3;
- end if;
- end if;
- end;
-
- Arg := 1;
-
- if Argc < Arg then
- Usage;
- end if;
-
- -- Deal with "-q"
-
- if Argument (Arg) = "-q" then
-
- Quiet_Mode := True;
- Arg := Arg + 1;
-
- if Argc < Arg then
- Usage;
- end if;
- end if;
-
- -- Deal with back trace depth
-
- if Argument (Arg) (1) in '0' .. '9' then
- begin
- BT_Depth := Integer'Value (Argument (Arg));
- exception
- when others =>
- Usage;
- end;
-
- Arg := Arg + 1;
+ loop
+ case Getopt ("b: dd m: i: q s:") is
+ when ASCII.Nul => exit;
- if Argc < Arg then
- Usage;
- end if;
- end if;
+ when 'b' =>
+ begin
+ BT_Depth := Natural'Value (Parameter);
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- -- Deal with "-o file" or "-i file"
+ when 'd' =>
+ Dump_Log_Mode := True;
- while Arg <= Argc and then Argument (Arg) (1) = '-' loop
- Arg := Arg + 1;
+ when 'm' =>
+ begin
+ Minimum_Nb_Leaks := Natural'Value (Parameter);
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- if Argc < Arg then
- Usage;
- end if;
+ when 'i' =>
+ Log_Name := new String'(Parameter);
- case Argument (Arg - 1) (2) is
- when 'o' =>
- Check_File (Arg, For_Creat => True);
- File_Pos := Arg;
+ when 'q' =>
+ Quiet_Mode := True;
- when 'i' =>
- Check_File (Arg);
- File_Pos := Arg;
- Run_Gdb := False;
- if Gmem_Initialize (Argument (Arg)) then
- Gmem_Mode := True;
- end if;
+ when 's' =>
+ declare
+ S : constant String (Sort_Order'Range) := Parameter;
+ begin
+ for J in Sort_Order'Range loop
+ if S (J) = 'n' or else
+ S (J) = 'w' or else
+ S (J) = 'h'
+ then
+ Sort_Order (J) := S (J);
+ else
+ Put_Line ("Invalid sort criteria string.");
+ GNAT.OS_Lib.OS_Exit (1);
+ end if;
+ end loop;
+ end;
when others =>
- Put_Line ("Unknown option : " & Argument (Arg));
- Usage;
+ null;
end case;
-
- Arg := Arg + 1;
-
- if Argc < Arg and then Run_Gdb then
- Usage;
- end if;
end loop;
- -- In the cross case, we first get the target
-
- if Cross_Case then
- Target_Pos := Arg;
- Arg := Arg + 1;
+ -- Set default log file if -i hasn't been specified
- if Argc < Arg and then Run_Gdb then
- Usage;
- end if;
+ if Log_Name = null then
+ Log_Name := new String'("gmem.out");
end if;
- -- Now all the following arguments are to be passed to gdb
+ -- Get the optional backtrace length and program name
- if Run_Gdb then
- Exec_Pos := Arg;
- Check_File (Exec_Pos);
+ declare
+ Str1 : constant String := GNAT.Command_Line.Get_Argument;
+ Str2 : constant String := GNAT.Command_Line.Get_Argument;
- elsif Gmem_Mode then
- if Arg > Argc then
+ begin
+ if Str1 = "" then
Usage;
- else
- Exec_Pos := Arg;
- Check_File (Exec_Pos);
- Gmem_A2l_Initialize (Argument (Exec_Pos));
end if;
- -- ... in other cases further arguments are disallowed
-
- elsif Arg <= Argc then
- Usage;
- end if;
- end Process_Arguments;
-
- ---------------
- -- Read_Next --
- ---------------
-
- function Read_Next return Gdb_Output_Elmt is
- Max_Line : constant Integer := 100;
- Line : String (1 .. Max_Line);
- Last : Integer := 0;
+ if Str2 = "" then
+ Program_Name := new String'(Str1);
+ else
+ BT_Depth := Natural'Value (Str1);
+ Program_Name := new String'(Str2);
+ end if;
- Curs1, Curs2 : Integer;
- Separator : constant Character := '^';
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- function Next_Separator return Integer;
- -- Return the index of the next separator after Curs1 in Line
+ -- Ensure presence of executable suffix in Program_Name
- function Next_Separator return Integer is
- Curs : Integer := Curs1;
+ declare
+ Suffix : String_Access := Get_Executable_Suffix;
+ Tmp : String_Access;
begin
- loop
- if Curs > Last then
- raise Gdb_Output_Format_Error;
+ if Suffix.all /= ""
+ and then
+ Program_Name.all
+ (Program_Name.all'Last - Suffix.all'Length + 1 ..
+ Program_Name.all'Last) /= Suffix.all
+ then
+ Tmp := new String'(Program_Name.all & Suffix.all);
+ Free (Program_Name);
+ Program_Name := Tmp;
+ end if;
- elsif Line (Curs) = Separator then
- return Curs;
- end if;
+ Free (Suffix);
- Curs := Curs + 1;
- end loop;
- end Next_Separator;
+ -- Search the executable on the path. If not found in the PATH, we
+ -- default to the current directory. Otherwise, libaddr2line will
+ -- fail with an error:
- -- Start of processing for Read_Next
+ -- (null): Bad address
- begin
- Line (1) := ' ';
+ Tmp := Locate_Exec_On_Path (Program_Name.all);
- loop
- if Gmem_Mode then
- Gmem_Read_Next (Line, Last);
- else
- Get_Line (FT, Line, Last);
+ if Tmp = null then
+ Tmp := new String'('.' & Directory_Separator & Program_Name.all);
end if;
- if Line (1 .. 14) = "Program exited" then
- return Eof;
-
- elsif Line (1 .. 5) = "ALLOC" then
- -- ALLOC ^ <size> ^0x <addr> ^
+ Free (Program_Name);
+ Program_Name := Tmp;
+ end;
- -- Read the size
+ if not Is_Regular_File (Log_Name.all) then
+ Put_Line ("Couldn't find " & Log_Name.all);
+ GNAT.OS_Lib.OS_Exit (1);
+ end if;
- Curs1 := 7;
- Curs2 := Next_Separator - 1;
+ if not Gmem_Initialize (Log_Name.all) then
+ Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
+ GNAT.OS_Lib.OS_Exit (1);
+ end if;
- if not Quiet_Mode then
- Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2));
- end if;
+ if not Is_Regular_File (Program_Name.all) then
+ Put_Line ("Couldn't find " & Program_Name.all);
+ end if;
- -- Read the address, skip "^0x"
+ Gmem_A2l_Initialize (Program_Name.all);
- Curs1 := Curs2 + 4;
- Curs2 := Next_Separator - 1;
- Tmp_Address := Integer_Address'Value (
- "16#" & Line (Curs1 .. Curs2) & "#");
- return Alloc;
+ exception
+ when GNAT.Command_Line.Invalid_Switch =>
+ Ada.Text_IO.Put_Line ("Invalid switch : "
+ & GNAT.Command_Line.Full_Switch);
+ Usage;
+ end Process_Arguments;
- elsif Line (1 .. 5) = "DEALL" then
- -- DEALL ^ 0x <addr> ^
+ -- Local variables
- -- Read the address, skip "^0x"
-
- Curs1 := 9;
- Curs2 := Next_Separator - 1;
- Tmp_Address := Integer_Address'Value (
- "16#" & Line (Curs1 .. Curs2) & "#");
- return Deall;
- end if;
- end loop;
- exception
- when End_Error =>
- New_Line;
- Put_Line ("### incorrect user program termination detected.");
- Put_Line (" following data may not be meaningful");
- New_Line;
- return Eof;
- end Read_Next;
+ Cur_Elmt : Storage_Elmt;
+ Buff : String (1 .. 16);
-- Start of processing for Gnatmem
begin
Process_Arguments;
- if Run_Gdb then
- Create_Gdb_Script;
- end if;
+ if Dump_Log_Mode then
+ Put_Line ("Full dump of dynamic memory operations history");
+ Put_Line ("----------------------------------------------");
- -- Now we start the gdb session using the following syntax
-
- -- gdb --nx --nw -batch -x gnatmem.tmp
-
- -- If there is a -o option we redirect the gdb output in the specified
- -- file, otherwise we just read directly from a pipe.
-
- if File_Pos /= 0 then
declare
- Name : aliased String := Argument (File_Pos) & ASCII.NUL;
+ function CTime (Clock : Address) return Address;
+ pragma Import (C, CTime, "ctime");
- begin
- if Run_Gdb then
- if Cross_Case then
- declare
- Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
- & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & " > "
- & Name;
- begin
- System_Cmd (Cmd'Address);
- end;
- else
+ Int_T0 : Integer := Integer (T0);
+ CTime_Addr : constant Address := CTime (Int_T0'Address);
- declare
- Cmd : aliased String
- := "gdb --nx --nw " & Argument (Exec_Pos)
- & " -batch -x " & Gnatmem_Tmp & " > "
- & Name;
- begin
- System_Cmd (Cmd'Address);
- end;
- end if;
- end if;
+ Buffer : String (1 .. 30);
+ for Buffer'Address use CTime_Addr;
- if not Gmem_Mode then
- FD := fopen (Name'Address, Mode_R'Address);
- end if;
+ begin
+ Put_Line ("Log started at T0 =" & Duration'Image (T0) & " ("
+ & Buffer (1 .. 24) & ")");
end;
-
- else
- if Cross_Case then
- declare
- Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
- & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & ASCII.NUL;
- begin
- FD := popen (Cmd'Address, Mode_R'Address);
- end;
- else
- declare
- Cmd : aliased String := "gdb --nx --nw " & Argument (Exec_Pos)
- & " -batch -x " & Gnatmem_Tmp & ASCII.NUL;
-
- begin
- FD := popen (Cmd'Address, Mode_R'Address);
- end;
- end if;
- end if;
-
- -- Open the FD file as a regular Text_IO file
-
- if not Gmem_Mode then
- Ada.Text_IO.C_Streams.Open (FT, In_File, FD);
end if;
- -- Main loop analysing the data generated by the debugger
- -- for each allocation, the backtrace is kept and stored in a htable
- -- whose entry is the address. Fore ach deallocation, we look for the
+ -- Main loop analysing the data generated by the instrumented routines.
+ -- For each allocation, the backtrace is kept and stored in a htable
+ -- whose entry is the address. For each deallocation, we look for the
-- corresponding allocation and cancel it.
Main : loop
- case Read_Next is
- when EOF =>
+ Cur_Elmt := Read_Next;
+
+ case Cur_Elmt.Elmt is
+ when '*' =>
exit Main;
- when Alloc =>
+ when 'A' =>
+
+ -- Read the corresponding back trace
- -- Update global counters if the allocated size is meaningful
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
if Quiet_Mode then
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Nb_Root := Nb_Root + 1;
end if;
+
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
- Address_HTable.Set (Tmp_Address, Tmp_Alloc);
+ Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
- elsif Tmp_Size > 0 then
+ elsif Cur_Elmt.Size > 0 then
- Global_Alloc_Size := Global_Alloc_Size + Tmp_Size;
+ -- Update global counters if the allocated size is meaningful
+
+ Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
Global_Nb_Alloc := Global_Nb_Alloc + 1;
if Global_High_Water_Mark < Global_Alloc_Size then
Global_High_Water_Mark := Global_Alloc_Size;
end if;
- -- Read the corresponding back trace
-
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
-
-- Update the number of allocation root if this is a new one
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
-- Update allocation root specific counters
Set_Alloc_Size (Tmp_Alloc.Root,
- Alloc_Size (Tmp_Alloc.Root) + Tmp_Size);
+ Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
- if High_Water_Mark (Tmp_Alloc.Root)
- < Alloc_Size (Tmp_Alloc.Root)
+ if High_Water_Mark (Tmp_Alloc.Root) <
+ Alloc_Size (Tmp_Alloc.Root)
then
Set_High_Water_Mark (Tmp_Alloc.Root,
Alloc_Size (Tmp_Alloc.Root));
-- Associate this allocation root to the allocated address
- Tmp_Alloc.Size := Tmp_Size;
- Address_HTable.Set (Tmp_Address, Tmp_Alloc);
+ Tmp_Alloc.Size := Cur_Elmt.Size;
+ Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
- -- non meaninful output, just consumes the backtrace
-
- else
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
end if;
- when Deall =>
+ when 'D' =>
-- Get the corresponding Dealloc_Size and Root
- Tmp_Alloc := Address_HTable.Get (Tmp_Address);
+ Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
if Tmp_Alloc.Root = No_Root_Id then
-- There was no prior allocation at this address, something is
- -- very wrong. Mark this allocation root as problematic a
+ -- very wrong. Mark this allocation root as problematic.
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
if not Quiet_Mode then
Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
end if;
+
Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
-- Update allocation root specific counters
Set_Alloc_Size (Tmp_Alloc.Root,
Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
end if;
+
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
- -- update the number of allocation root if this one disappear
+ -- Update the number of allocation root if this one disappears
- if Nb_Alloc (Tmp_Alloc.Root) = 0 then
+ if Nb_Alloc (Tmp_Alloc.Root) = 0
+ and then Minimum_Nb_Leaks > 0 then
Nb_Root := Nb_Root - 1;
end if;
- -- De-associate the deallocated address
+ -- Deassociate the deallocated address
- Address_HTable.Remove (Tmp_Address);
+ Address_HTable.Remove (Cur_Elmt.Address);
end if;
+
+ when others =>
+ raise Program_Error;
end case;
- end loop Main;
- -- We can get rid of the temp file now
+ if Dump_Log_Mode then
+ case Cur_Elmt.Elmt is
+ when 'A' =>
+ Put ("ALLOC");
+ Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
+ Put (Buff);
+ Int_IO.Put (Buff (1 .. 8), Integer (Cur_Elmt.Size));
+ Put (Buff (1 .. 8) & " bytes at moment T0 +");
+ Put_Line (Duration'Image (Cur_Elmt.Timestamp - T0));
+
+ when 'D' =>
+ Put ("DEALL");
+ Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
+ Put (Buff);
+ Put_Line (" at moment T0 +"
+ & Duration'Image (Cur_Elmt.Timestamp - T0));
+ when others =>
+ raise Program_Error;
+ end case;
- if Run_Gdb and then File_Pos = 0 then
- declare
- X : int;
- begin
- X := unlink (Gnatmem_Tmp'Address);
- end;
- end if;
+ Print_BT (Tmp_Alloc.Root);
+ end if;
+
+ end loop Main;
-- Print out general information about overall allocation
end if;
-- Print out the back traces corresponding to potential leaks in order
- -- greatest number of non-deallocated allocations
+ -- greatest number of non-deallocated allocations.
Print_Back_Traces : declare
type Root_Array is array (Natural range <>) of Root_Id;
- Leaks : Root_Array (0 .. Nb_Root);
+ type Access_Root_Array is access Root_Array;
+
+ Leaks : constant Access_Root_Array :=
+ new Root_Array (0 .. Nb_Root);
Leak_Index : Natural := 0;
- Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
+ Bogus_Dealls : constant Access_Root_Array :=
+ new Root_Array (1 .. Nb_Wrong_Deall);
Deall_Index : Natural := 0;
+ Nb_Alloc_J : Natural := 0;
procedure Move (From : Natural; To : Natural);
- function Lt (Op1, Op2 : Natural) return Boolean;
- package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
+
+ ----------
+ -- Move --
+ ----------
procedure Move (From : Natural; To : Natural) is
begin
Leaks (To) := Leaks (From);
end Move;
+ --------
+ -- Lt --
+ --------
+
function Lt (Op1, Op2 : Natural) return Boolean is
+
+ function Apply_Sort_Criterion (S : Character) return Integer;
+ -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
+ -- smaller than, equal, or greater than Op2 according to criterion.
+
+ --------------------------
+ -- Apply_Sort_Criterion --
+ --------------------------
+
+ function Apply_Sort_Criterion (S : Character) return Integer is
+ LOp1, LOp2 : Integer;
+
+ begin
+ case S is
+ when 'n' =>
+ LOp1 := Nb_Alloc (Leaks (Op1));
+ LOp2 := Nb_Alloc (Leaks (Op2));
+
+ when 'w' =>
+ LOp1 := Integer (Alloc_Size (Leaks (Op1)));
+ LOp2 := Integer (Alloc_Size (Leaks (Op2)));
+
+ when 'h' =>
+ LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
+ LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
+
+ when others =>
+ return 0; -- Can't actually happen
+ end case;
+
+ if LOp1 < LOp2 then
+ return -1;
+ elsif LOp1 > LOp2 then
+ return 1;
+ else
+ return 0;
+ end if;
+
+ exception
+ when Constraint_Error =>
+ return 0;
+ end Apply_Sort_Criterion;
+
+ -- Local Variables
+
+ Result : Integer;
+
+ -- Start of processing for Lt
+
begin
- if Nb_Alloc (Leaks (Op1)) > Nb_Alloc (Leaks (Op2)) then
- return True;
- elsif Nb_Alloc (Leaks (Op1)) = Nb_Alloc (Leaks (Op2)) then
- return Alloc_Size (Leaks (Op1)) > Alloc_Size (Leaks (Op2));
- else
- return False;
- end if;
+ for S in Sort_Order'Range loop
+ Result := Apply_Sort_Criterion (Sort_Order (S));
+ if Result = -1 then
+ return False;
+ elsif Result = 1 then
+ return True;
+ end if;
+ end loop;
+ return False;
end Lt;
-- Start of processing for Print_Back_Traces
begin
- -- Transfer all the relevant Roots in the Leaks and a
- -- Bogus_Deall arrays
+ -- Transfer all the relevant Roots in the Leaks and a Bogus_Deall arrays
Tmp_Alloc.Root := Get_First;
while Tmp_Alloc.Root /= No_Root_Id loop
- if Nb_Alloc (Tmp_Alloc.Root) = 0 then
+ if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_Nb_Leaks > 0 then
null;
elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
end if;
for J in 1 .. Bogus_Dealls'Last loop
- Print_BT (Bogus_Dealls (J));
+ Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
New_Line;
end loop;
end if;
-- Print out all allocation Leaks
- if Nb_Root > 0 then
+ if Leak_Index > 0 then
-- Sort the Leaks so that potentially important leaks appear first
- Root_Sort.Sort (Nb_Root);
+ Root_Sort.Sort (Leak_Index);
+
+ for J in 1 .. Leak_Index loop
+ Nb_Alloc_J := Nb_Alloc (Leaks (J));
+
+ if Nb_Alloc_J >= Minimum_Nb_Leaks then
+ if Quiet_Mode then
+ if Nb_Alloc_J = 1 then
+ Put_Line (" 1 leak at :");
+ else
+ Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
+ end if;
- for J in 1 .. Leaks'Last loop
- if Quiet_Mode then
- if Nb_Alloc (Leaks (J)) = 1 then
- Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
- & " leak at :");
else
- Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
- & " leaks at :");
- end if;
- else
- Put_Line ("Allocation Root #" & Integer'Image (J));
- Put_Line ("-------------------");
+ Put_Line ("Allocation Root #" & Integer'Image (J));
+ Put_Line ("-------------------");
- Put (" Number of non freed allocations :");
- Ada.Integer_Text_IO.Put (Nb_Alloc (Leaks (J)), 4);
- New_Line;
+ Put (" Number of non freed allocations :");
+ Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
+ New_Line;
- Put_Line (" Final Water Mark (non freed mem) :"
- & Mem_Image (Alloc_Size (Leaks (J))));
+ Put_Line
+ (" Final Water Mark (non freed mem) :"
+ & Mem_Image (Alloc_Size (Leaks (J))));
- Put_Line (" High Water Mark :"
- & Mem_Image (High_Water_Mark (Leaks (J))));
+ Put_Line
+ (" High Water Mark :"
+ & Mem_Image (High_Water_Mark (Leaks (J))));
- Put_Line (" Backtrace :");
+ Put_Line (" Backtrace :");
+ end if;
+
+ Print_BT (Leaks (J), Short => Quiet_Mode);
+ New_Line;
end if;
- Print_BT (Leaks (J));
- New_Line;
end loop;
end if;
end Print_Back_Traces;
-
end Gnatmem;
OSDN Git Service
