X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fgnatmem.adb;fp=gcc%2Fada%2Fgnatmem.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=b4988fb5e8f34e6cec55d3a6ae8823794ab07495;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb deleted file mode 100644 index b4988fb5..00000000 --- a/gcc/ada/gnatmem.adb +++ /dev/null @@ -1,1058 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T M E M -- --- -- --- B o d y -- --- -- --- $Revision: 1.3.10.1 $ --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- 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 ^ ^0x ^ - - -- 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 ^ - - -- 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;