44d6a70684
* 5ataprop.adb, 5atpopsp.adb, 5ftaprop.adb, 5gmastop.adb, 5gtaprop.adb, 5htaprop.adb, 5itaprop.adb, 5lintman.adb, 5omastop.adb, 5oosinte.adb, 5otaprop.adb, 5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb, 5wintman.adb, 5wtaprop.adb, 5zinterr.adb, 5ztaprop.adb, 6vcstrea.adb, 7sintman.adb, 7staprop.adb, 9drpc.adb, ChangeLog, Makefile.in, a-except.adb, a-tags.ads, a-tasatt.adb, a-teioed.adb, a-textio.ads, a-witeio.ads, a-wtedit.adb, ali.ads, comperr.adb, cstand.adb, einfo.ads, errout.adb, exp_ch11.adb, exp_ch2.adb, exp_ch3.adb, exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch9.adb, exp_util.adb, exp_util.ads, fname-uf.adb, g-cgi.ads, g-exctra.ads, g-expect.ads, g-regist.adb, g-spipat.adb, gnatchop.adb, gnatlink.adb, gnatls.adb, gnatmain.adb, gnatmem.adb, init.c, make.adb, make.ads, mdlltool.adb, nlists.ads, osint.ads, par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb, par.adb, repinfo.adb, s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-finimp.adb, s-finimp.ads, s-interr.adb, s-secsta.ads, s-shasto.ads, s-stalib.adb, s-stalib.ads, s-tarest.ads, s-tasdeb.adb, s-tassta.adb, s-tassta.ads, s-vaflop.ads, scans.ads, scn.adb, sem.ads, sem_aggr.adb, sem_attr.adb, sem_case.ads, sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, sem_ch3.ads, sem_ch5.adb, sem_ch7.adb, sem_ch8.adb, sem_ch8.ads, sem_type.adb, sem_util.ads, sinfo.ads, sprint.adb, tbuild.ads, types.ads, utils.c, xeinfo.adb: Fix spelling errors. From-SVN: r48055
1059 lines
33 KiB
Ada
1059 lines
33 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G N A T M E M --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- $Revision: 1.2 $
|
|
-- --
|
|
-- Copyright (C) 1997-2001, Ada Core Technologies, Inc. --
|
|
-- --
|
|
-- 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- --
|
|
-- 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. --
|
|
-- --
|
|
-- 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). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
-- 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.
|
|
-- 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.
|
|
--
|
|
-- 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.).
|
|
|
|
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 System; use System;
|
|
with System.Storage_Elements; use System.Storage_Elements;
|
|
|
|
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 := '/';
|
|
|
|
------------------------
|
|
-- 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;
|
|
|
|
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.
|
|
|
|
procedure Create_Gdb_Script;
|
|
-- Create the GDB script and save it in a temporary 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.
|
|
|
|
procedure Process_Arguments;
|
|
-- Read command line arguments;
|
|
|
|
procedure Usage;
|
|
-- Prints out the option help
|
|
|
|
function Gmem_Initialize (Dumpname : String) return Boolean;
|
|
-- Opens the file represented by Dumpname and prepares it for
|
|
-- work. Returns False if the file does not have the correct format, True
|
|
-- otherwise.
|
|
|
|
procedure Gmem_A2l_Initialize (Exename : String);
|
|
-- 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 --
|
|
-----------------------------------
|
|
|
|
type Allocation is record
|
|
Root : Root_Id;
|
|
Size : Storage_Count;
|
|
end record;
|
|
|
|
type Address_Range is range 0 .. 4097;
|
|
function H (A : Integer_Address) return Address_Range;
|
|
No_Alloc : constant Allocation := (No_Root_Id, 0);
|
|
|
|
package Address_HTable is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => Address_Range,
|
|
Element => Allocation,
|
|
No_Element => No_Alloc,
|
|
Key => Integer_Address,
|
|
Hash => H,
|
|
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;
|
|
|
|
--------------------------------
|
|
-- GMEM functionality binding --
|
|
--------------------------------
|
|
|
|
function Gmem_Initialize (Dumpname : String) return Boolean is
|
|
function Initialize (Dumpname : System.Address) return Boolean;
|
|
pragma Import (C, Initialize, "__gnat_gmem_initialize");
|
|
S : aliased String := Dumpname & ASCII.NUL;
|
|
begin
|
|
return Initialize (S'Address);
|
|
end Gmem_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
|
|
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;
|
|
|
|
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;
|
|
|
|
-------
|
|
-- H --
|
|
-------
|
|
|
|
function H (A : Integer_Address) return Address_Range is
|
|
begin
|
|
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);
|
|
|
|
begin
|
|
if Megs /= 0 then
|
|
Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
|
|
return Buff & " Megabytes";
|
|
|
|
elsif Ks /= 0 then
|
|
Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
|
|
return Buff & " Kilobytes";
|
|
|
|
else
|
|
Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
|
|
return Buff (1 .. 4) & " Bytes";
|
|
end if;
|
|
end Mem_Image;
|
|
|
|
-----------
|
|
-- Usage --
|
|
-----------
|
|
|
|
procedure Usage is
|
|
begin
|
|
New_Line;
|
|
Put ("GNATMEM ");
|
|
Put (Gnat_Version_String);
|
|
Put_Line (" Copyright 1997-2000 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 (" -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");
|
|
GNAT.OS_Lib.OS_Exit (1);
|
|
end Usage;
|
|
|
|
-----------------------
|
|
-- Process_Arguments --
|
|
-----------------------
|
|
|
|
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
|
|
|
|
-- 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;
|
|
|
|
if Argc < Arg then
|
|
Usage;
|
|
end if;
|
|
end if;
|
|
|
|
-- Deal with "-o file" or "-i file"
|
|
|
|
while Arg <= Argc and then Argument (Arg) (1) = '-' loop
|
|
Arg := Arg + 1;
|
|
|
|
if Argc < Arg then
|
|
Usage;
|
|
end if;
|
|
|
|
case Argument (Arg - 1) (2) is
|
|
when 'o' =>
|
|
Check_File (Arg, For_Creat => True);
|
|
File_Pos := Arg;
|
|
|
|
when 'i' =>
|
|
Check_File (Arg);
|
|
File_Pos := Arg;
|
|
Run_Gdb := False;
|
|
if Gmem_Initialize (Argument (Arg)) then
|
|
Gmem_Mode := True;
|
|
end if;
|
|
|
|
when others =>
|
|
Put_Line ("Unknown option : " & Argument (Arg));
|
|
Usage;
|
|
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;
|
|
|
|
if Argc < Arg and then Run_Gdb then
|
|
Usage;
|
|
end if;
|
|
end if;
|
|
|
|
-- Now all the following arguments are to be passed to gdb
|
|
|
|
if Run_Gdb then
|
|
Exec_Pos := Arg;
|
|
Check_File (Exec_Pos);
|
|
|
|
elsif Gmem_Mode then
|
|
if Arg > Argc 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;
|
|
|
|
Curs1, Curs2 : Integer;
|
|
Separator : constant Character := '^';
|
|
|
|
function Next_Separator return Integer;
|
|
-- Return the index of the next separator after Curs1 in Line
|
|
|
|
function Next_Separator return Integer is
|
|
Curs : Integer := Curs1;
|
|
|
|
begin
|
|
loop
|
|
if Curs > Last then
|
|
raise Gdb_Output_Format_Error;
|
|
|
|
elsif Line (Curs) = Separator then
|
|
return Curs;
|
|
end if;
|
|
|
|
Curs := Curs + 1;
|
|
end loop;
|
|
end Next_Separator;
|
|
|
|
-- Start of processing for Read_Next
|
|
|
|
begin
|
|
Line (1) := ' ';
|
|
|
|
loop
|
|
if Gmem_Mode then
|
|
Gmem_Read_Next (Line, Last);
|
|
else
|
|
Get_Line (FT, Line, Last);
|
|
end if;
|
|
|
|
if Line (1 .. 14) = "Program exited" then
|
|
return Eof;
|
|
|
|
elsif Line (1 .. 5) = "ALLOC" then
|
|
-- ALLOC ^ <size> ^0x <addr> ^
|
|
|
|
-- Read the size
|
|
|
|
Curs1 := 7;
|
|
Curs2 := Next_Separator - 1;
|
|
|
|
if not Quiet_Mode then
|
|
Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2));
|
|
end if;
|
|
|
|
-- Read the address, skip "^0x"
|
|
|
|
Curs1 := Curs2 + 4;
|
|
Curs2 := Next_Separator - 1;
|
|
Tmp_Address := Integer_Address'Value (
|
|
"16#" & Line (Curs1 .. Curs2) & "#");
|
|
return Alloc;
|
|
|
|
elsif Line (1 .. 5) = "DEALL" then
|
|
-- DEALL ^ 0x <addr> ^
|
|
|
|
-- 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;
|
|
|
|
-- Start of processing for Gnatmem
|
|
|
|
begin
|
|
Process_Arguments;
|
|
|
|
if Run_Gdb then
|
|
Create_Gdb_Script;
|
|
end if;
|
|
|
|
-- 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;
|
|
|
|
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
|
|
|
|
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;
|
|
|
|
if not Gmem_Mode then
|
|
FD := fopen (Name'Address, Mode_R'Address);
|
|
end if;
|
|
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
|
|
-- corresponding allocation and cancel it.
|
|
|
|
Main : loop
|
|
case Read_Next is
|
|
when EOF =>
|
|
exit Main;
|
|
|
|
when Alloc =>
|
|
|
|
-- Update global counters if the allocated size is meaningful
|
|
|
|
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);
|
|
|
|
elsif Tmp_Size > 0 then
|
|
|
|
Global_Alloc_Size := Global_Alloc_Size + Tmp_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
|
|
Nb_Root := Nb_Root + 1;
|
|
end if;
|
|
|
|
-- Update allocation root specific counters
|
|
|
|
Set_Alloc_Size (Tmp_Alloc.Root,
|
|
Alloc_Size (Tmp_Alloc.Root) + Tmp_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)
|
|
then
|
|
Set_High_Water_Mark (Tmp_Alloc.Root,
|
|
Alloc_Size (Tmp_Alloc.Root));
|
|
end if;
|
|
|
|
-- Associate this allocation root to the allocated address
|
|
|
|
Tmp_Alloc.Size := Tmp_Size;
|
|
Address_HTable.Set (Tmp_Address, Tmp_Alloc);
|
|
|
|
-- non meaninful output, just consumes the backtrace
|
|
|
|
else
|
|
Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
|
|
end if;
|
|
|
|
when Deall =>
|
|
|
|
-- Get the corresponding Dealloc_Size and Root
|
|
|
|
Tmp_Alloc := Address_HTable.Get (Tmp_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
|
|
|
|
Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
|
|
|
|
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
|
|
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
|
|
Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
|
|
end if;
|
|
|
|
else
|
|
-- Update global counters
|
|
|
|
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
|
|
|
|
if not Quiet_Mode then
|
|
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
|
|
|
|
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
|
|
Nb_Root := Nb_Root - 1;
|
|
end if;
|
|
|
|
-- De-associate the deallocated address
|
|
|
|
Address_HTable.Remove (Tmp_Address);
|
|
end if;
|
|
end case;
|
|
end loop Main;
|
|
|
|
-- We can get rid of the temp file now
|
|
|
|
if Run_Gdb and then File_Pos = 0 then
|
|
declare
|
|
X : int;
|
|
begin
|
|
X := unlink (Gnatmem_Tmp'Address);
|
|
end;
|
|
end if;
|
|
|
|
-- Print out general information about overall allocation
|
|
|
|
if not Quiet_Mode then
|
|
Put_Line ("Global information");
|
|
Put_Line ("------------------");
|
|
|
|
Put (" Total number of allocations :");
|
|
Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
|
|
New_Line;
|
|
|
|
Put (" Total number of deallocations :");
|
|
Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
|
|
New_Line;
|
|
|
|
Put_Line (" Final Water Mark (non freed mem) :"
|
|
& Mem_Image (Global_Alloc_Size));
|
|
Put_Line (" High Water Mark :"
|
|
& Mem_Image (Global_High_Water_Mark));
|
|
New_Line;
|
|
end if;
|
|
|
|
-- Print out the back traces corresponding to potential leaks in order
|
|
-- 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);
|
|
Leak_Index : Natural := 0;
|
|
|
|
Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
|
|
Deall_Index : 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);
|
|
|
|
procedure Move (From : Natural; To : Natural) is
|
|
begin
|
|
Leaks (To) := Leaks (From);
|
|
end Move;
|
|
|
|
function Lt (Op1, Op2 : Natural) return Boolean is
|
|
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;
|
|
end Lt;
|
|
|
|
-- Start of processing for Print_Back_Traces
|
|
|
|
begin
|
|
-- 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
|
|
null;
|
|
|
|
elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
|
|
Deall_Index := Deall_Index + 1;
|
|
Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
|
|
|
|
else
|
|
Leak_Index := Leak_Index + 1;
|
|
Leaks (Leak_Index) := Tmp_Alloc.Root;
|
|
end if;
|
|
|
|
Tmp_Alloc.Root := Get_Next;
|
|
end loop;
|
|
|
|
-- Print out wrong deallocations
|
|
|
|
if Nb_Wrong_Deall > 0 then
|
|
Put_Line ("Releasing deallocated memory at :");
|
|
if not Quiet_Mode then
|
|
Put_Line ("--------------------------------");
|
|
end if;
|
|
|
|
for J in 1 .. Bogus_Dealls'Last loop
|
|
Print_BT (Bogus_Dealls (J));
|
|
New_Line;
|
|
end loop;
|
|
end if;
|
|
|
|
-- Print out all allocation Leaks
|
|
|
|
if Nb_Root > 0 then
|
|
|
|
-- Sort the Leaks so that potentially important leaks appear first
|
|
|
|
Root_Sort.Sort (Nb_Root);
|
|
|
|
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 (" Number of non freed allocations :");
|
|
Ada.Integer_Text_IO.Put (Nb_Alloc (Leaks (J)), 4);
|
|
New_Line;
|
|
|
|
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 (" Backtrace :");
|
|
end if;
|
|
Print_BT (Leaks (J));
|
|
New_Line;
|
|
end loop;
|
|
end if;
|
|
end Print_Back_Traces;
|
|
|
|
end Gnatmem;
|