From: charlet Date: Thu, 21 Oct 2010 13:27:26 +0000 (+0000) Subject: 2010-10-21 Robert Dewar X-Git-Tag: upstream/4.9.2~25561 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=20e4f1c1b873e306a4eef23aa860f9c89a1d2b74;p=platform%2Fupstream%2Flinaro-gcc.git 2010-10-21 Robert Dewar * sem_ch3.adb: Minor reformatting. 2010-10-21 Thomas Quinot * einfo.ads (Next_Girder_Discriminant): Remove obsolete description for removed routine. 2010-10-21 Nicolas Roche * gnatmem.adb, memroot.adb, memroot.ads, gmem.c, gcc-interface/Makefile.in: Remove gnatmem specific files. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165776 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 587474f..1770e47 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2010-10-21 Robert Dewar + + * sem_ch3.adb: Minor reformatting. + +2010-10-21 Thomas Quinot + + * einfo.ads (Next_Girder_Discriminant): Remove obsolete description for + removed routine. + +2010-10-21 Nicolas Roche + + * gnatmem.adb, memroot.adb, memroot.ads, gmem.c, + gcc-interface/Makefile.in: Remove gnatmem specific files. + 2010-10-21 Thomas Quinot * sem_res.adb, exp_ch13.adb: Minor reformatting. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 189e1c5..1d3c9cb 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3055,12 +3055,6 @@ package Einfo is -- Empty if there are no more formals. The list returned includes -- all the extra formals (see description of Extra_Formal field) --- Next_Girder_Discriminant (synthesized) --- Applies to discriminants. Set only for a discriminant returned by --- a call to First/Next_Girder_Discriminant. Returns next girder --- discriminant, if there are more (see complete description in --- First_Girder_Discriminant), or Empty if there are no more. - -- Next_Index (synthesized) -- Applies to array types and subtypes and to string types and -- subtypes. Yields the next index. The first index is obtained by diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 602e466..31693bc 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -2756,7 +2756,6 @@ errno.o : errno.c exit.o : adaint.h exit.c expect.o : expect.c final.o : final.c -gmem.o : gmem.c link.o : link.c mkdir.o : mkdir.c socket.o : socket.c gsocket.h diff --git a/gcc/ada/gmem.c b/gcc/ada/gmem.c deleted file mode 100644 index 12c3c0a..0000000 --- a/gcc/ada/gmem.c +++ /dev/null @@ -1,217 +0,0 @@ -/**************************************************************************** - * * - * GNATMEM COMPONENTS * - * * - * G M E M * - * * - * C Implementation File * - * * - * Copyright (C) 2000-2009, Free Software Foundation, 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 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. * - * * - * As a special exception under Section 7 of GPL version 3, you are granted * - * additional permissions described in the GCC Runtime Library Exception, * - * version 3.1, as published by the Free Software Foundation. * - * * - * You should have received a copy of the GNU General Public License and * - * a copy of the GCC Runtime Library Exception along with this program; * - * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/* This unit reads the allocation tracking log produced by augmented - __gnat_malloc and __gnat_free procedures (see file memtrack.adb) and - provides GNATMEM tool with gdb-compliant output. The output is - processed by GNATMEM to detect dynamic memory allocation errors. - - See GNATMEM section in GNAT User's Guide for more information. - - NOTE: This capability is currently supported on the following targets: - - DEC Unix - GNU/Linux x86 - Solaris (sparc and x86) (*) - Windows 98/95/NT (x86) - Alpha OpenVMS - - (*) on these targets, the compilation must be done with -funwind-tables to - be able to build the stack backtrace. - -*/ - -#ifdef VMS -#include -#define xstrdup32(S) strcpy ((__char_ptr32) _malloc32 (strlen (S) + 1), S) -#else -#define xstrdup32(S) S -#endif - -#include - -static FILE *gmemfile; - -/* tb_len is the number of call level supported by this module */ -#define tb_len 200 -static void * tracebk [tb_len]; -static int cur_tb_len, cur_tb_pos; - -#define LOG_EOF '*' -#define LOG_ALLOC 'A' -#define LOG_DEALL 'D' - -struct struct_storage_elmt { - char Elmt; - void * Address; - size_t Size; - long long Timestamp; -}; - -static void -__gnat_convert_addresses (void *addrs[], int n_addrs, void *buf, int *len); -/* Place in BUF a string representing the symbolic translation of N_ADDRS raw - addresses provided in ADDRS. LEN is filled with the result length. - - This is a GNAT specific interface to the libaddr2line convert_addresses - routine. The latter examines debug info from a provided executable file - name to perform the translation into symbolic form of an input sequence of - raw binary addresses. It attempts to open the file from the provided name - "as is", so an absolute path must be provided to ensure the file is - always found. We compute this name once, at initialization time. */ - -static const char * exename = 0; - -extern void convert_addresses (const char * , void *[], int, void *, int *); -extern char *__gnat_locate_exec_on_path (char *); -/* ??? Both of these extern functions are prototyped in adaint.h, which - also refers to "time_t" hence needs complex extra header inclusions to - be satisfied on every target. */ - -static void -__gnat_convert_addresses (void *addrs[], int n_addrs, void *buf, int *len) -{ - if (exename != 0) - convert_addresses (exename, addrs, n_addrs, buf, len); - else - *len = 0; -} - -/* reads backtrace information from gmemfile placing them in tracebk - array. cur_tb_len is the size of this array -*/ - -static void -gmem_read_backtrace (void) -{ - fread (&cur_tb_len, sizeof (int), 1, gmemfile); - fread (tracebk, sizeof (void *), cur_tb_len, gmemfile); - cur_tb_pos = 0; -} - -/* initialize gmem feature from the dumpname file. It returns t0 timestamp - if the dumpname has been generated by GMEM (instrumented malloc/free) - and 0 if not. -*/ - -long long __gnat_gmem_initialize (char *dumpname) -{ - char header [10]; - long long t0; - - gmemfile = fopen (dumpname, "rb"); - fread (header, 10, 1, gmemfile); - - /* check for GMEM magic-tag */ - if (memcmp (header, "GMEM DUMP\n", 10)) - { - fclose (gmemfile); - return 0; - } - - fread (&t0, sizeof (long long), 1, gmemfile); - - return t0; -} - -/* initialize addr2line library */ - -void __gnat_gmem_a2l_initialize (char *exearg) -{ - /* Resolve the executable filename to use in later invocations of - the libaddr2line symbolization service. Ensure that on VMS - exename is allocated in 32 bit memory for compatibility - with libaddr2line. */ - exename = xstrdup32 (__gnat_locate_exec_on_path (exearg)); -} - -/* Read next allocation of deallocation information from the GMEM file and - write an alloc/free information in buf to be processed by gnatmem */ - -void -__gnat_gmem_read_next (struct struct_storage_elmt *buf) -{ - void *addr; - size_t size; - int j; - - j = fgetc (gmemfile); - if (j == EOF) - { - fclose (gmemfile); - buf->Elmt = LOG_EOF; - } - else - { - switch (j) - { - case 'A' : - buf->Elmt = LOG_ALLOC; - fread (&(buf->Address), sizeof (void *), 1, gmemfile); - fread (&(buf->Size), sizeof (size_t), 1, gmemfile); - fread (&(buf->Timestamp), sizeof (long long), 1, gmemfile); - break; - case 'D' : - buf->Elmt = LOG_DEALL; - fread (&(buf->Address), sizeof (void *), 1, gmemfile); - fread (&(buf->Timestamp), sizeof (long long), 1, gmemfile); - break; - default: - puts ("GNATMEM dump file corrupt"); - __gnat_os_exit (1); - } - - gmem_read_backtrace (); - } -} - -/* Read the next frame from the current traceback, and move the cursor to the - next frame */ - -void __gnat_gmem_read_next_frame (void** addr) -{ - if (cur_tb_pos >= cur_tb_len) { - *addr = NULL; - } else { - *addr = (void*)*(tracebk + cur_tb_pos); - ++cur_tb_pos; - } -} - -/* Converts addr into a symbolic traceback, and stores the result in buf - with a format suitable for gnatmem */ - -void __gnat_gmem_symbolic (void * addr, char* buf, int* length) -{ - void * addresses [] = { addr }; - - __gnat_convert_addresses (addresses, 1, buf, length); -} diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb deleted file mode 100644 index d6ac078..0000000 --- a/gcc/ada/gnatmem.adb +++ /dev/null @@ -1,815 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T M E M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2008, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- GNATMEM is a utility that tracks memory leaks. It is based on a simple --- idea: - --- - Read the allocation log generated by the application linked using --- instrumented memory allocation and deallocation (see memtrack.adb for --- this circuitry). To get access to this functionality, the application --- must be relinked with library libgmem.a: - --- $ gnatmake my_prog -largs -lgmem - --- The running my_prog will produce a file named gmem.out that will be --- parsed by gnatmem. - --- - Record a reference to the allocated memory on each allocation call - --- - Suppress this reference on deallocation - --- - At the end of the program, remaining references are potential leaks. --- sort them out the best possible way in order to locate the root of --- the leak. - --- This capability is not supported on all platforms, please refer to --- memtrack.adb for further information. - --- In order to help finding out the real leaks, the notion of "allocation --- root" is defined. An allocation root is a specific point in the program --- execution generating memory allocation where data is collected (such as --- number of allocations, amount of memory allocated, high water mark, etc.) - -with Ada.Float_Text_IO; -with Ada.Integer_Text_IO; -with Ada.Text_IO; use Ada.Text_IO; - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.Heap_Sort_G; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.HTable; use GNAT.HTable; - -with Gnatvsn; use Gnatvsn; -with Memroot; use Memroot; - -procedure Gnatmem is - - package Int_IO renames Ada.Integer_Text_IO; - - ------------------------ - -- Other Declarations -- - ------------------------ - - type Storage_Elmt is record - Elmt : Character; - -- * = End of log file - -- A = found a ALLOC mark in the log - -- D = found a DEALL mark in the log - - Address : Integer_Address; - Size : Storage_Count; - Timestamp : Duration; - end record; - -- This type is used to read heap operations from the log file. - -- Elmt contains the type of the operation, which can be either - -- allocation, deallocation, or a special mark indicating the - -- end of the log file. Address is used to store address on the - -- heap where a chunk was allocated/deallocated, size is only - -- for A event and contains size of the allocation, and Timestamp - -- is the clock value at the moment of allocation - - Log_Name : String_Access; - -- Holds the name of the heap operations log file - - Program_Name : String_Access; - -- Holds the name of the user executable - - function Read_Next return Storage_Elmt; - -- Reads next dynamic storage operation from the log file - - function Mem_Image (X : Storage_Count) return String; - -- X is a size in storage_element. Returns a value - -- in Megabytes, Kilobytes or Bytes as appropriate. - - procedure Process_Arguments; - -- Read command line arguments - - procedure Usage; - -- Prints out the option help - - function Gmem_Initialize (Dumpname : String) return Boolean; - -- Opens the file represented by Dumpname and prepares it for - -- work. Returns False if the file does not have the correct format, True - -- otherwise. - - procedure Gmem_A2l_Initialize (Exename : String); - -- Initialises the convert_addresses interface by supplying it with - -- the name of the executable file Exename - - ----------------------------------- - -- HTable address --> Allocation -- - ----------------------------------- - - type Allocation is record - Root : Root_Id; - Size : Storage_Count; - end record; - - type Address_Range is range 0 .. 4097; - function H (A : Integer_Address) return Address_Range; - No_Alloc : constant Allocation := (No_Root_Id, 0); - - package Address_HTable is new GNAT.HTable.Simple_HTable ( - Header_Num => Address_Range, - Element => Allocation, - No_Element => No_Alloc, - Key => Integer_Address, - Hash => H, - Equal => "="); - - BT_Depth : Integer := 1; - - -- Some global statistics - - Global_Alloc_Size : Storage_Count := 0; - -- Total number of bytes allocated during the lifetime of a program - - Global_High_Water_Mark : Storage_Count := 0; - -- Largest amount of storage ever in use during the lifetime - - Global_Nb_Alloc : Integer := 0; - -- Total number of allocations - - Global_Nb_Dealloc : Integer := 0; - -- Total number of deallocations - - Nb_Root : Integer := 0; - -- Total number of allocation roots - - Nb_Wrong_Deall : Integer := 0; - -- Total number of wrong deallocations (i.e. without matching alloc) - - Minimum_Nb_Leaks : Integer := 1; - -- How many unfreed allocs should be in a root for it to count as leak - - T0 : Duration := 0.0; - -- The moment at which memory allocation routines initialized (should - -- be pretty close to the moment the program started since there are - -- always some allocations at RTL elaboration - - Tmp_Alloc : Allocation; - Dump_Log_Mode : Boolean := False; - Quiet_Mode : Boolean := False; - - ------------------------------ - -- Allocation Roots Sorting -- - ------------------------------ - - Sort_Order : String (1 .. 3) := "nwh"; - -- This is the default order in which sorting criteria will be applied - -- n - Total number of unfreed allocations - -- w - Final watermark - -- h - High watermark - - -------------------------------- - -- GMEM functionality binding -- - -------------------------------- - - --------------------- - -- Gmem_Initialize -- - --------------------- - - function Gmem_Initialize (Dumpname : String) return Boolean is - function Initialize (Dumpname : System.Address) return Duration; - pragma Import (C, Initialize, "__gnat_gmem_initialize"); - - S : aliased String := Dumpname & ASCII.NUL; - - begin - T0 := Initialize (S'Address); - return T0 > 0.0; - end Gmem_Initialize; - - ------------------------- - -- Gmem_A2l_Initialize -- - ------------------------- - - procedure Gmem_A2l_Initialize (Exename : String) is - procedure A2l_Initialize (Exename : System.Address); - pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize"); - - S : aliased String := Exename & ASCII.NUL; - - begin - A2l_Initialize (S'Address); - end Gmem_A2l_Initialize; - - --------------- - -- Read_Next -- - --------------- - - function Read_Next return Storage_Elmt is - procedure Read_Next (buf : System.Address); - pragma Import (C, Read_Next, "__gnat_gmem_read_next"); - - S : Storage_Elmt; - - begin - Read_Next (S'Address); - return S; - end Read_Next; - - ------- - -- H -- - ------- - - function H (A : Integer_Address) return Address_Range is - begin - return Address_Range (A mod Integer_Address (Address_Range'Last)); - end H; - - --------------- - -- Mem_Image -- - --------------- - - function Mem_Image (X : Storage_Count) return String is - Ks : constant Storage_Count := X / 1024; - Megs : constant Storage_Count := Ks / 1024; - Buff : String (1 .. 7); - - begin - if Megs /= 0 then - Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0); - return Buff & " Megabytes"; - - elsif Ks /= 0 then - Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0); - return Buff & " Kilobytes"; - - else - Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X)); - return Buff (1 .. 4) & " Bytes"; - end if; - end Mem_Image; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - New_Line; - Put ("GNATMEM "); - Put_Line (Gnat_Version_String); - Put_Line ("Copyright 1997-2007, Free Software Foundation, Inc."); - New_Line; - - Put_Line ("Usage: gnatmem switches [depth] exename"); - New_Line; - Put_Line (" depth backtrace depth to take into account, default is" - & Integer'Image (BT_Depth)); - Put_Line (" exename the name of the executable to be analyzed"); - New_Line; - Put_Line ("Switches:"); - Put_Line (" -b n same as depth parameter"); - Put_Line (" -i file read the allocation log from specific file"); - Put_Line (" default is gmem.out in the current directory"); - Put_Line (" -m n masks roots with less than n leaks, default is 1"); - Put_Line (" specify 0 to see even released allocation roots"); - Put_Line (" -q quiet, minimum output"); - Put_Line (" -s order sort allocation roots according to an order of"); - Put_Line (" sort criteria"); - GNAT.OS_Lib.OS_Exit (1); - end Usage; - - ----------------------- - -- Process_Arguments -- - ----------------------- - - procedure Process_Arguments is - begin - -- Parse the options first - - loop - case Getopt ("b: dd m: i: q s:") is - when ASCII.NUL => exit; - - when 'b' => - begin - BT_Depth := Natural'Value (Parameter); - exception - when Constraint_Error => - Usage; - end; - - when 'd' => - Dump_Log_Mode := True; - - when 'm' => - begin - Minimum_Nb_Leaks := Natural'Value (Parameter); - exception - when Constraint_Error => - Usage; - end; - - when 'i' => - Log_Name := new String'(Parameter); - - when 'q' => - Quiet_Mode := True; - - when 's' => - declare - S : constant String (Sort_Order'Range) := Parameter; - begin - for J in Sort_Order'Range loop - if S (J) = 'n' or else - S (J) = 'w' or else - S (J) = 'h' - then - Sort_Order (J) := S (J); - else - Put_Line ("Invalid sort criteria string."); - GNAT.OS_Lib.OS_Exit (1); - end if; - end loop; - end; - - when others => - null; - end case; - end loop; - - -- Set default log file if -i hasn't been specified - - if Log_Name = null then - Log_Name := new String'("gmem.out"); - end if; - - -- Get the optional backtrace length and program name - - declare - Str1 : constant String := GNAT.Command_Line.Get_Argument; - Str2 : constant String := GNAT.Command_Line.Get_Argument; - - begin - if Str1 = "" then - Usage; - end if; - - if Str2 = "" then - Program_Name := new String'(Str1); - else - BT_Depth := Natural'Value (Str1); - Program_Name := new String'(Str2); - end if; - - exception - when Constraint_Error => - Usage; - end; - - -- Ensure presence of executable suffix in Program_Name - - declare - Suffix : String_Access := Get_Executable_Suffix; - Tmp : String_Access; - - begin - if Suffix.all /= "" - and then - Program_Name.all - (Program_Name.all'Last - Suffix.all'Length + 1 .. - Program_Name.all'Last) /= Suffix.all - then - Tmp := new String'(Program_Name.all & Suffix.all); - Free (Program_Name); - Program_Name := Tmp; - end if; - - Free (Suffix); - - -- Search the executable on the path. If not found in the PATH, we - -- default to the current directory. Otherwise, libaddr2line will - -- fail with an error: - - -- (null): Bad address - - Tmp := Locate_Exec_On_Path (Program_Name.all); - - if Tmp = null then - Tmp := new String'('.' & Directory_Separator & Program_Name.all); - end if; - - Free (Program_Name); - Program_Name := Tmp; - end; - - if not Is_Regular_File (Log_Name.all) then - Put_Line ("Couldn't find " & Log_Name.all); - GNAT.OS_Lib.OS_Exit (1); - end if; - - if not Gmem_Initialize (Log_Name.all) then - Put_Line ("File " & Log_Name.all & " is not a gnatmem log file"); - GNAT.OS_Lib.OS_Exit (1); - end if; - - if not Is_Regular_File (Program_Name.all) then - Put_Line ("Couldn't find " & Program_Name.all); - end if; - - Gmem_A2l_Initialize (Program_Name.all); - - exception - when GNAT.Command_Line.Invalid_Switch => - Ada.Text_IO.Put_Line ("Invalid switch : " - & GNAT.Command_Line.Full_Switch); - Usage; - end Process_Arguments; - - -- Local variables - - Cur_Elmt : Storage_Elmt; - Buff : String (1 .. 16); - --- Start of processing for Gnatmem - -begin - Process_Arguments; - - if Dump_Log_Mode then - Put_Line ("Full dump of dynamic memory operations history"); - Put_Line ("----------------------------------------------"); - - declare - function CTime (Clock : Address) return Address; - pragma Import (C, CTime, "ctime"); - - Int_T0 : Integer := Integer (T0); - CTime_Addr : constant Address := CTime (Int_T0'Address); - - Buffer : String (1 .. 30); - for Buffer'Address use CTime_Addr; - - begin - Put_Line ("Log started at T0 =" & Duration'Image (T0) & " (" - & Buffer (1 .. 24) & ")"); - end; - end if; - - -- Main loop analysing the data generated by the instrumented routines. - -- For each allocation, the backtrace is kept and stored in a htable - -- whose entry is the address. For each deallocation, we look for the - -- corresponding allocation and cancel it. - - Main : loop - Cur_Elmt := Read_Next; - - case Cur_Elmt.Elmt is - when '*' => - exit Main; - - when 'A' => - - -- Read the corresponding back trace - - Tmp_Alloc.Root := Read_BT (BT_Depth); - - if Quiet_Mode then - - if Nb_Alloc (Tmp_Alloc.Root) = 0 then - Nb_Root := Nb_Root + 1; - end if; - - Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); - Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); - - elsif Cur_Elmt.Size > 0 then - - -- Update global counters if the allocated size is meaningful - - Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size; - Global_Nb_Alloc := Global_Nb_Alloc + 1; - - if Global_High_Water_Mark < Global_Alloc_Size then - Global_High_Water_Mark := Global_Alloc_Size; - end if; - - -- Update the number of allocation root if this is a new one - - if Nb_Alloc (Tmp_Alloc.Root) = 0 then - Nb_Root := Nb_Root + 1; - end if; - - -- Update allocation root specific counters - - Set_Alloc_Size (Tmp_Alloc.Root, - Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size); - - Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); - - if High_Water_Mark (Tmp_Alloc.Root) < - Alloc_Size (Tmp_Alloc.Root) - then - Set_High_Water_Mark (Tmp_Alloc.Root, - Alloc_Size (Tmp_Alloc.Root)); - end if; - - -- Associate this allocation root to the allocated address - - Tmp_Alloc.Size := Cur_Elmt.Size; - Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); - - end if; - - when 'D' => - - -- Get the corresponding Dealloc_Size and Root - - Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address); - - if Tmp_Alloc.Root = No_Root_Id then - - -- There was no prior allocation at this address, something is - -- very wrong. Mark this allocation root as problematic. - - Tmp_Alloc.Root := Read_BT (BT_Depth); - - if Nb_Alloc (Tmp_Alloc.Root) = 0 then - Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); - Nb_Wrong_Deall := Nb_Wrong_Deall + 1; - end if; - - else - -- Update global counters - - if not Quiet_Mode then - Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size; - end if; - - Global_Nb_Dealloc := Global_Nb_Dealloc + 1; - - -- Update allocation root specific counters - - if not Quiet_Mode then - Set_Alloc_Size (Tmp_Alloc.Root, - Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size); - end if; - - Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); - - -- Update the number of allocation root if this one disappears - - if Nb_Alloc (Tmp_Alloc.Root) = 0 - and then Minimum_Nb_Leaks > 0 then - Nb_Root := Nb_Root - 1; - end if; - - -- Deassociate the deallocated address - - Address_HTable.Remove (Cur_Elmt.Address); - end if; - - when others => - raise Program_Error; - end case; - - if Dump_Log_Mode then - case Cur_Elmt.Elmt is - when 'A' => - Put ("ALLOC"); - Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16); - Put (Buff); - Int_IO.Put (Buff (1 .. 8), Integer (Cur_Elmt.Size)); - Put (Buff (1 .. 8) & " bytes at moment T0 +"); - Put_Line (Duration'Image (Cur_Elmt.Timestamp - T0)); - - when 'D' => - Put ("DEALL"); - Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16); - Put (Buff); - Put_Line (" at moment T0 +" - & Duration'Image (Cur_Elmt.Timestamp - T0)); - when others => - raise Program_Error; - end case; - - Print_BT (Tmp_Alloc.Root); - end if; - - end loop Main; - - -- Print out general information about overall allocation - - if not Quiet_Mode then - Put_Line ("Global information"); - Put_Line ("------------------"); - - Put (" Total number of allocations :"); - Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4); - New_Line; - - Put (" Total number of deallocations :"); - Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4); - New_Line; - - Put_Line (" Final Water Mark (non freed mem) :" - & Mem_Image (Global_Alloc_Size)); - Put_Line (" High Water Mark :" - & Mem_Image (Global_High_Water_Mark)); - New_Line; - end if; - - -- Print out the back traces corresponding to potential leaks in order - -- greatest number of non-deallocated allocations. - - Print_Back_Traces : declare - type Root_Array is array (Natural range <>) of Root_Id; - type Access_Root_Array is access Root_Array; - - Leaks : constant Access_Root_Array := - new Root_Array (0 .. Nb_Root); - Leak_Index : Natural := 0; - - Bogus_Dealls : constant Access_Root_Array := - new Root_Array (1 .. Nb_Wrong_Deall); - Deall_Index : Natural := 0; - Nb_Alloc_J : Natural := 0; - - procedure Move (From : Natural; To : Natural); - function Lt (Op1, Op2 : Natural) return Boolean; - package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt); - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - Leaks (To) := Leaks (From); - end Move; - - -------- - -- Lt -- - -------- - - function Lt (Op1, Op2 : Natural) return Boolean is - - function Apply_Sort_Criterion (S : Character) return Integer; - -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is - -- smaller than, equal, or greater than Op2 according to criterion. - - -------------------------- - -- Apply_Sort_Criterion -- - -------------------------- - - function Apply_Sort_Criterion (S : Character) return Integer is - LOp1, LOp2 : Integer; - - begin - case S is - when 'n' => - LOp1 := Nb_Alloc (Leaks (Op1)); - LOp2 := Nb_Alloc (Leaks (Op2)); - - when 'w' => - LOp1 := Integer (Alloc_Size (Leaks (Op1))); - LOp2 := Integer (Alloc_Size (Leaks (Op2))); - - when 'h' => - LOp1 := Integer (High_Water_Mark (Leaks (Op1))); - LOp2 := Integer (High_Water_Mark (Leaks (Op2))); - - when others => - return 0; -- Can't actually happen - end case; - - if LOp1 < LOp2 then - return -1; - elsif LOp1 > LOp2 then - return 1; - else - return 0; - end if; - - exception - when Constraint_Error => - return 0; - end Apply_Sort_Criterion; - - -- Local Variables - - Result : Integer; - - -- Start of processing for Lt - - begin - for S in Sort_Order'Range loop - Result := Apply_Sort_Criterion (Sort_Order (S)); - if Result = -1 then - return False; - elsif Result = 1 then - return True; - end if; - end loop; - return False; - end Lt; - - -- Start of processing for Print_Back_Traces - - begin - -- Transfer all the relevant Roots in the Leaks and a Bogus_Deall arrays - - Tmp_Alloc.Root := Get_First; - while Tmp_Alloc.Root /= No_Root_Id loop - if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_Nb_Leaks > 0 then - null; - - elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then - Deall_Index := Deall_Index + 1; - Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root; - - else - Leak_Index := Leak_Index + 1; - Leaks (Leak_Index) := Tmp_Alloc.Root; - end if; - - Tmp_Alloc.Root := Get_Next; - end loop; - - -- Print out wrong deallocations - - if Nb_Wrong_Deall > 0 then - Put_Line ("Releasing deallocated memory at :"); - if not Quiet_Mode then - Put_Line ("--------------------------------"); - end if; - - for J in 1 .. Bogus_Dealls'Last loop - Print_BT (Bogus_Dealls (J), Short => Quiet_Mode); - New_Line; - end loop; - end if; - - -- Print out all allocation Leaks - - if Leak_Index > 0 then - - -- Sort the Leaks so that potentially important leaks appear first - - Root_Sort.Sort (Leak_Index); - - for J in 1 .. Leak_Index loop - Nb_Alloc_J := Nb_Alloc (Leaks (J)); - - if Nb_Alloc_J >= Minimum_Nb_Leaks then - if Quiet_Mode then - if Nb_Alloc_J = 1 then - Put_Line (" 1 leak at :"); - else - Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :"); - end if; - - else - Put_Line ("Allocation Root #" & Integer'Image (J)); - Put_Line ("-------------------"); - - Put (" Number of non freed allocations :"); - Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4); - New_Line; - - Put_Line - (" Final Water Mark (non freed mem) :" - & Mem_Image (Alloc_Size (Leaks (J)))); - - Put_Line - (" High Water Mark :" - & Mem_Image (High_Water_Mark (Leaks (J)))); - - Put_Line (" Backtrace :"); - end if; - - Print_BT (Leaks (J), Short => Quiet_Mode); - New_Line; - end if; - end loop; - end if; - end Print_Back_Traces; -end Gnatmem; diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb deleted file mode 100644 index 3aae5c4..0000000 --- a/gcc/ada/memroot.adb +++ /dev/null @@ -1,615 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M E M R O O T -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Table; -with GNAT.HTable; use GNAT.HTable; -with Ada.Text_IO; use Ada.Text_IO; - -package body Memroot is - - Main_Name_Id : Name_Id; - -- The constant "main" where we should stop the backtraces - - ------------- - -- Name_Id -- - ------------- - - package Chars is new GNAT.Table ( - Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 10_000, - Table_Increment => 100); - -- The actual character container for names - - type Name is record - First, Last : Integer; - end record; - - package Names is new GNAT.Table ( - Table_Component_Type => Name, - Table_Index_Type => Name_Id, - Table_Low_Bound => 0, - Table_Initial => 400, - Table_Increment => 100); - - type Name_Range is range 1 .. 1023; - - function Name_Eq (N1, N2 : Name) return Boolean; - -- compare 2 names - - function H (N : Name) return Name_Range; - - package Name_HTable is new GNAT.HTable.Simple_HTable ( - Header_Num => Name_Range, - Element => Name_Id, - No_Element => No_Name_Id, - Key => Name, - Hash => H, - Equal => Name_Eq); - - -------------- - -- Frame_Id -- - -------------- - - type Frame is record - Name, File, Line : Name_Id; - end record; - - function Image - (F : Frame_Id; - Max_Fil : Integer; - Max_Lin : Integer; - Short : Boolean := False) return String; - -- Returns an image for F containing the file name, the Line number, - -- and if 'Short' is not true, the subprogram name. When possible, spaces - -- are inserted between the line number and the subprogram name in order - -- to align images of the same frame. Alignment is computed with Max_Fil - -- & Max_Lin representing the max number of character in a filename or - -- length in a given frame. - - package Frames is new GNAT.Table ( - Table_Component_Type => Frame, - Table_Index_Type => Frame_Id, - Table_Low_Bound => 1, - Table_Initial => 400, - Table_Increment => 100); - - type Frame_Range is range 1 .. 10000; - function H (N : Integer_Address) return Frame_Range; - - package Frame_HTable is new GNAT.HTable.Simple_HTable ( - Header_Num => Frame_Range, - Element => Frame_Id, - No_Element => No_Frame_Id, - Key => Integer_Address, - Hash => H, - Equal => "="); - - ------------- - -- Root_Id -- - ------------- - - type Root is record - First, Last : Integer; - Nb_Alloc : Integer; - Alloc_Size : Storage_Count; - High_Water_Mark : Storage_Count; - end record; - - package Frames_In_Root is new GNAT.Table ( - Table_Component_Type => Frame_Id, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 400, - Table_Increment => 100); - - package Roots is new GNAT.Table ( - Table_Component_Type => Root, - Table_Index_Type => Root_Id, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100); - type Root_Range is range 1 .. 513; - - function Root_Eq (N1, N2 : Root) return Boolean; - function H (B : Root) return Root_Range; - - package Root_HTable is new GNAT.HTable.Simple_HTable ( - Header_Num => Root_Range, - Element => Root_Id, - No_Element => No_Root_Id, - Key => Root, - Hash => H, - Equal => Root_Eq); - - ---------------- - -- Alloc_Size -- - ---------------- - - function Alloc_Size (B : Root_Id) return Storage_Count is - begin - return Roots.Table (B).Alloc_Size; - end Alloc_Size; - - ----------------- - -- Enter_Frame -- - ----------------- - - function Enter_Frame - (Addr : System.Address; - Name : Name_Id; - File : Name_Id; - Line : Name_Id) - return Frame_Id - is - begin - Frames.Increment_Last; - Frames.Table (Frames.Last) := Frame'(Name, File, Line); - - Frame_HTable.Set (To_Integer (Addr), Frames.Last); - return Frames.Last; - end Enter_Frame; - - ---------------- - -- Enter_Name -- - ---------------- - - function Enter_Name (S : String) return Name_Id is - Old_L : constant Integer := Chars.Last; - Len : constant Integer := S'Length; - F : constant Integer := Chars.Allocate (Len); - Res : Name_Id; - - begin - Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S); - Names.Increment_Last; - Names.Table (Names.Last) := Name'(F, F + Len - 1); - Res := Name_HTable.Get (Names.Table (Names.Last)); - - if Res /= No_Name_Id then - Names.Decrement_Last; - Chars.Set_Last (Old_L); - return Res; - - else - Name_HTable.Set (Names.Table (Names.Last), Names.Last); - return Names.Last; - end if; - end Enter_Name; - - ---------------- - -- Enter_Root -- - ---------------- - - function Enter_Root (Fr : Frame_Array) return Root_Id is - Old_L : constant Integer := Frames_In_Root.Last; - Len : constant Integer := Fr'Length; - F : constant Integer := Frames_In_Root.Allocate (Len); - Res : Root_Id; - - begin - Frames_In_Root.Table (F .. F + Len - 1) := - Frames_In_Root.Table_Type (Fr); - Roots.Increment_Last; - Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0); - Res := Root_HTable.Get (Roots.Table (Roots.Last)); - - if Res /= No_Root_Id then - Frames_In_Root.Set_Last (Old_L); - Roots.Decrement_Last; - return Res; - - else - Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last); - return Roots.Last; - end if; - end Enter_Root; - - --------------- - -- Frames_Of -- - --------------- - - function Frames_Of (B : Root_Id) return Frame_Array is - begin - return Frame_Array ( - Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last)); - end Frames_Of; - - --------------- - -- Get_First -- - --------------- - - function Get_First return Root_Id is - begin - return Root_HTable.Get_First; - end Get_First; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next return Root_Id is - begin - return Root_HTable.Get_Next; - end Get_Next; - - ------- - -- H -- - ------- - - function H (B : Root) return Root_Range is - - type Uns is mod 2 ** 32; - - function Rotate_Left (Value : Uns; Amount : Natural) return Uns; - pragma Import (Intrinsic, Rotate_Left); - - Tmp : Uns := 0; - - begin - for J in B.First .. B.Last loop - Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J)); - end loop; - - return Root_Range'First - + Root_Range'Base (Tmp mod Root_Range'Range_Length); - end H; - - function H (N : Name) return Name_Range is - function H is new Hash (Name_Range); - - begin - return H (String (Chars.Table (N.First .. N.Last))); - end H; - - function H (N : Integer_Address) return Frame_Range is - begin - return Frame_Range (1 + N mod Frame_Range'Range_Length); - end H; - - --------------------- - -- High_Water_Mark -- - --------------------- - - function High_Water_Mark (B : Root_Id) return Storage_Count is - begin - return Roots.Table (B).High_Water_Mark; - end High_Water_Mark; - - ----------- - -- Image -- - ----------- - - function Image (N : Name_Id) return String is - Nam : Name renames Names.Table (N); - - begin - return String (Chars.Table (Nam.First .. Nam.Last)); - end Image; - - function Image - (F : Frame_Id; - Max_Fil : Integer; - Max_Lin : Integer; - Short : Boolean := False) return String - is - Fram : Frame renames Frames.Table (F); - Fil : Name renames Names.Table (Fram.File); - Lin : Name renames Names.Table (Fram.Line); - Nam : Name renames Names.Table (Fram.Name); - - Fil_Len : constant Integer := Fil.Last - Fil.First + 1; - Lin_Len : constant Integer := Lin.Last - Lin.First + 1; - - use type Chars.Table_Type; - - Spaces : constant String (1 .. 80) := (1 .. 80 => ' '); - - Result : constant String := - String (Chars.Table (Fil.First .. Fil.Last)) - & ':' - & String (Chars.Table (Lin.First .. Lin.Last)); - begin - if Short then - return Result; - else - return Result - & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len) - & String (Chars.Table (Nam.First .. Nam.Last)); - end if; - end Image; - - ------------- - -- Name_Eq -- - ------------- - - function Name_Eq (N1, N2 : Name) return Boolean is - use type Chars.Table_Type; - begin - return - Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last); - end Name_Eq; - - -------------- - -- Nb_Alloc -- - -------------- - - function Nb_Alloc (B : Root_Id) return Integer is - begin - return Roots.Table (B).Nb_Alloc; - end Nb_Alloc; - - -------------- - -- Print_BT -- - -------------- - - procedure Print_BT (B : Root_Id; Short : Boolean := False) is - Max_Col_Width : constant := 35; - -- Largest filename length for which backtraces will be - -- properly aligned. Frames containing longer names won't be - -- truncated but they won't be properly aligned either. - - F : constant Frame_Array := Frames_Of (B); - - Max_Fil : Integer; - Max_Lin : Integer; - - begin - Max_Fil := 0; - Max_Lin := 0; - - for J in F'Range loop - declare - Fram : Frame renames Frames.Table (F (J)); - Fil : Name renames Names.Table (Fram.File); - Lin : Name renames Names.Table (Fram.Line); - - begin - Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1); - Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1); - end; - end loop; - - Max_Fil := Integer'Min (Max_Fil, Max_Col_Width); - - for J in F'Range loop - Put (" "); - Put_Line (Image (F (J), Max_Fil, Max_Lin, Short)); - end loop; - end Print_BT; - - ------------- - -- Read_BT -- - ------------- - - function Read_BT (BT_Depth : Integer) return Root_Id is - Max_Line : constant Integer := 500; - Curs1 : Integer; - Curs2 : Integer; - Line : String (1 .. Max_Line); - Last : Integer := 0; - Frames : Frame_Array (1 .. BT_Depth); - F : Integer := Frames'First; - Nam : Name_Id; - Fil : Name_Id; - Lin : Name_Id; - Add : System.Address; - Int_Add : Integer_Address; - Fr : Frame_Id; - Main_Found : Boolean := False; - pragma Warnings (Off, Line); - - procedure Find_File; - pragma Inline (Find_File); - -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains - -- the file name. The file name may not be on the current line since - -- a frame may be printed on more than one line when there is a lot - -- of parameters or names are long, so this subprogram can read new - -- lines of input. - - procedure Find_Line; - pragma Inline (Find_Line); - -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains - -- the line number. - - procedure Find_Name; - pragma Inline (Find_Name); - -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains - -- the subprogram name. - - function Skip_To_Space (Pos : Integer) return Integer; - pragma Inline (Skip_To_Space); - -- Scans Line starting with position Pos, returning the position - -- immediately before the first space, or the value of Last if no - -- spaces were found - - --------------- - -- Find_File -- - --------------- - - procedure Find_File is - begin - -- Skip " at " - - Curs1 := Curs2 + 5; - Curs2 := Last; - - -- Scan backwards from end of line until ':' is encountered - - for J in reverse Curs1 .. Last loop - if Line (J) = ':' then - Curs2 := J - 1; - end if; - end loop; - end Find_File; - - --------------- - -- Find_Line -- - --------------- - - procedure Find_Line is - begin - Curs1 := Curs2 + 2; - Curs2 := Last; - - -- Check for Curs1 too large. Should never happen with non-corrupt - -- output. If it does happen, just reset it to the highest value. - - if Curs1 > Last then - Curs1 := Last; - end if; - end Find_Line; - - --------------- - -- Find_Name -- - --------------- - - procedure Find_Name is - begin - -- Skip the address value and " in " - - Curs1 := Skip_To_Space (1) + 5; - Curs2 := Skip_To_Space (Curs1); - end Find_Name; - - ------------------- - -- Skip_To_Space -- - ------------------- - - function Skip_To_Space (Pos : Integer) return Integer is - begin - for Cur in Pos .. Last loop - if Line (Cur) = ' ' then - return Cur - 1; - end if; - end loop; - - return Last; - end Skip_To_Space; - - procedure Gmem_Read_Next_Frame (Addr : out System.Address); - pragma Import (C, Gmem_Read_Next_Frame, "__gnat_gmem_read_next_frame"); - -- Read the next frame in the current traceback. Addr is set to 0 if - -- there are no more addresses in this traceback. The pointer is moved - -- to the next frame. - - procedure Gmem_Symbolic - (Addr : System.Address; Buf : String; Last : out Natural); - pragma Import (C, Gmem_Symbolic, "__gnat_gmem_symbolic"); - -- Get the symbolic traceback for Addr. Note: we cannot use - -- GNAT.Tracebacks.Symbolic, since the latter will only work with the - -- current executable. - -- - -- "__gnat_gmem_symbolic" will work with the executable whose name is - -- given in gnat_argv[0], as initialized by Gnatmem.Gmem_A21_Initialize. - - -- Start of processing for Read_BT - - begin - while F <= BT_Depth and then not Main_Found loop - Gmem_Read_Next_Frame (Add); - Int_Add := To_Integer (Add); - exit when Int_Add = 0; - - Fr := Frame_HTable.Get (Int_Add); - - if Fr = No_Frame_Id then - Gmem_Symbolic (Add, Line, Last); - Last := Last - 1; -- get rid of the trailing line-feed - Find_Name; - - -- Skip the __gnat_malloc frame itself - - if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then - Nam := Enter_Name (Line (Curs1 .. Curs2)); - Main_Found := (Nam = Main_Name_Id); - - Find_File; - Fil := Enter_Name (Line (Curs1 .. Curs2)); - Find_Line; - Lin := Enter_Name (Line (Curs1 .. Curs2)); - - Frames (F) := Enter_Frame (Add, Nam, Fil, Lin); - F := F + 1; - end if; - - else - Frames (F) := Fr; - Main_Found := (Memroot.Frames.Table (Fr).Name = Main_Name_Id); - F := F + 1; - end if; - end loop; - - return Enter_Root (Frames (1 .. F - 1)); - end Read_BT; - - ------------- - -- Root_Eq -- - ------------- - - function Root_Eq (N1, N2 : Root) return Boolean is - use type Frames_In_Root.Table_Type; - - begin - return - Frames_In_Root.Table (N1.First .. N1.Last) - = Frames_In_Root.Table (N2.First .. N2.Last); - end Root_Eq; - - -------------------- - -- Set_Alloc_Size -- - -------------------- - - procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is - begin - Roots.Table (B).Alloc_Size := V; - end Set_Alloc_Size; - - ------------------------- - -- Set_High_Water_Mark -- - ------------------------- - - procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is - begin - Roots.Table (B).High_Water_Mark := V; - end Set_High_Water_Mark; - - ------------------ - -- Set_Nb_Alloc -- - ------------------ - - procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is - begin - Roots.Table (B).Nb_Alloc := V; - end Set_Nb_Alloc; - -begin - -- Initialize name for No_Name_ID - - Names.Increment_Last; - Names.Table (Names.Last) := Name'(1, 0); - Main_Name_Id := Enter_Name ("main"); -end Memroot; diff --git a/gcc/ada/memroot.ads b/gcc/ada/memroot.ads deleted file mode 100644 index 484b621..0000000 --- a/gcc/ada/memroot.ads +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M E M R O O T -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- This package offers basic types that deal with gdb backtraces related --- to memory allocation. A memory root (root_id) is a backtrace --- referencing the actual point of allocation along with counters --- recording various information concerning allocation at this root. - --- A back trace is composed of Frames (Frame_Id) which themselves are --- nothing else than a subprogram call at a source location which can be --- represented by three strings: subprogram name, file name and line --- number. All the needed strings are entered in a table and referenced --- through a Name_Id in order to avoid duplication. - -with System.Storage_Elements; use System.Storage_Elements; - -package Memroot is - - -- Simple abstract type for names. A name is a sequence of letters - - type Name_Id is new Natural; - No_Name_Id : constant Name_Id := 0; - - function Enter_Name (S : String) return Name_Id; - function Image (N : Name_Id) return String; - - -- Simple abstract type for a backtrace frame. A frame is composed by - -- a subprogram name, a file name and a line reference. - - type Frame_Id is new Natural; - No_Frame_Id : constant Frame_Id := 0; - - function Enter_Frame - (Addr : System.Address; - Name : Name_Id; - File : Name_Id; - Line : Name_Id) - return Frame_Id; - - type Frame_Array is array (Natural range <>) of Frame_Id; - - -- Simple abstract type for an allocation root. It is composed by a set - -- of frames, the number of allocation, the total size of allocated - -- memory, and the high water mark. An iterator is also provided to - -- iterate over all the entered allocation roots. - - type Root_Id is new Natural; - No_Root_Id : constant Root_Id := 0; - - function Read_BT (BT_Depth : Integer) return Root_Id; - -- Reads a backtrace whose maximum frame number is given by - -- BT_Depth and returns the corresponding Allocation root. - - function Enter_Root (Fr : Frame_Array) return Root_Id; - -- Create an allocation root from the frames that compose it - - function Frames_Of (B : Root_Id) return Frame_Array; - -- Retrieves the Frames of the root's backtrace - - procedure Print_BT (B : Root_Id; Short : Boolean := False); - -- Prints on standard out the backtrace associated with the root B - -- When Short is set to True, only the filename & line info is printed. - -- When it is set to false, the subprogram name is also printed. - - function Get_First return Root_Id; - function Get_Next return Root_Id; - -- Iterator to iterate over roots - - procedure Set_Nb_Alloc (B : Root_Id; V : Integer); - function Nb_Alloc (B : Root_Id) return Integer; - -- Access and modify the number of allocation counter associated with - -- this allocation root. If the value is negative, it means that this is - -- not an allocation root but a deallocation root (this can only happen - -- in erroneous situations where there are more frees than allocations). - - procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count); - function Alloc_Size (B : Root_Id) return Storage_Count; - -- Access and modify the total allocated memory counter associated with - -- this allocation root. - - procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count); - function High_Water_Mark (B : Root_Id) return Storage_Count; - -- Access and modify the high water mark associated with this - -- allocation root. The high water mark is the maximum value, over - -- time, of the Alloc_Size. - -end Memroot; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f29e747..f0e4c49 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9607,9 +9607,8 @@ package body Sem_Ch3 is -- on the partial view. Make them visible to component declarations. declare - D : Entity_Id; - -- Discriminant on T (full view) referencing expression on partial - -- view. + D : Entity_Id; + -- Discriminant on T (full view) referencing expr on partial view Prev_D : Entity_Id; -- Entity of corresponding discriminant on partial view @@ -9619,10 +9618,10 @@ package body Sem_Ch3 is -- syntactic copy on full view (which has been checked for -- conformance with partial view), only used here to post error -- message. + begin - D := First_Discriminant (T); + D := First_Discriminant (T); New_D := First (Discriminant_Specifications (N)); - while Present (D) loop Prev_D := Current_Entity (D); Set_Current_Entity (D); @@ -9639,8 +9638,7 @@ package body Sem_Ch3 is and then not Error_Posted (Expression (Parent (D))) then Error_Msg_N - ("discriminants of tagged type " - & "cannot have defaults", + ("discriminants of tagged type cannot have defaults", Expression (New_D)); end if; @@ -10765,7 +10763,7 @@ package body Sem_Ch3 is Next_Elmt (E); end loop; - -- The corresponding_Discriminant mechanism is incomplete, because + -- The Corresponding_Discriminant mechanism is incomplete, because -- the correspondence between new and old discriminants is not one -- to one: one new discriminant can constrain several old ones. In -- that case, scan sequentially the stored_constraint, the list of @@ -16387,16 +16385,15 @@ package body Sem_Ch3 is Expression (Discr)); elsif Is_Tagged_Type (Current_Scope) - and then Comes_From_Source (N) + and then Comes_From_Source (N) then - -- Note: see also similar test in Check_Or_Process_ - -- Discriminants, to handle the (illegal) case of the - -- completion of an untagged view with discriminants - -- with defaults by a tagged full view. We skip the check if - -- Discr does not come from source to account for the case of - -- an untagged derived type providing defaults for a renamed - -- discriminant from a private nontagged ancestor with a tagged - -- full view (ACATS B460006). + -- Note: see similar test in Check_Or_Process_Discriminants, to + -- handle the (illegal) case of the completion of an untagged + -- view with discriminants with defaults by a tagged full view. + -- We skip the check if Discr does not come from source to + -- account for the case of an untagged derived type providing + -- defaults for a renamed discriminant from a private nontagged + -- ancestor with a tagged full view (ACATS B460006). Error_Msg_N ("discriminants of tagged type cannot have defaults",