| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T M E M -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1997-2005, 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- -- |
| -- 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, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- 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 dealocation (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 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 |
| |
| ------------------------ |
| -- 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; |
| end record; |
| -- This needs a comment ??? |
| |
| Log_Name, Program_Name : String_Access; |
| -- These need comments, and should be on separate lines ??? |
| |
| 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; |
| |
| -- The following need comments ??? |
| |
| 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; |
| |
| ------------------------------ |
| -- 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 -- |
| -------------------------------- |
| |
| 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; |
| |
| ------- |
| -- 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-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; |
| |
| ----------------------- |
| -- Process_Arguments -- |
| ----------------------- |
| |
| procedure Process_Arguments is |
| begin |
| -- Parse the options first |
| |
| 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; |
| |
| -- 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; |
| |
| Cur_Elmt : Storage_Elmt; |
| |
| -- Start of processing for Gnatmem |
| |
| begin |
| Process_Arguments; |
| |
| -- 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' => |
| |
| -- Update global counters if the allocated size is meaningful |
| |
| 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; |
| |
| -- Read the corresponding back trace |
| |
| Tmp_Alloc.Root := Read_BT (BT_Depth); |
| |
| -- 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); |
| |
| -- non meaningful output, just consumes the backtrace |
| |
| else |
| Tmp_Alloc.Root := Read_BT (BT_Depth); |
| 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 disappear |
| |
| 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 |
| |
| Address_HTable.Remove (Cur_Elmt.Address); |
| end if; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| 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; |
| 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; |
| -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is |
| -- smaller than, equal, or greater than Op2 according to 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; |
| |
| 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 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 |
| 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; |
