aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.2.1/gcc/ada/gnatmem.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.2.1/gcc/ada/gnatmem.adb')
-rw-r--r--gcc-4.2.1/gcc/ada/gnatmem.adb707
1 files changed, 707 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/gnatmem.adb b/gcc-4.2.1/gcc/ada/gnatmem.adb
new file mode 100644
index 000000000..d52fe005f
--- /dev/null
+++ b/gcc-4.2.1/gcc/ada/gnatmem.adb
@@ -0,0 +1,707 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;