+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2003, Ada Core Technologies --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL 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 GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux version of this package
-
--- This file performs the system-dependent translation between machine
--- exceptions and the Ada exceptions, if any, that should be raised when they
--- occur. This version works for the x86 running linux.
-
--- This is a Sun OS (FSU THREADS) version of this package
-
--- PLEASE DO NOT add any dependences on other packages. ??? why not ???
--- This package is designed to work with or without tasking support.
-
--- Make a careful study of all signals available under the OS, to see which
--- need to be reserved, kept always unmasked, or kept always unmasked. Be on
--- the lookout for special signals that may be used by the thread library.
-
--- The definitions of "reserved" differ slightly between the ARM and POSIX.
--- Here is the ARM definition of reserved interrupt:
-
--- The set of reserved interrupts is implementation defined. A reserved
--- interrupt is either an interrupt for which user-defined handlers are not
--- supported, or one which already has an attached handler by some other
--- implementation-defined means. Program units can be connected to
--- non-reserved interrupts.
-
--- POSIX.5b/.5c specifies further:
-
--- Signals which the application cannot accept, and for which the application
--- cannot modify the signal action or masking, because the signals are
--- reserved for use by the Ada language implementation. The reserved signals
--- defined by this standard are Signal_Abort, Signal_Alarm,
--- Signal_Floating_Point_Error, Signal_Illegal_Instruction,
--- Signal_Segmentation_Violation, Signal_Bus_Error. If the implementation
--- supports any signals besides those defined by this standard, the
--- implementation may also reserve some of those.
-
--- The signals defined by POSIX.5b/.5c that are not specified as being
--- reserved are SIGHUP, SIGINT, SIGPIPE, SIGQUIT, SIGTERM, SIGUSR1, SIGUSR2,
--- SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO SIGURG, and all
--- the real-time signals.
-
--- Beware of reserving signals that POSIX.5b/.5c require to be available for
--- users. POSIX.5b/.5c say:
-
--- An implementation shall not impose restrictions on the ability of an
--- application to send, accept, block, or ignore the signals defined by this
--- standard, except as specified in this standard.
-
--- Here are some other relevant requirements from POSIX.5b/.5c:
-
--- For the environment task, the initial signal mask is that specified for
--- the process...
-
--- It is anticipated that the paragraph above may be modified by a future
--- revision of this standard, to require that the realtime signals always be
--- initially masked for a process that is an Ada active partition.
-
--- For all other tasks, the initial signal mask shall include all the signals
--- that are not reserved signals and are not bound to entries of the task.
-
-with Interfaces.C;
--- used for int and other types
-
-with System.Error_Reporting;
--- used for Shutdown
-
-with System.OS_Interface;
--- used for various Constants, Signal and types
-
-with Ada.Exceptions;
--- used for Exception_Id
--- Raise_From_Signal_Handler
-
-with System.Soft_Links;
--- used for Get_Machine_State_Addr
-
-with Unchecked_Conversion;
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.Error_Reporting;
- use System.OS_Interface;
-
- package TSL renames System.Soft_Links;
-
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
- Exception_Interrupts : constant Interrupt_List :=
- (SIGFPE, SIGILL, SIGSEGV);
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- subtype int is Interfaces.C.int;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- pragma Warnings (Off);
- -- Because many unaccessed arguments
-
- Signal_Mask : aliased sigset_t;
- -- The set of signals handled by Notify_Exception
-
- -- This function identifies the Ada exception to be raised using
- -- the information when the system received a synchronous signal.
- -- Since this function is machine and OS dependent, different code
- -- has to be provided for different target.
-
- procedure Notify_Exception
- (signo : Signal;
- gs : unsigned_short;
- fs : unsigned_short;
- es : unsigned_short;
- ds : unsigned_short;
- edi : unsigned_long;
- esi : unsigned_long;
- ebp : unsigned_long;
- esp : unsigned_long;
- ebx : unsigned_long;
- edx : unsigned_long;
- ecx : unsigned_long;
- eax : unsigned_long;
- trapno : unsigned_long;
- err : unsigned_long;
- eip : unsigned_long;
- cs : unsigned_short;
- eflags : unsigned_long;
- esp_at_signal : unsigned_long;
- ss : unsigned_short;
- fpstate : System.Address;
- oldmask : unsigned_long;
- cr2 : unsigned_long);
-
- procedure Notify_Exception
- (signo : Signal;
- gs : unsigned_short;
- fs : unsigned_short;
- es : unsigned_short;
- ds : unsigned_short;
- edi : unsigned_long;
- esi : unsigned_long;
- ebp : unsigned_long;
- esp : unsigned_long;
- ebx : unsigned_long;
- edx : unsigned_long;
- ecx : unsigned_long;
- eax : unsigned_long;
- trapno : unsigned_long;
- err : unsigned_long;
- eip : unsigned_long;
- cs : unsigned_short;
- eflags : unsigned_long;
- esp_at_signal : unsigned_long;
- ss : unsigned_short;
- fpstate : System.Address;
- oldmask : unsigned_long;
- cr2 : unsigned_long)
- is
- pragma Warnings (On);
-
- function To_Machine_State_Ptr is new
- Unchecked_Conversion (Address, Machine_State_Ptr);
-
- -- These are not directly visible
-
- procedure Raise_From_Signal_Handler
- (E : Ada.Exceptions.Exception_Id;
- M : System.Address);
- pragma Import
- (Ada, Raise_From_Signal_Handler,
- "ada__exceptions__raise_from_signal_handler");
- pragma No_Return (Raise_From_Signal_Handler);
-
- mstate : Machine_State_Ptr;
- message : aliased constant String := "" & ASCII.Nul;
- -- A null terminated String.
-
- Result : int;
-
- begin
-
- -- Raise_From_Signal_Handler makes sure that the exception is raised
- -- safely from this signal handler.
-
- -- ??? The original signal mask (the one we had before coming into this
- -- signal catching function) should be restored by
- -- Raise_From_Signal_Handler. For now, restore it explicitely
-
- Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
- pragma Assert (Result = 0);
-
- -- Check that treatment of exception propagation here
- -- is consistent with treatment of the abort signal in
- -- System.Task_Primitives.Operations.
-
- mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all);
- mstate.eip := eip;
- mstate.ebx := ebx;
- mstate.esp := esp_at_signal;
- mstate.ebp := ebp;
- mstate.esi := esi;
- mstate.edi := edi;
-
- case signo is
- when SIGFPE =>
- Raise_From_Signal_Handler
- (Constraint_Error'Identity, message'Address);
- when SIGILL =>
- Raise_From_Signal_Handler
- (Constraint_Error'Identity, message'Address);
- when SIGSEGV =>
- Raise_From_Signal_Handler
- (Storage_Error'Identity, message'Address);
- when others =>
- if Shutdown ("Unexpected signal") then
- null;
- end if;
- end case;
- end Notify_Exception;
-
- ---------------------------
- -- Initialize_Interrupts --
- ---------------------------
-
- -- Nothing needs to be done on this platform.
-
- procedure Initialize_Interrupts is
- begin
- null;
- end Initialize_Interrupts;
-
-begin
- declare
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Result : int;
-
- function State (Int : Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
-
- User : constant Character := 'u';
- Runtime : constant Character := 'r';
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- begin
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- Abort_Task_Interrupt := SIGADAABORT;
-
- act.sa_handler := Notify_Exception'Address;
-
- act.sa_flags := 0;
-
- -- On some targets, we set sa_flags to SA_NODEFER so that during the
- -- handler execution we do not change the Signal_Mask to be masked for
- -- the Signal.
-
- -- This is a temporary fix to the problem that the Signal_Mask is
- -- not restored after the exception (longjmp) from the handler.
- -- The right fix should be made in sigsetjmp so that we save
- -- the Signal_Set and restore it after a longjmp.
-
- -- Since SA_NODEFER is obsolete, instead we reset explicitely
- -- the mask in the exception handler.
-
- Result := sigemptyset (Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- -- Add signals that map to Ada exceptions to the mask.
-
- for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= Default then
- Result :=
- sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- act.sa_mask := Signal_Mask;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- -- Process state of exception signals
-
- for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= User then
- Keep_Unmasked (Exception_Interrupts (J)) := True;
- Reserve (Exception_Interrupts (J)) := True;
-
- if State (Exception_Interrupts (J)) /= Default then
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end if;
- end if;
- end loop;
-
- if State (Abort_Task_Interrupt) /= User then
- Keep_Unmasked (Abort_Task_Interrupt) := True;
- Reserve (Abort_Task_Interrupt) := True;
- end if;
-
- -- Set SIGINT to unmasked state as long as it's
- -- not in "User" state. Check for Unreserve_All_Interrupts last
-
- if State (SIGINT) /= User then
- Keep_Unmasked (SIGINT) := True;
- Reserve (SIGINT) := True;
- end if;
-
- -- Check all signals for state that requires keeping them
- -- unmasked and reserved
-
- for J in Interrupt_ID'Range loop
- if State (J) = Default or else State (J) = Runtime then
- Keep_Unmasked (J) := True;
- Reserve (J) := True;
- end if;
- end loop;
-
- -- Add the set of signals that must always be unmasked for this target
-
- for J in Unmasked'Range loop
- Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
- Reserve (Interrupt_ID (Unmasked (J))) := True;
- end loop;
-
- -- Add target-specific reserved signals
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- Process pragma Unreserve_All_Interrupts. This overrides any
- -- settings due to pragma Interrupt_State:
-
- if Unreserve_All_Interrupts /= 0 then
- Keep_Unmasked (SIGINT) := False;
- Reserve (SIGINT) := False;
- end if;
-
- -- We do not have Signal 0 in reality. We just use this value
- -- to identify non-existent signals (see s-intnam.ads). Therefore,
- -- Signal 0 should not be used in all signal related operations hence
- -- mark it as reserved.
-
- Reserve (0) := True;
- end;
-end System.Interrupt_Management;
+2003-12-03 Thomas Quinot <quinot@act-europe.fr>
+
+ PR ada/11724
+
+ * adaint.h, adaint.c, g-os_lib.ads:
+ Do not assume that the offset argument to lseek(2) is a 32 bit integer,
+ on some platforms (including FreeBSD), it is a 64 bit value.
+ Introduce a __gnat_lseek wrapper in adaint.c to allow for portability.
+
+2003-12-03 Arnaud Charlet <charlet@act-europe.fr>
+
+ * gnatvsn.ads (Library_Version): Now contain only the relevant
+ version info.
+ (Verbose_Library_Version): New constant.
+
+ * g-spipat.adb, g-awk.adb, g-debpoo.adb,
+ g-memdum.adb, g-thread.adb, s-geveop.adb, s-interr.adb,
+ s-taskin.adb, s-tassta.adb: Make code compile with -gnatwa.
+
+ * gnatlbr.adb: Clean up: replace Library_Version by
+ Verbose_Library_Version.
+
+ * make.adb, lib-writ.adb, exp_attr.adb:
+ Clean up: replace Library_Version by Verbose_Library_Version.
+
+ * 5lintman.adb: Removed.
+
+ * Makefile.in:
+ Update and simplify computation of LIBRARY_VERSION.
+ Fix computation of GSMATCH_VERSION.
+ 5lintman.adb is no longer used: replaced by 7sintman.adb.
+
+2003-12-03 Robert Dewar <dewar@gnat.com>
+
+ * exp_ch5.adb:
+ (Possible_Bit_Aligned_Component): Maybe_Bit_Aligned_Large_Component new
+ name. Modified to consider small non-bit-packed arrays as troublesome
+ and in need of component-by-component assigment expansion.
+
+2003-12-03 Vincent Celier <celier@gnat.com>
+
+ * lang-specs.h: Process nostdlib as nostdinc
+
+ * back_end.adb: Update Copyright notice
+ (Scan_Compiler_Arguments): Process -nostdlib directly.
+
+2003-12-03 Jose Ruiz <ruiz@act-europe.fr>
+
+ * Makefile.in:
+ When defining LIBGNAT_TARGET_PAIRS for bare board targets, remove the
+ redundant inclusion of EXTRA_HIE_NONE_TARGET_PAIRS, which is always
+ included in HIE_NONE_TARGET_PAIRS.
+
+2003-12-03 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_attr.adb:
+ (Legal_Formal_Attribute): Attribute is legal in an inlined body, as it
+ is legal in an instance, because legality is cheched in the template.
+
+ * sem_prag.adb:
+ (Analyze_Pragma, case Warnings): In an inlined body, the pragma may be
+ appplied to an unchecked conversion of a formal parameter.
+
+ * sem_warn.adb:
+ (Output_Unreferenced_Messages): Suppress "not read" warnings on imported
+ variables.
+
+2003-12-03 Olivier Hainque <hainque@act-europe.fr>
+
+ * tb-alvms.c (unwind_regular_code, unwind_kernel_handler): New
+ routines. The second one is new functionality to deal with backtracing
+ through signal handlers.
+ (unwind): Split into the two separate subroutines above.
+ Update the documentation, and deal properly with sizeof (REG) different
+ from sizeof (void*).
+
2003-12-01 Nicolas Setton <setton@act-europe.fr>
* a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point,
../../libiberty/xstrdup.o \
../../libiberty/xexit.o
+LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
+
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
# $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match.
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
system.ads<59system.ads
LIBGNAT_TARGET_PAIRS = \
- $(HIE_NONE_TARGET_PAIRS) \
- $(EXTRA_HIE_NONE_TARGET_PAIRS)
+ $(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
system.ads<5rsystem.ads
LIBGNAT_TARGET_PAIRS = \
- $(HIE_NONE_TARGET_PAIRS) \
- $(EXTRA_HIE_NONE_TARGET_PAIRS)
+ $(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<5iosinte.adb \
s-osinte.ads<5iosinte.ads \
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<7sosinte.adb \
s-osinte.ads<5losinte.ads \
system.ads<56system.ads
THREADSLIB=
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
SO_OPTS = -Wl,+h,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
../../gnatlbr$(exeext) \
,,/../gnatsym$(exeext)
# This command transforms (YYYYMMDD) into YY,MMDD
- GSMATCH_VERSION := $(shell grep "^ *Gnat_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/' -e 's/\./_/g'))
+ GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
endif
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
soext = .dll
GNATLIB_SHARED = gnatlib-shared-win32
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<5lintman.adb \
+ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+ LIBRARY_VERSION := $(LIB_VERSION)
endif
# The runtime library for gnat comprises two directories. One contains the
a no-op in this case. */
#endif
}
+
+int
+__gnat_lseek (int fd, long offset, int whence)
+{
+ return (int) lseek (fd, offset, whence);
+}
extern void __gnat_set_binary_mode (int);
extern void __gnat_set_text_mode (int);
extern char *__gnat_ttyname (int);
+extern int __gnat_lseek (int, long, int);
#ifdef __MINGW32__
extern void __gnat_plist_init (void);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
Opt.No_Stdinc := True;
Scan_Back_End_Switches (Argv);
+ -- We must recognize -nostdlib to suppress visibility on the
+ -- standard GNAT RTL objects.
+
+ elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
+ Opt.No_Stdlib := True;
+
elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv);
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
- Name_Buffer (1 .. Library_Version'Length) := Library_Version;
- Name_Len := Library_Version'Length;
+ Name_Buffer (1 .. Verbose_Library_Version'Length) :=
+ Verbose_Library_Version;
+ Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- either because the target is not byte aligned, or there is a change
-- of representation.
- function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
- -- This function is used in processing the assignment of a record or
- -- indexed component. The back end can handle such assignments fine
- -- if the objects involved are small (64-bits) or are both aligned on
- -- a byte boundary (starts on a byte, and ends on a byte). However,
- -- problems arise for large components that are not byte aligned,
- -- since the assignment may clobber other components that share bit
- -- positions in the starting or ending bytes, and in the case of
- -- components not starting on a byte boundary, the back end cannot
- -- even manage to extract the value. This function is used to detect
- -- such situations, so that the assignment can be handled component-wise.
- -- A value of False means that either the object is known to be greater
- -- than 64 bits, or that it is known to be byte aligned (and occupy an
- -- integral number of bytes. True is returned if the object is known to
- -- be greater than 64 bits, and is known to be unaligned. As implied
- -- by the name, the result is conservative, in that if the compiler
- -- cannot determine these conditions at compile time, True is returned.
-
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
-- that is to say, finalization of the target before, adjustement of
-- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node.
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
+ -- This function is used in processing the assignment of a record or
+ -- indexed component. The back end can handle such assignments fine
+ -- if the objects involved are small (64-bits or less) records or
+ -- scalar items (including bit-packed arrays represented with modular
+ -- types) or are both aligned on a byte boundary (starting on a byte
+ -- boundary, and occupying an integral number of bytes).
+ --
+ -- However, problems arise for records larger than 64 bits, or for
+ -- arrays (other than bit-packed arrays represented with a modular
+ -- type) if the component starts on a non-byte boundary, or does
+ -- not occupy an integral number of bytes (i.e. there are some bits
+ -- possibly shared with fields at the start or beginning of the
+ -- component). The back end cannot handle loading and storing such
+ -- components in a single operation.
+ --
+ -- This function is used to detect the troublesome situation. it is
+ -- conservative in the sense that it produces True unless it knows
+ -- for sure that the component is safe (as outlined in the first
+ -- paragraph above). The code generation for record and array
+ -- assignment checks for trouble using this function, and if so
+ -- the assignment is generated component-wise, which the back end
+ -- is required to handle correctly.
+ --
+ -- Note that in GNAT 3, the back end will reject such components
+ -- anyway, so the hard work in checking for this case is wasted
+ -- in GNAT 3, but it's harmless, so it is easier to do it in
+ -- all cases, rather than conditionalize it in GNAT 5 or beyond.
+
------------------------------
-- Change_Of_Representation --
------------------------------
function Change_Of_Representation (N : Node_Id) return Boolean is
Rhs : constant Node_Id := Expression (N);
-
begin
return
Nkind (Rhs) = N_Type_Conversion
-- We require a loop if the left side is possibly bit unaligned
- elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ elsif Possible_Bit_Aligned_Component (Lhs)
or else
- Maybe_Bit_Aligned_Large_Component (Rhs)
+ Possible_Bit_Aligned_Component (Rhs)
then
Loop_Required := True;
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
- elsif Maybe_Bit_Aligned_Large_Component (Lhs)
+ elsif Possible_Bit_Aligned_Component (Lhs)
or
- Maybe_Bit_Aligned_Large_Component (Rhs)
+ Possible_Bit_Aligned_Component (Rhs)
then
null;
return Empty_List;
end Make_Tag_Ctrl_Assignment;
- ---------------------------------------
- -- Maybe_Bit_Aligned_Large_Component --
- ---------------------------------------
+ ------------------------------------
+ -- Possible_Bit_Aligned_Component --
+ ------------------------------------
- function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean is
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
begin
case Nkind (N) is
-- indexing from a possibly unaligned component.
else
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
end if;
end;
-- only the recursive test on the prefix.
if No (Component_Clause (Comp)) then
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
-- Otherwise we have a component clause, which means that
-- the Esize and Normalized_First_Bit fields are set and
-- contain static values known at compile time.
else
- -- If we know the size is 64 bits or less we are fine
- -- since the back end always handles small fields right.
-
- if Esize (Comp) <= 64 then
+ -- If we know that we have a small (64 bits or less) record
+ -- or bit-packed array, then everything is fine, since the
+ -- back end can handle these cases correctly.
+
+ if Esize (Comp) <= 64
+ and then (Is_Record_Type (Etype (Comp))
+ or else
+ Is_Bit_Packed_Array (Etype (Comp)))
+ then
return False;
-- Otherwise if the component is not byte aligned, we
-- but we still need to test our prefix recursively.
else
- return Maybe_Bit_Aligned_Large_Component (P);
+ return Possible_Bit_Aligned_Component (P);
end if;
end if;
end;
return False;
end case;
- end Maybe_Bit_Aligned_Large_Component;
+ end Possible_Bit_Aligned_Component;
end Exp_Ch5;
Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session)
is
- Filter_Active : Boolean;
- Quit : Boolean;
+ Quit : Boolean;
begin
Open (Separators, Filename, Session);
Split_Line (Session);
if Callbacks in Only .. Pass_Through then
- Filter_Active := Apply_Filters (Session);
+ declare
+ Discard : Boolean;
+ pragma Unreferenced (Discard);
+ begin
+ Discard := Apply_Filters (Session);
+ end;
end if;
if Callbacks /= Only then
return Tracebacks_Array_Access;
function Hash (T : Tracebacks_Array_Access) return Header;
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
- pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
+ pragma Inline (Set_Next, Next, Get_Key, Hash);
-- Subprograms required for instantiation of the htable. See GNAT.HTable.
package Backtrace_Htable is new GNAT.HTable.Static_HTable
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
use Ada.Exceptions.Traceback;
-
begin
return K1.all = K2.all;
end Equal;
Line_Buf : String (1 .. Line_Len);
- Hex : array (0 .. 15) of Character := "0123456789ABCDEF";
+ Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF";
type Char_Ptr is access all Character;
(FD : File_Descriptor;
offset : Long_Integer;
origin : Integer);
- pragma Import (C, Lseek, "lseek");
+ pragma Import (C, Lseek, "__gnat_lseek");
-- Sets the current file pointer to the indicated offset value,
-- relative to the current position (origin = SEEK_CUR), end of
-- file (origin = SEEK_END), or start of file (origin = SEEK_SET).
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002, Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- structure (i.e. it is a pattern that is guaranteed to match at least
-- one character on success, and not to make any entries on the stack.
- OK_For_Simple_Arbno :
- array (Pattern_Code) of Boolean := (
- PC_Any_CS |
- PC_Any_CH |
- PC_Any_VF |
- PC_Any_VP |
- PC_Char |
- PC_Len_Nat |
- PC_NotAny_CS |
- PC_NotAny_CH |
- PC_NotAny_VF |
- PC_NotAny_VP |
- PC_Span_CS |
- PC_Span_CH |
- PC_Span_VF |
- PC_Span_VP |
- PC_String |
- PC_String_2 |
- PC_String_3 |
- PC_String_4 |
- PC_String_5 |
- PC_String_6 => True,
-
- others => False);
+ OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
+ (PC_Any_CS |
+ PC_Any_CH |
+ PC_Any_VF |
+ PC_Any_VP |
+ PC_Char |
+ PC_Len_Nat |
+ PC_NotAny_CS |
+ PC_NotAny_CH |
+ PC_NotAny_VF |
+ PC_NotAny_VP |
+ PC_Span_CS |
+ PC_Span_CH |
+ PC_Span_VF |
+ PC_Span_VP |
+ PC_String |
+ PC_String_2 |
+ PC_String_3 |
+ PC_String_4 |
+ PC_String_5 |
+ PC_String_6 => True,
+ others => False);
-------------------------------
-- The Pattern History Stack --
(Code : Address;
Parm : Void_Ptr;
Size : Natural;
- Prio : Integer)
- return System.Address
+ Prio : Integer) return System.Address
is
TP : Tptr;
procedure Unregister_Thread is
Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
-
begin
Self_Id.Common.State := Tasking.Terminated;
Destroy_TSD (Self_Id.Common.Compiler_Data);
procedure Destroy_Thread (Id : Address) is
Tid : constant Task_Id := To_Id (Id);
-
begin
Abort_Task (Tid);
end Destroy_Thread;
procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface;
-
- Thr : Thread_Id_Ptr := To_Thread (Thread);
-
+ Thr : constant Thread_Id_Ptr := To_Thread (Thread);
begin
Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread;
----------------
function To_Task_Id
- (Id : System.Address)
- return Ada.Task_Identification.Task_Id
+ (Id : System.Address) return Ada.Task_Identification.Task_Id
is
begin
return To_Tid (Id);
& F_ADC_File (1 .. F_ADC_File_Len));
Make_Args (6) :=
- new String'("LIBRARY_VERSION=" & '"' & Library_Version & '"');
+ new String'("LIBRARY_VERSION=" & '"' &
+ Verbose_Library_Version & '"');
Make_Args (7) :=
new String'("-f");
-- value should never be decreased in the future, but it would be
-- OK to increase it if absolutely necessary.
- Library_Version : constant String := "GNAT Lib v3.4";
+ Library_Version : constant String := "3.4";
-- Library version. This value must be updated whenever any change to the
-- compiler affects the library formats in such a way as to obsolete
-- previously compiled library modules.
-- Note: Makefile.in relies on the precise format of the library version
-- string in order to correctly construct the soname value.
+ Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version;
+ -- Version string stored in e.g. ALI files.
+
ASIS_Version_Number : constant := 2;
-- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees, and an ASIS application that is reading the
%{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\
%eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
+ %{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \
Write_Info_Initiate ('V');
Write_Info_Str (" """);
- Write_Info_Str (Library_Version);
+ Write_Info_Str (Verbose_Library_Version);
Write_Info_Char ('"');
Write_Info_EOL;
return;
elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /=
- Library_Version
+ Verbose_Library_Version
then
Verbose_Msg (Full_Lib_File, "compiled with old GNAT version");
ALI := No_ALI_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2003 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- --
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
- SA : Address := XA + ((Length + 0) / VU * VU
+ SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
- SA : Address := XA + ((Length + 0) / VU * VU
+ SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
end if;
- if (New_Handler = null) then
+ if New_Handler = null then
if Old_Handler /= null then
Unbind_Handler (Interrupt);
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
All_Tasks_List := T;
end Initialize_ATCB;
- Main_Task_Image : String := "main_task";
+ Main_Task_Image : constant String := "main_task";
-- Image of environment task.
Main_Priority : Integer;
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
- Excep : Exception_Occurrence_Access := SSL.Get_Current_Excep.all;
+ Excep : constant Exception_Occurrence_Access :=
+ SSL.Get_Current_Excep.all;
begin
-- This procedure is called by the task outermost handler in
Error_Attr ("prefix of % attribute must be generic type", N);
elsif Is_Generic_Actual_Type (Entity (P))
- or In_Instance
+ or else In_Instance
+ or else In_Inlined_Body
then
null;
E_Id := Expression (Arg2);
Analyze (E_Id);
+ if In_Instance_Body
+ and then Nkind (E_Id) = N_Unchecked_Type_Conversion
+ then
+ E_Id := Expression (E_Id);
+ end if;
+
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name",
when E_Variable =>
-- Case of variable that is assigned but not read. We
- -- suppress the message if the variable is volatile or
- -- has an address clause.
+ -- suppress the message if the variable is volatile,
+ -- has an address clause, or is imported.
if Referenced_As_LHS (E)
and then No (Address_Clause (E))
and then not Is_Volatile (E)
then
- if Warn_On_Modified_Unread then
+ if Warn_On_Modified_Unread
+ and then not Is_Imported (E)
+ then
Error_Msg_N
("variable & is assigned but never read?", E);
end if;
document, sections of which we will refer to as ABI-<section_number>. */
#include <pdscdef.h>
+#include <libicb.h>
+#include <chfctxdef.h>
+#include <chfdef.h>
-/* We still use a number of macros similar to the ones for the generic
- __gnat_backtrace implementation. */
-#define SKIP_FRAME 1
-#define PC_ADJUST -4
-
-#define STOP_FRAME (frame_state.saved_ra == RA_STOP)
-
-/* Mask for PDSC$V_BASE_FRAME in procedure descriptors, missing from the
- header file included above. */
+/* A couple of items missing from the header file included above. */
+extern void * SYS$GL_CALL_HANDL;
#define PDSC$M_BASE_FRAME (1 << 10)
-typedef unsigned long REG;
+/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */
+typedef void * ADDR;
+typedef unsigned long long REG;
+
+#define REG_AT(addr) (*(REG *)(addr))
-#define REG_AT(address) (*(REG *)(address))
+#define AS_REG(addr) ((REG)(unsigned long)(addr))
+#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg))
+#define ADDR_IN(reg) (AS_ADDR(reg))
/* The following structure defines the state maintained during the
unwinding process. */
typedef struct
{
- void * pc; /* Address of the call insn involved in the chain. */
- void * sp; /* Stack Pointer at the time of this call. */
- void * fp; /* Frame Pointer at the time of this call. */
+ ADDR pc; /* Address of the call insn involved in the chain. */
+ ADDR sp; /* Stack Pointer at the time of this call. */
+ ADDR fp; /* Frame Pointer at the time of this call. */
+
+ /* The values above are fetched as saved REGisters on the stack. They are
+ typed ADDR because this is what the values in those registers are. */
/* Values of the registers saved by the functions in the chain,
- incrementally updated through consecutive calls to the "unwind"
- function below. */
+ incrementally updated through consecutive calls to the "unwind" function
+ below. */
REG saved_regs [32];
} frame_state_t;
This is from ABI-3.1.1 [Integer Registers]. */
-#define saved_fp saved_regs[29]
-#define saved_sp saved_regs[30]
-#define saved_ra saved_regs[26]
-#define saved_pv saved_regs[27]
+#define saved_fpr saved_regs[29]
+#define saved_spr saved_regs[30]
+#define saved_rar saved_regs[26]
+#define saved_pvr saved_regs[27]
-/* Special values for saved_ra, used to control the overall unwinding
+/* Special values for saved_rar, used to control the overall unwinding
process. */
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
-/* Compute Procedure Value from a live Frame Pointer value. */
+/* We still use a number of macros similar to the ones for the generic
+ __gnat_backtrace implementation. */
+#define PC_ADJUST 4
+#define STOP_FRAME (frame_state.saved_rar == RA_STOP)
+
+/* Compute Procedure Value from Frame Pointer value. This follows the rules
+ in ABI-3.6.1 [Current Procedure]. */
#define PV_FOR(FP) \
- ((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP);
+ (((FP) != 0) \
+ ? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0)
+
/**********
* unwind *
**********/
-/* Helper for __gnat_backtrace. Update FS->pc/sp/fp to represent the
- state computed in FS->saved_regs during the previous call, and update
- FS->saved_regs in preparation of the next call. */
+/* Helper for __gnat_backtrace.
+
+ FS represents some call frame, identified by a pc and associated frame
+ pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the
+ general registers upon entry in this frame. Of most interest in this set
+ are the saved return address and frame pointer registers, which actually
+ allow identifying the caller's frame.
+
+ This routine "unwinds" the input frame state by adjusting it to eventually
+ represent its caller's frame. The basic principle is to shift the fp and pc
+ saved values into the current state, and then compute the corresponding new
+ saved registers set.
+
+ If the call chain goes through a signal handler, special processing is
+ required when we process the kernel frame which has called the handler, to
+ switch it to the interrupted context frame. */
+
+#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL)
+
+static void unwind_regular_code (frame_state_t * fs);
+static void unwind_kernel_handler (frame_state_t * fs);
void
unwind (frame_state_t * fs)
{
- REG frame_base;
- PDSCDEF * pv;
-
/* Don't do anything if requested so. */
- if (fs->saved_ra == RA_STOP)
+ if (fs->saved_rar == RA_STOP)
return;
/* Retrieve the values of interest computed during the previous
call. PC_ADJUST gets us from the return address to the call insn
address. */
- fs->pc = (void *) fs->saved_ra + PC_ADJUST;
- fs->sp = (void *) fs->saved_sp;
- fs->fp = (void *) fs->saved_fp;
+ fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
+ fs->sp = ADDR_IN (fs->saved_spr);
+ fs->fp = ADDR_IN (fs->saved_fpr);
/* Unless we are able to determine otherwise, set the frame state's
saved return address such that the unwinding process will stop. */
- fs->saved_ra = RA_STOP;
+ fs->saved_rar = RA_STOP;
- /* Now we want to update fs->saved_regs to reflect what the procedure
- described by pc/fp/sp has done. */
+ /* Now we want to update fs->saved_regs to reflect the state of the caller
+ of the procedure described by pc/fp.
- /* Compute the corresponding "procedure value", following the rules in
- ABI-3.6.1 [Current Procedure]. Return immediatly if this value mandates
- us to stop. */
- if (fs->fp == 0)
- return;
+ The condition to check for a special kernel frame which has called a
+ signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
+ of the call to the handler can be identified by the return address of
+ SYS$CALL_HANDL+4". We use the equivalent procedure value identification
+ here because SYS$CALL_HANDL appears to be undefined. */
+
+ if (K_HANDLER_FRAME (fs))
+ unwind_kernel_handler (fs);
+ else
+ unwind_regular_code (fs);
+}
- pv = PV_FOR (fs->fp);
+/***********************
+ * unwind_regular_code *
+ ***********************/
+
+/* Helper for unwind, for the case of unwinding through regular code which
+ is not a signal handler. */
+
+static void
+unwind_regular_code (frame_state_t * fs)
+{
+ PDSCDEF * pv = PV_FOR (fs->fp);
+
+ ADDR frame_base;
+
+ /* Use the procedure value to unwind, in a way depending on the kind of
+ procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4
+ [Procedure Types]. */
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
return;
- /* Use the procedure value to unwind, in a way depending on the kind of
- procedure at hand. This is based on ABI-3.3 [Procedure Representation]
- and ABI-3.4 [Procedure Types]. */
frame_base
- = (REG) ((pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp);
+ = (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp;
switch (pv->pdsc$w_flags & 0xf)
{
/* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
from the Register Save Area in the frame. */
{
- REG rsa_base = frame_base + pv->pdsc$w_rsa_offset;
+ ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset;
int i, j;
- fs->saved_ra = REG_AT (rsa_base);
- fs->saved_pv = REG_AT (frame_base);
-
+ fs->saved_rar = REG_AT (rsa_base);
+ fs->saved_pvr = REG_AT (frame_base);
+
for (i = 0, j = 0; i < 32; i++)
if (pv->pdsc$l_ireg_mask & (1 << i))
fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
- /* Note that the loop above is guaranteed to set fs->saved_fp, because
- "The preserved register set must always include R29(FP) since it
- will always be used." (ABI-3.4.3.4 [Register Save Area for All
- Stack Frames]).
-
+ /* Note that the loop above is guaranteed to set fs->saved_fpr,
+ because "The preserved register set must always include R29(FP)
+ since it will always be used." (ABI-3.4.3.4 [Register Save Area for
+ All Stack Frames]).
+
Also note that we need to run through all the registers to ensure
that unwinding through register procedures (see below) gets the
right values out of the saved_regs array. */
/* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
the registers where they have been saved. */
{
- fs->saved_ra = fs->saved_regs[pv->pdsc$b_save_ra];
- fs->saved_fp = fs->saved_regs[pv->pdsc$b_save_fp];
+ fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
+ fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
}
break;
/* SP is actually never part of the saved registers area, so we use the
corresponding entry in the saved_regs array to manually keep track of
it's evolution. */
- fs->saved_sp = frame_base + pv->pdsc$l_size;
+ fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size;
+}
+
+/*************************
+ * unwind_kernel_handler *
+ *************************/
+
+/* Helper for unwind, for the specific case of unwinding through a signal
+ handler.
+
+ The input frame state describes the kernel frame which has called a signal
+ handler. We fill the corresponding saved_regs to have it's "caller" frame
+ represented as the interrupted context. */
+
+static void
+unwind_kernel_handler (frame_state_t * fs)
+{
+ PDSCDEF * pv = PV_FOR (fs->fp);
+
+ CHFDEF1 *sigargs;
+ CHFDEF2 *mechargs;
+
+ /* Retrieve the arguments passed to the handler, by way of a VMS service
+ providing the corresponding "Invocation Context Block". */
+ {
+ long handler_ivhandle;
+ INVO_CONTEXT_BLK handler_ivcb;
+
+ CHFCTX *chfctx;
+
+ handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp);
+ handler_ivcb.libicb$q_ireg [30] = 0;
+
+ handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb);
+
+ if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1)
+ return;
+
+ chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr);
+
+ sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst);
+ mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst);
+ }
+
+ /* Compute the saved return address as the PC of the instruction causing the
+ condition, accounting for the fact that it will be adjusted by the next
+ call to "unwind" as if it was an actual call return address. */
+ {
+ /* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address
+ is available from the sigargs argument to the handler, designed to
+ support both 32 and 64 bit addresses. The initial reference we get
+ is a pointer to the 32bit form, from which one may extract a pointer
+ to the 64bit version if need be. We work directly from the 32bit
+ form here. */
+
+ /* The sigargs vector structure for 32bits addresses is:
+
+ <......32bit......>
+ +-----------------+
+ | Vsize | :chf$is_sig_args
+ +-----------------+ -+-
+ | Condition Value | : [0]
+ +-----------------+ :
+ | ... | :
+ +-----------------+ : vector of Vsize entries
+ | Signal PC | :
+ +-----------------+ :
+ | PS | : [Vsize - 1]
+ +-----------------+ -+-
+
+ */
+
+ unsigned long * sigargs_vector
+ = ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1;
+
+ long sigargs_vsize
+ = sigargs->chf$is_sig_args;
+
+ fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST;
+ }
+
+ fs->saved_spr = RA_UNKNOWN;
+ fs->saved_fpr = (REG) mechargs->chf$q_mch_frame;
+ fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27;
+
+ fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16;
+ fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17;
+ fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18;
+ fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19;
+ fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20;
}
/* Structure representing a traceback entry in the tracebacks array to be
filled by __gnat_backtrace below.
+ !! This should match what is in System.Traceback_Entries, so beware of
+ !! the REG/ADDR difference here.
+
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
- void * pc;
- void * pv;
+ ADDR pc;
+ ADDR pv;
} tb_entry_t;
/********************
********************/
int
-__gnat_backtrace (void **array,
- int size,
- void *exclude_min,
- void *exclude_max,
- int skip_frames)
+__gnat_backtrace (void **array, int size,
+ void *exclude_min, void *exclude_max, int skip_frames)
{
int cnt;
register REG this_FP __asm__("$29");
register REG this_SP __asm__("$30");
- frame_state.saved_fp = this_FP;
- frame_state.saved_sp = this_SP;
- frame_state.saved_ra = RA_UNKNOWN;
+ frame_state.saved_fpr = this_FP;
+ frame_state.saved_spr = this_SP;
+ frame_state.saved_rar = RA_UNKNOWN;
unwind (&frame_state);
cnt = 0;
while (cnt < size)
{
+ PDSCDEF * pv = PV_FOR (frame_state.fp);
+
+ /* Stop if either the frame contents or the unwinder say so. */
if (STOP_FRAME)
break;
- if (frame_state.pc < exclude_min
- || frame_state.pc > exclude_max)
+ if (! K_HANDLER_FRAME (&frame_state)
+ && (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
{
- tbe->pc = frame_state.pc;
- tbe->pv = PV_FOR (frame_state.fp);
-
+ tbe->pc = (ADDR) frame_state.pc;
+ tbe->pv = (ADDR) PV_FOR (frame_state.fp);
+
cnt ++;
tbe ++;
}
projects / gcc.git / commitdiff