------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T M E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1997-2008, 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 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 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. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- GNATMEM is a utility that tracks memory leaks. It is based on a simple -- idea: -- - 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. -- 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, amount of memory allocated, high water mark, etc.) with Ada.Float_Text_IO; with Ada.Integer_Text_IO; 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 package Int_IO renames Ada.Integer_Text_IO; ------------------------ -- Other Declarations -- ------------------------ 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 Program_Name : String_Access; -- Holds the name of the user executable 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, Kilobytes 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 ----------------------------------- -- 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; -- 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 Duration; pragma Import (C, Initialize, "__gnat_gmem_initialize"); S : aliased String := Dumpname & ASCII.NUL; begin 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; --------------- -- Read_Next -- --------------- 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; ------- -- H -- ------- function H (A : Integer_Address) return Address_Range is begin return Address_Range (A mod Integer_Address (Address_Range'Last)); end H; --------------- -- 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_Line (Gnat_Version_String); Put_Line ("Copyright 1997-2007, 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; ----------------------- -- Process_Arguments -- ----------------------- procedure Process_Arguments is begin -- Parse the options first loop case Getopt ("b: dd m: i: q s:") is when ASCII.NUL => exit; when 'b' => begin BT_Depth := Natural'Value (Parameter); exception when Constraint_Error => Usage; end; when 'd' => Dump_Log_Mode := True; 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; -- Set default log file if -i hasn't been specified if Log_Name = null then Log_Name := new String'("gmem.out"); end if; -- Get the optional backtrace length and program name 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; -- Ensure presence of executable suffix in Program_Name 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); -- 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: -- (null): Bad address 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; -- Local variables Cur_Elmt : Storage_Elmt; Buff : String (1 .. 16); -- Start of processing for Gnatmem begin Process_Arguments; if Dump_Log_Mode then Put_Line ("Full dump of dynamic memory operations history"); Put_Line ("----------------------------------------------"); declare function CTime (Clock : Address) return Address; pragma Import (C, CTime, "ctime"); Int_T0 : Integer := Integer (T0); CTime_Addr : constant Address := CTime (Int_T0'Address); Buffer : String (1 .. 30); for Buffer'Address use CTime_Addr; begin Put_Line ("Log started at T0 =" & Duration'Image (T0) & " (" & Buffer (1 .. 24) & ")"); end; end if; -- 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 Cur_Elmt := Read_Next; case Cur_Elmt.Elmt is when '*' => exit Main; when 'A' => -- Read the corresponding back trace Tmp_Alloc.Root := Read_BT (BT_Depth); if Quiet_Mode then 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 -- 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; -- 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) + 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; -- Associate this allocation root to the allocated address Tmp_Alloc.Size := Cur_Elmt.Size; Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); end if; when 'D' => -- Get the corresponding Dealloc_Size and Root 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. 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 -- 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 disappears if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_Nb_Leaks > 0 then Nb_Root := Nb_Root - 1; end if; -- Deassociate the deallocated address Address_HTable.Remove (Cur_Elmt.Address); end if; when others => raise Program_Error; end case; 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; Print_BT (Tmp_Alloc.Root); end if; end loop Main; -- 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; 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 : 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); ---------- -- 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 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 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; -- 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), Short => Quiet_Mode); New_Line; end loop; end if; -- Print out all allocation Leaks if Leak_Index > 0 then -- Sort the Leaks so that potentially important leaks appear first 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; 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;