diff options
Diffstat (limited to 'gcc/ada/gnatmem.adb')
| -rw-r--r-- | gcc/ada/gnatmem.adb | 815 |
1 files changed, 0 insertions, 815 deletions
diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb deleted file mode 100644 index d6ac07834a9..00000000000 --- a/gcc/ada/gnatmem.adb +++ /dev/null @@ -1,815 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |