robotux
/
rt_gccstream
1
0
Fork 0
Code Issues Pull Requests Releases Activity
rt_gccstream/gcc/ada/gnatmem.adb

816 lines
26 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- --
-- 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;
Reference in New Issue View Git Blame Copy Permalink