Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         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;