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
function Get_Current_TTY return String;
function popen (File, Mode : System.Address) return FILEs;
pragma Import (C, popen, "popen");
procedure System_Cmd (X : System.Address);
pragma Import (C, System_Cmd, "system");
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");
Dir_Sep : constant Character := '/';
type Gdb_Output_Elmt is (Eof, Alloc, Deall);
Gdb_Output_Format_Error : exception;
function Read_Next return Gdb_Output_Elmt;
procedure Create_Gdb_Script;
function Mem_Image (X : Storage_Count) return String;
procedure Process_Arguments;
procedure Usage;
function Gmem_Initialize (Dumpname : String) return Boolean;
procedure Gmem_A2l_Initialize (Exename : String);
procedure Gmem_Read_Next (Buf : out String; Last : out Natural);
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;
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;
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;
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;
return "";
end Get_Current_TTY;
function H (A : Integer_Address) return Address_Range is
begin
return Address_Range (A mod Integer_Address (Address_Range'Last));
end H;
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
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);
end if;
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, " up");
Put_Line (FD, " set $gm_addr = $pc");
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, " up");
Put_Line (FD, " set $gm_addr = $pc");
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 + 1));
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, " up");
Put (FD, " backtrace");
if BT_Depth /= 0 then
Put (FD, Integer'Image (BT_Depth + 1));
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;
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;
procedure Usage is
begin
New_Line;
Put ("GNATMEM ");
Put (Gnat_Version_String);
Put_Line (" Copyright 1997-2002 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;
procedure Process_Arguments is
Arg : Integer;
procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False);
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;
begin
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;
if Argument (Arg) = "-q" then
Quiet_Mode := True;
Arg := Arg + 1;
if Argc < Arg then
Usage;
end if;
end if;
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;
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;
if Cross_Case then
Target_Pos := Arg;
Arg := Arg + 1;
if Argc < Arg and then Run_Gdb then
Usage;
end if;
end if;
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;
elsif Arg <= Argc then
Usage;
end if;
end Process_Arguments;
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;
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;
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
Curs1 := 7;
Curs2 := Next_Separator - 1;
if not Quiet_Mode then
Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2));
end if;
Curs1 := Curs2 + 4;
Curs2 := Next_Separator - 1;
Tmp_Address := Integer_Address'Value (
"16#" & Line (Curs1 .. Curs2) & "#");
return Alloc;
elsif Line (1 .. 5) = "DEALL" then
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;
begin
Process_Arguments;
if Run_Gdb then
Create_Gdb_Script;
end if;
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;
if not Gmem_Mode then
Ada.Text_IO.C_Streams.Open (FT, In_File, FD);
end if;
Main : loop
case Read_Next is
when EOF =>
exit Main;
when Alloc =>
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;
Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Nb_Root := Nb_Root + 1;
end if;
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;
Tmp_Alloc.Size := Tmp_Size;
Address_HTable.Set (Tmp_Address, Tmp_Alloc);
else
Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
end if;
when Deall =>
Tmp_Alloc := Address_HTable.Get (Tmp_Address);
if Tmp_Alloc.Root = No_Root_Id then
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
if not Quiet_Mode then
Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
end if;
Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
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);
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Nb_Root := Nb_Root - 1;
end if;
Address_HTable.Remove (Tmp_Address);
end if;
end case;
end loop Main;
if Run_Gdb and then File_Pos = 0 then
declare
X : int;
begin
X := unlink (Gnatmem_Tmp'Address);
end;
end if;
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_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;
begin
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;
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;
if Nb_Root > 0 then
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;