+2010-10-21 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb: Minor reformatting.
+
+2010-10-21 Thomas Quinot <quinot@adacore.com>
+
+ * einfo.ads (Next_Girder_Discriminant): Remove obsolete description for
+ removed routine.
+
+2010-10-21 Nicolas Roche <roche@adacore.com>
+
+ * gnatmem.adb, memroot.adb, memroot.ads, gmem.c,
+ gcc-interface/Makefile.in: Remove gnatmem specific files.
+
2010-10-21 Thomas Quinot <quinot@adacore.com>
* sem_res.adb, exp_ch13.adb: Minor reformatting.
-- 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
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
+++ /dev/null
-/****************************************************************************
- * *
- * 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 *
- * <http://www.gnu.org/licenses/>. *
- * *
- * 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 <string.h>
-#define xstrdup32(S) strcpy ((__char_ptr32) _malloc32 (strlen (S) + 1), S)
-#else
-#define xstrdup32(S) S
-#endif
-
-#include <stdio.h>
-
-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);
-}
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- 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
-- 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);
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;
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
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",
projects / platform / upstream / linaro-gcc.git / commitdiff