with Gnatvsn; use Gnatvsn;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Float_Text_IO;
with Ada.Integer_Text_IO;
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 System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with Memroot; use Memroot;
procedure Gnatmem is
type Storage_Elmt is record
Elmt : Character;
Address : Integer_Address;
Size : Storage_Count;
end record;
Log_Name, Program_Name : String_Access;
function Read_Next return Storage_Elmt;
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);
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;
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;
Minimum_NB_Leaks : Integer := 1;
Tmp_Alloc : Allocation;
Quiet_Mode : Boolean := False;
Sort_Order : String (1 .. 3) := "nwh";
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;
function Read_Next return Storage_Elmt is
procedure Read_Next (buf : System.Address);
pragma Import (C, Read_Next, "__gnat_gmem_read_next");
S : Storage_Elmt;
begin
Read_Next (S'Address);
return S;
end Read_Next;
function H (A : Integer_Address) return Address_Range is
begin
return Address_Range (A mod Integer_Address (Address_Range'Last));
end H;
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_Line (Gnat_Version_String);
Put_Line ("Copyright 1997-2005 Free Software Foundation, Inc.");
New_Line;
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 (" -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
begin
loop
case Getopt ("b: m: i: q s:") is
when ASCII.Nul => exit;
when 'b' =>
begin
BT_Depth := Natural'Value (Parameter);
exception
when Constraint_Error =>
Usage;
end;
when 'm' =>
begin
Minimum_NB_Leaks := Natural'Value (Parameter);
exception
when Constraint_Error =>
Usage;
end;
when 'i' =>
Log_Name := new String'(Parameter);
when 'q' =>
Quiet_Mode := True;
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 =>
null;
end case;
end loop;
if Log_Name = null then
Log_Name := new String'("gmem.out");
end if;
declare
Str1 : constant String := GNAT.Command_Line.Get_Argument;
Str2 : constant String := GNAT.Command_Line.Get_Argument;
begin
if Str1 = "" then
Usage;
end if;
if Str2 = "" then
Program_Name := new String'(Str1);
else
BT_Depth := Natural'Value (Str1);
Program_Name := new String'(Str2);
end if;
exception
when Constraint_Error =>
Usage;
end;
declare
Suffix : String_Access := Get_Executable_Suffix;
Tmp : String_Access;
begin
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;
Free (Suffix);
Tmp := Locate_Exec_On_Path (Program_Name.all);
if Tmp = null then
Tmp := new String'('.' & Directory_Separator & Program_Name.all);
end if;
Free (Program_Name);
Program_Name := Tmp;
end;
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;
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 Is_Regular_File (Program_Name.all) then
Put_Line ("Couldn't find " & Program_Name.all);
end if;
Gmem_A2l_Initialize (Program_Name.all);
exception
when GNAT.Command_Line.Invalid_Switch =>
Ada.Text_IO.Put_Line ("Invalid switch : "
& GNAT.Command_Line.Full_Switch);
Usage;
end Process_Arguments;
Cur_Elmt : Storage_Elmt;
begin
Process_Arguments;
Main : loop
Cur_Elmt := Read_Next;
case Cur_Elmt.Elmt is
when '*' =>
exit Main;
when 'A' =>
if Quiet_Mode then
Tmp_Alloc.Root := Read_BT (BT_Depth);
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 (Cur_Elmt.Address, Tmp_Alloc);
elsif Cur_Elmt.Size > 0 then
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;
Tmp_Alloc.Root := Read_BT (BT_Depth);
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) + 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)
then
Set_High_Water_Mark (Tmp_Alloc.Root,
Alloc_Size (Tmp_Alloc.Root));
end if;
Tmp_Alloc.Size := Cur_Elmt.Size;
Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
else
Tmp_Alloc.Root := Read_BT (BT_Depth);
end if;
when 'D' =>
Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
if Tmp_Alloc.Root = No_Root_Id then
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);
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
and then Minimum_NB_Leaks > 0 then
Nb_Root := Nb_Root - 1;
end if;
Address_HTable.Remove (Cur_Elmt.Address);
end if;
when others =>
raise Program_Error;
end case;
end loop Main;
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;
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);
procedure Move (From : Natural; To : Natural) is
begin
Leaks (To) := Leaks (From);
end Move;
function Lt (Op1, Op2 : Natural) return Boolean is
function Apply_Sort_Criterion (S : Character) return Integer;
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; 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;
Result : Integer;
begin
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;
begin
Tmp_Alloc.Root := Get_First;
while Tmp_Alloc.Root /= No_Root_Id loop
if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 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), Short => Quiet_Mode);
New_Line;
end loop;
end if;
if Nb_Root > 0 then
Root_Sort.Sort (Nb_Root);
for J in 1 .. Leaks'Last 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;
else
Put_Line ("Allocation Root #" & Integer'Image (J));
Put_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
(" High Water Mark :"
& Mem_Image (High_Water_Mark (Leaks (J))));
Put_Line (" Backtrace :");
end if;
Print_BT (Leaks (J), Short => Quiet_Mode);
New_Line;
end if;
end loop;
end if;
end Print_Back_Traces;
end Gnatmem;