Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

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