| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T M E M -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision: 1.2 $ |
| -- -- |
| -- 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 Dependent 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 |
| -- ALLOC ^ <size> ^0x <addr> ^ |
| |
| -- Read the size |
| |
| Curs1 := 7; |
| Curs2 := Next_Separator - 1; |
| |
| if not Quiet_Mode then |
| 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 |
| -- DEALL ^ 0x <addr> ^ |
| |
| -- 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; |
