diff options
Diffstat (limited to 'gcc/ada/gnatmem.adb')
| -rw-r--r-- | gcc/ada/gnatmem.adb | 1059 |
1 files changed, 1059 insertions, 0 deletions
diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb new file mode 100644 index 00000000000..b3457118f9a --- /dev/null +++ b/gcc/ada/gnatmem.adb @@ -0,0 +1,1059 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T M E M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.24 $ +-- -- +-- Copyright (C) 1997-2001, Ada Core Technologies, Inc. -- +-- -- +-- 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- GNATMEM is a utility that tracks memory leaks. It is based on a simple +-- idea: +-- - run the application under gdb +-- - set a breakpoint on __gnat_malloc and __gnat_free +-- - 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. +-- +-- GNATMEM can also be used with instrumented allocation/deallocation +-- routine (see a-raise.c with symbol GMEM defined). This is not supported +-- in all platforms, again refer to a-raise.c for further information. +-- In this case 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. +-- +-- 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, quantify of memory allocated, high water mark, +-- etc.). + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Text_IO.C_Streams; +with Ada.Float_Text_IO; +with Ada.Integer_Text_IO; +with Gnatvsn; use Gnatvsn; +with GNAT.Heap_Sort_G; +with GNAT.OS_Lib; +with GNAT.HTable; use GNAT.HTable; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +with Memroot; use Memroot; + +procedure Gnatmem is + + ------------------------------------------------ + -- Potentially Target Dependant Subprograms. -- + ------------------------------------------------ + + function Get_Current_TTY return String; + -- Give the current tty on which the program is run. This is needed to + -- separate the output of the debugger from the output of the program. + -- The output of this function will be used to call the gdb command "tty" + -- in the gdb script in order to get the program output on the current tty + -- while the gdb output is redirected and processed by gnatmem. + + function popen (File, Mode : System.Address) return FILEs; + pragma Import (C, popen, "popen"); + -- Execute the program 'File'. If the mode is "r" the standard output + -- of the program is redirected and the FILEs handler of the + -- redirection is returned. + + procedure System_Cmd (X : System.Address); + pragma Import (C, System_Cmd, "system"); + -- Execute the program "X". + + subtype Cstring is String (1 .. Integer'Last); + type Cstring_Ptr is access all Cstring; + + function ttyname (Dec : Integer) return Cstring_Ptr; + pragma Import (C, ttyname, "__gnat_ttyname"); + -- Return a null-terminated string containing the current tty + + Dir_Sep : constant Character := '/'; + + ------------------------ + -- Other Declarations -- + ------------------------ + + type Gdb_Output_Elmt is (Eof, Alloc, Deall); + -- Eof = End of gdb output file + -- Alloc = found a ALLOC mark in the gdb output + -- Deall = found a DEALL mark in the gdb output + Gdb_Output_Format_Error : exception; + + function Read_Next return Gdb_Output_Elmt; + -- Read the output of the debugger till it finds either the end of the + -- output, or the 'ALLOC' mark or the 'DEALL' mark. In the second case, + -- it sets the Tmp_Size and Tmp_Address global variables, in the + -- third case it sets the Tmp_Address variable. + + procedure Create_Gdb_Script; + -- Create the GDB script and save it in a temporary file + + function Mem_Image (X : Storage_Count) return String; + -- X is a size in storage_element. Returns a value + -- in Megabytes, Kiloytes 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 + + procedure Gmem_Read_Next (Buf : out String; Last : out Natural); + -- Reads the next allocation/deallocation entry and its backtrace + -- and prepares in the string Buf (up to the position of Last) the + -- expression compatible with gnatmem parser: + -- Allocation entry produces the expression "ALLOC^[size]^0x[address]^" + -- Deallocation entry produces the expression "DEALLOC^0x[address]^" + + Argc : constant Integer := Argument_Count; + Gnatmem_Tmp : aliased constant String := "gnatmem.tmp"; + + Mode_R : aliased constant String (1 .. 2) := 'r' & ASCII.NUL; + Mode_W : aliased constant String (1 .. 3) := "w+" & ASCII.NUL; + + ----------------------------------- + -- 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; + FD : FILEs; + FT : File_Type; + File_Pos : Integer := 0; + Exec_Pos : Integer := 0; + Target_Pos : Integer := 0; + Run_Gdb : Boolean := True; + + 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; + Target_Name : String (1 .. 80); + Target_Protocol : String (1 .. 80); + Target_Name_Len : Integer; + Target_Protocol_Len : Integer; + Cross_Case : Boolean := False; + + + Tmp_Size : Storage_Count := 0; + Tmp_Address : Integer_Address; + Tmp_Alloc : Allocation; + Quiet_Mode : Boolean := False; + + -------------------------------- + -- 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; + + procedure Gmem_Read_Next (Buf : out String; Last : out Natural) is + procedure Read_Next (buf : System.Address); + pragma Import (C, Read_Next, "__gnat_gmem_read_next"); + function Strlen (str : System.Address) return Natural; + pragma Import (C, Strlen, "strlen"); + + S : String (1 .. 1000); + begin + Read_Next (S'Address); + Last := Strlen (S'Address); + Buf (1 .. Last) := S (1 .. Last); + end Gmem_Read_Next; + + --------------------- + -- Get_Current_TTY -- + --------------------- + + function Get_Current_TTY return String is + Res : Cstring_Ptr; + stdout : constant Integer := 1; + Max_TTY_Name : constant Integer := 500; + + begin + if isatty (stdout) /= 1 then + return ""; + end if; + + Res := ttyname (1); + if Res /= null then + for J in Cstring'First .. Max_TTY_Name loop + if Res (J) = ASCII.NUL then + return Res (Cstring'First .. J - 1); + end if; + end loop; + end if; + + -- if we fall thru the ttyname result was dubious. Just forget it. + + return ""; + end Get_Current_TTY; + + ------- + -- H -- + ------- + + function H (A : Integer_Address) return Address_Range is + begin + return Address_Range (A mod Integer_Address (Address_Range'Last)); + end H; + + ----------------------- + -- Create_Gdb_Script -- + ----------------------- + + procedure Create_Gdb_Script is + FD : File_Type; + + begin + begin + Create (FD, Out_File, Gnatmem_Tmp); + exception + when others => + Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp); + GNAT.OS_Lib.OS_Exit (1); + end; + + declare + TTY : constant String := Get_Current_TTY; + begin + if TTY'Length > 0 then + Put_Line (FD, "tty " & TTY); + end if; + end; + + + if Cross_Case then + Put (FD, "target "); + Put (FD, Target_Protocol (1 .. Target_Protocol_Len)); + Put (FD, " "); + Put (FD, Argument (Target_Pos)); + New_Line (FD); + Put (FD, "load "); + Put_Line (FD, Argument (Exec_Pos)); + + else + -- In the native case, run the program before setting the + -- breakpoints so that gnatmem will also work with shared + -- libraries. + + Put_Line (FD, "set lang c"); + Put_Line (FD, "break main"); + Put_Line (FD, "set lang auto"); + Put (FD, "run"); + for J in Exec_Pos + 1 .. Argc loop + Put (FD, " "); + Put (FD, Argument (J)); + end loop; + New_Line (FD); + + -- At this point, gdb knows about __gnat_malloc and __gnat_free + end if; + + -- Make sure that outputing long backtraces do not pause + + Put_Line (FD, "set height 0"); + Put_Line (FD, "set width 0"); + + if Quiet_Mode then + Put_Line (FD, "break __gnat_malloc"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set lang c"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " finish"); + Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " set lang auto"); + else + Put_Line (FD, "break __gnat_malloc"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set lang c"); + Put_Line (FD, " set $gm_size = size"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " finish"); + Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " set lang auto"); + end if; + + Put (FD, " backtrace"); + + if BT_Depth /= 0 then + Put (FD, Integer'Image (BT_Depth)); + end if; + + New_Line (FD); + + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " continue"); + Put_Line (FD, "end"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + Put_Line (FD, "break __gnat_free"); + Put_Line (FD, "command"); + Put_Line (FD, " silent"); + Put_Line (FD, " set print address on"); + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr"); + Put_Line (FD, " set print address off"); + Put_Line (FD, " finish"); + + Put (FD, " backtrace"); + + if BT_Depth /= 0 then + Put (FD, Integer'Image (BT_Depth)); + end if; + + New_Line (FD); + + Put_Line (FD, " printf ""\n\n"""); + Put_Line (FD, " continue"); + Put_Line (FD, "end"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + Put_Line (FD, "#"); + + if Cross_Case then + Put (FD, "run "); + Put_Line (FD, Argument (Exec_Pos)); + + if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then + Put (FD, "unload "); + Put_Line (FD, Argument (Exec_Pos)); + end if; + else + Put_Line (FD, "continue"); + end if; + + Close (FD); + end Create_Gdb_Script; + + --------------- + -- 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 (Gnat_Version_String); + Put_Line (" Copyright 1997-2000 Free Software Foundation, Inc."); + New_Line; + + if Cross_Case then + Put_Line (Command_Name + & " [-q] [n] [-o file] target entry_point ..."); + Put_Line (Command_Name & " [-q] [n] [-i file]"); + + else + Put_Line ("GDB mode"); + Put_Line (" " & Command_Name + & " [-q] [n] [-o file] program arg1 arg2 ..."); + Put_Line (" " & Command_Name + & " [-q] [n] [-i file]"); + New_Line; + Put_Line ("GMEM mode"); + Put_Line (" " & Command_Name + & " [-q] [n] -i gmem.out program arg1 arg2 ..."); + New_Line; + end if; + + Put_Line (" -q quiet, minimum output"); + Put_Line (" n number of frames for allocation root backtraces"); + Put_Line (" default is 1."); + Put_Line (" -o file save gdb output in 'file' and process data"); + Put_Line (" post mortem. also keep the gdb script around"); + Put_Line (" -i file don't run gdb output. Do only post mortem"); + Put_Line (" processing from file"); + GNAT.OS_Lib.OS_Exit (1); + end Usage; + + ----------------------- + -- Process_Arguments -- + ----------------------- + + procedure Process_Arguments is + Arg : Integer; + + procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False); + -- Check that Argument (Arg_Pos) is an existing file if For_Creat is + -- false or if it is possible to create it if For_Creat is true + + procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False) is + Name : aliased constant String := Argument (Arg_Pos) & ASCII.NUL; + X : int; + + begin + if For_Creat then + FD := fopen (Name'Address, Mode_W'Address); + else + FD := fopen (Name'Address, Mode_R'Address); + end if; + + if FD = NULL_Stream then + New_Line; + if For_Creat then + Put_Line ("Cannot create file : " & Argument (Arg_Pos)); + else + Put_Line ("Cannot locate file : " & Argument (Arg_Pos)); + end if; + New_Line; + Usage; + else + X := fclose (FD); + end if; + end Check_File; + + -- Start of processing for Process_Arguments + + begin + + -- Is it a cross version? + + declare + Std_Name : constant String := "gnatmem"; + Name : constant String := Command_Name; + End_Pref : constant Integer := Name'Last - Std_Name'Length; + + begin + if Name'Length > Std_Name'Length + 9 + and then + Name (End_Pref + 1 .. Name'Last) = Std_Name + and then + Name (End_Pref - 8 .. End_Pref) = "-vxworks-" + then + Cross_Case := True; + + Target_Name_Len := End_Pref - 1; + for J in reverse Name'First .. End_Pref - 1 loop + if Name (J) = Dir_Sep then + Target_Name_Len := Target_Name_Len - J; + exit; + end if; + end loop; + + Target_Name (1 .. Target_Name_Len) + := Name (End_Pref - Target_Name_Len .. End_Pref - 1); + + if Target_Name (1 .. 5) = "alpha" then + Target_Protocol (1 .. 7) := "vxworks"; + Target_Protocol_Len := 7; + else + Target_Protocol (1 .. 3) := "wtx"; + Target_Protocol_Len := 3; + end if; + end if; + end; + + Arg := 1; + + if Argc < Arg then + Usage; + end if; + + -- Deal with "-q" + + if Argument (Arg) = "-q" then + + Quiet_Mode := True; + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + end if; + + -- Deal with back trace depth + + if Argument (Arg) (1) in '0' .. '9' then + begin + BT_Depth := Integer'Value (Argument (Arg)); + exception + when others => + Usage; + end; + + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + end if; + + -- Deal with "-o file" or "-i file" + + while Arg <= Argc and then Argument (Arg) (1) = '-' loop + Arg := Arg + 1; + + if Argc < Arg then + Usage; + end if; + + case Argument (Arg - 1) (2) is + when 'o' => + Check_File (Arg, For_Creat => True); + File_Pos := Arg; + + when 'i' => + Check_File (Arg); + File_Pos := Arg; + Run_Gdb := False; + if Gmem_Initialize (Argument (Arg)) then + Gmem_Mode := True; + end if; + + when others => + Put_Line ("Unknown option : " & Argument (Arg)); + Usage; + end case; + + Arg := Arg + 1; + + if Argc < Arg and then Run_Gdb then + Usage; + end if; + end loop; + + -- In the cross case, we first get the target + + if Cross_Case then + Target_Pos := Arg; + Arg := Arg + 1; + + if Argc < Arg and then Run_Gdb then + Usage; + end if; + end if; + + -- Now all the following arguments are to be passed to gdb + + if Run_Gdb then + Exec_Pos := Arg; + Check_File (Exec_Pos); + + elsif Gmem_Mode then + if Arg > Argc then + Usage; + else + Exec_Pos := Arg; + Check_File (Exec_Pos); + Gmem_A2l_Initialize (Argument (Exec_Pos)); + end if; + + -- ... in other cases further arguments are disallowed + + elsif Arg <= Argc then + Usage; + end if; + end Process_Arguments; + + --------------- + -- Read_Next -- + --------------- + + function Read_Next return Gdb_Output_Elmt is + Max_Line : constant Integer := 100; + Line : String (1 .. Max_Line); + Last : Integer := 0; + + Curs1, Curs2 : Integer; + Separator : constant Character := '^'; + + function Next_Separator return Integer; + -- Return the index of the next separator after Curs1 in Line + + function Next_Separator return Integer is + Curs : Integer := Curs1; + + begin + loop + if Curs > Last then + raise Gdb_Output_Format_Error; + + elsif Line (Curs) = Separator then + return Curs; + end if; + + Curs := Curs + 1; + end loop; + end Next_Separator; + + -- Start of processing for Read_Next + + begin + Line (1) := ' '; + + loop + if Gmem_Mode then + Gmem_Read_Next (Line, Last); + else + Get_Line (FT, Line, Last); + end if; + + if Line (1 .. 14) = "Program exited" then + return Eof; + + elsif Line (1 .. 5) = "ALLOC" then + + -- Read the size + + if Quiet_Mode then + Curs2 := 5; + else + Curs1 := 7; + Curs2 := Next_Separator - 1; + Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2)); + end if; + + -- Read the address, skip "^0x" + + Curs1 := Curs2 + 4; + Curs2 := Next_Separator - 1; + Tmp_Address := Integer_Address'Value ( + "16#" & Line (Curs1 .. Curs2) & "#"); + return Alloc; + + elsif Line (1 .. 5) = "DEALL" then + + -- Read the address, skip "^0x" + + Curs1 := 9; + Curs2 := Next_Separator - 1; + Tmp_Address := Integer_Address'Value ( + "16#" & Line (Curs1 .. Curs2) & "#"); + return Deall; + end if; + end loop; + exception + when End_Error => + New_Line; + Put_Line ("### incorrect user program termination detected."); + Put_Line (" following data may not be meaningful"); + New_Line; + return Eof; + end Read_Next; + +-- Start of processing for Gnatmem + +begin + Process_Arguments; + + if Run_Gdb then + Create_Gdb_Script; + end if; + + -- Now we start the gdb session using the following syntax + + -- gdb --nx --nw -batch -x gnatmem.tmp + + -- If there is a -o option we redirect the gdb output in the specified + -- file, otherwise we just read directly from a pipe. + + if File_Pos /= 0 then + declare + Name : aliased String := Argument (File_Pos) & ASCII.NUL; + + begin + if Run_Gdb then + if Cross_Case then + declare + Cmd : aliased String := Target_Name (1 .. Target_Name_Len) + & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & " > " + & Name; + begin + System_Cmd (Cmd'Address); + end; + else + + declare + Cmd : aliased String + := "gdb --nx --nw " & Argument (Exec_Pos) + & " -batch -x " & Gnatmem_Tmp & " > " + & Name; + begin + System_Cmd (Cmd'Address); + end; + end if; + end if; + + if not Gmem_Mode then + FD := fopen (Name'Address, Mode_R'Address); + end if; + end; + + else + if Cross_Case then + declare + Cmd : aliased String := Target_Name (1 .. Target_Name_Len) + & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & ASCII.NUL; + begin + FD := popen (Cmd'Address, Mode_R'Address); + end; + else + declare + Cmd : aliased String := "gdb --nx --nw " & Argument (Exec_Pos) + & " -batch -x " & Gnatmem_Tmp & ASCII.NUL; + + begin + FD := popen (Cmd'Address, Mode_R'Address); + end; + end if; + end if; + + -- Open the FD file as a regular Text_IO file + + if not Gmem_Mode then + Ada.Text_IO.C_Streams.Open (FT, In_File, FD); + end if; + + -- Main loop analysing the data generated by the debugger + -- for each allocation, the backtrace is kept and stored in a htable + -- whose entry is the address. Fore ach deallocation, we look for the + -- corresponding allocation and cancel it. + + Main : loop + case Read_Next is + when EOF => + exit Main; + + when Alloc => + + -- Update global counters if the allocated size is meaningful + + if Quiet_Mode then + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + 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 (Tmp_Address, Tmp_Alloc); + + elsif Tmp_Size > 0 then + + Global_Alloc_Size := Global_Alloc_Size + Tmp_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, FT); + + -- 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) + Tmp_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 := Tmp_Size; + Address_HTable.Set (Tmp_Address, Tmp_Alloc); + + -- non meaninful output, just consumes the backtrace + + else + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + end if; + + when Deall => + + -- Get the corresponding Dealloc_Size and Root + + Tmp_Alloc := Address_HTable.Get (Tmp_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 a + + Tmp_Alloc.Root := Read_BT (BT_Depth, FT); + + 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 then + Nb_Root := Nb_Root - 1; + end if; + + -- De-associate the deallocated address + + Address_HTable.Remove (Tmp_Address); + end if; + end case; + end loop Main; + + -- We can get rid of the temp file now + + if Run_Gdb and then File_Pos = 0 then + declare + X : int; + begin + X := unlink (Gnatmem_Tmp'Address); + end; + end if; + + -- 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; + + 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 + begin + if Nb_Alloc (Leaks (Op1)) > Nb_Alloc (Leaks (Op2)) then + return True; + elsif Nb_Alloc (Leaks (Op1)) = Nb_Alloc (Leaks (Op2)) then + return Alloc_Size (Leaks (Op1)) > Alloc_Size (Leaks (Op2)); + else + return False; + end if; + 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 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)); + 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 + if Quiet_Mode then + if Nb_Alloc (Leaks (J)) = 1 then + Put_Line (Integer'Image (Nb_Alloc (Leaks (J))) + & " leak at :"); + else + Put_Line (Integer'Image (Nb_Alloc (Leaks (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 (Leaks (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)); + New_Line; + end loop; + end if; + end Print_Back_Traces; + +end Gnatmem; |