summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-11-15 13:52:55 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-11-15 13:52:55 +0000
commitc9d3640b2e9c6c5c8bb6925bad72408c4a3039fb (patch)
tree0729687fd2f51fc5d6d47f05db75aa9af3a5e6b5 /gcc
parent6c45c9be7f51d5bf4b0524a59e34a846ae688c73 (diff)
downloadgcc-c9d3640b2e9c6c5c8bb6925bad72408c4a3039fb.tar.gz
* a-except.adb (Zero_Cost_Exceptions): Removed, no longer used.
(builtin_longjmp, Process_Raise_Exceeption): Move setjmp/longjmp related code to a-exexpr.adb (Save_Occurrence_And_Private): Move GCC EH related code to a-exexpr-gcc.adb (Raise_Current_Excep): Add new variable Id with pragma volatile, to ensure that the variable lives on stack. * a-exexpr-gcc.adb, raise-gcc.c: New file. * a-exexpr.adb (builtin_longjmp, Propagate_Exception): Moved here code from a-except.adb. Move GCC EH related code to a-exexpr-gcc.adb * Makefile.in: Add or update g-soccon LIBGNAT pairs for Linux/PPC and 64-bit Solaris Split the Linux version of g-soccon into separate variants for 32 and 64 bit platforms. (gnatlib): Use $(AR_FOR_TARGET) and $(RANLIB_FOR_TARGET) vice $(AR) and $(RANLIB). Remove use of host variable $(RANLIB_FLAGS). install-gnatlib: Use $(RANLIB_FOR_TARGET) vice $(RANLIB). Remove use of host variable $(RANLIB_FLAGS). (alpha64-dec-*vms*): Fix translations for 64 bit compiler. Code clean up: remove unused/obsolete targets. (EH_MECHANISM): New variable introduced to differenciate between the two EH mechanisms statically. (gnatlib-zcx, gnatlib-sjlj): Force EH_MECHANISM manually. (LIBGNAT_OBJS): Add raise-gcc.o (LIBGNAT_TARGET_PAIRS for ppc-vxworks): Use an specialized version of s-osinte.adb, s-tpopsp.adb, and system.ads for the run time that supports VxWorks 6 RTPs. (EXTRA_GNATRTL_NONTASKING_OBJS for ppc-vxworks): Remove the use of i-vxworks and i-vxwoio from the run time that supports VxWorks 6 RTPs. * raise.c: Move all GCC EH-related routines to raise-gcc.c git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106959 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/Makefile.in328
-rw-r--r--gcc/ada/a-except.adb128
-rw-r--r--gcc/ada/a-exexpr-gcc.adb726
-rw-r--r--gcc/ada/a-exexpr.adb689
-rw-r--r--gcc/ada/raise-gcc.c1150
-rw-r--r--gcc/ada/raise.c1122
6 files changed, 2040 insertions, 2103 deletions
diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in
index f13fed7fb76..0dfe8ae1816 100644
--- a/gcc/ada/Makefile.in
+++ b/gcc/ada/Makefile.in
@@ -348,6 +348,11 @@ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<s-taprop-dummy.adb \
s-taspri.ads<s-taspri-dummy.ads
+# When using the GCC exception handling mechanism, we need to use an
+# alternate body for a-exexpr.adb (a-exexpr-gcc.adb)
+
+EH_MECHANISM=
+
# Default shared object option. Note that we rely on the fact that the "soname"
# option will always be present and last in this flag, so that we can have
# $(SO_OPTS)libgnat-x.xx
@@ -381,103 +386,6 @@ LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads |
# $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match.
-ifeq ($(strip $(filter-out %86 os2 OS2 os2_emx,$(arch) $(osys))),)
- LIBGNAT_TARGET_PAIRS = \
- a-excpol.adb<a-excpol-abort.adb \
- a-intnam.ads<a-intnam-dummy.ads \
- a-numaux.adb<a-numaux-x86.adb \
- a-numaux.ads<a-numaux-x86.ads \
- s-inmaop.adb<s-inmaop-dummy.adb \
- s-interr.adb<s-interr-dummy.adb \
- s-intman.adb<s-intman-dummy.adb \
- s-osinte.adb<s-osinte-os2.adb \
- s-osinte.ads<s-osinte-os2.ads \
- s-osprim.adb<s-osprim-os2.adb \
- s-parame.adb<s-parame-os2.adb \
- system.ads<system-os2.ads \
- s-taprop.adb<s-taprop-os2.adb \
- s-taspri.ads<s-taspri-os2.ads
-
- EXTRA_GNATRTL_NONTASKING_OBJS = \
- i-os2err.o \
- i-os2lib.o \
- i-os2syn.o \
- i-os2thr.o
-endif
-
-ifeq ($(strip $(filter-out %86 interix%,$(arch) $(osys))),)
- LIBGNAT_TARGET_PAIRS = \
- a-excpol.adb<a-excpol-interix.adb \
- a-intnam.ads<a-intnam-interix.ads \
- a-numaux.adb<a-numaux-x86.adb \
- a-numaux.ads<a-numaux-x86.ads \
- g-soccon.ads<g-soccon-interix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-fsu.adb \
- s-osinte.ads<s-osinte-interix.ads \
- s-osprim.adb<s-osprim-unix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- system.ads<system-interix.ads \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb
-
- THREADSLIB = -lgthreads -lmalloc
- PREFIX_OBJS=$(PREFIX_REAL_OBJS)
-endif
-
-# sysv5uw is SCO UnixWare 7
-ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
- LIBGNAT_TARGET_PAIRS = \
- a-excpol.adb<a-excpol-abort.adb \
- a-intnam.ads<a-intnam-unixware.ads \
- a-numaux.adb<a-numaux-x86.adb \
- a-numaux.ads<a-numaux-x86.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.ads<s-osinte-unixware.ads \
- s-osinte.adb<s-osinte-unixware.adb \
- s-osprim.adb<s-osprim-unix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- system.ads<system-unixware.ads \
- g-soccon.ads<g-soccon-unixware.ads \
- g-soliop.ads<g-soliop-unixware.ads
-
- THREADSLIB = -lthread
- PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- SO_OPTS = -Wl,-h,
- GNATLIB_SHARED = gnatlib-shared-dual
- LIBRARY_VERSION := $(LIB_VERSION)
-endif
-
-ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-vxworks.ads \
- a-numaux.ads<a-numaux-vxworks.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-interr.adb<s-interr-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
- s-osinte.adb<s-osinte-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
- s-osprim.adb<s-osprim-vxworks.adb \
- s-parame.ads<s-parame-vxworks.ads \
- s-stchop.adb<s-stchop-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-vxwork.ads<s-vxwork-alpha.ads \
- g-soccon.ads<g-soccon-vxworks.ads \
- g-socthi.ads<g-socthi-vxworks.ads \
- g-socthi.adb<g-socthi-vxworks.adb \
- system.ads<system-vxworks-alpha.ads
-
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
-endif
-
ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-vxworks.ads \
@@ -523,19 +431,16 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
- s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<s-taspri-vxworks.ads \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<s-vxwork-ppc.ads \
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
- g-socthi.adb<g-socthi-vxworks.adb \
- system.ads<system-vxworks-ppc.ads
+ g-socthi.adb<g-socthi-vxworks.adb
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
@@ -548,7 +453,22 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
s-tfsetr.adb<s-tfsetr-vxworks.adb
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-vxwexc.o
+ ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-osinte.adb<s-osinte-vxworks-rtp.adb \
+ s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
+ system.ads<system-vxworks-ppc-rtp.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
+ else
+ LIBGNAT_TARGET_PAIRS += \
+ s-osinte.adb<s-osinte-vxworks.adb \
+ s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ system.ads<system-vxworks-ppc.ads
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-vxwexc.o
+ endif
+
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
endif
@@ -695,6 +615,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-solaris.adb
+ EH_MECHANISM=-gcc
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
SO_OPTS = -Wl,-h,
@@ -703,24 +624,6 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
- ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-solaris.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-solaris.adb \
- s-osinte.adb<s-osinte-fsu.adb \
- s-osinte.ads<s-osinte-solaris-fsu.ads \
- s-osprim.adb<s-osprim-solaris.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
- g-soccon.ads<g-soccon-solaris.ads \
- g-soliop.ads<g-soliop-solaris.ads \
- system.ads<system-solaris-sparc.ads
-
- THREADSLIB = -lgthreads -lmalloc
- endif
-
ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-solaris.ads \
@@ -753,7 +656,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<s-tpopsp-solaris.adb \
- g-soccon.ads<g-soccon-solaris.ads \
+ g-soccon.ads<g-soccon-solaris-64.ads \
g-soliop.ads<g-soliop-solaris.ads \
system.ads<system-solaris-sparcv9.ads
endif
@@ -795,6 +698,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
+ g-soccon.ads<g-soccon-linux-x86.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.adb<s-osinte-posix.adb \
@@ -810,29 +714,12 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
-
- ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- a-numaux.adb<a-numaux-x86.adb \
- a-numaux.ads<a-numaux-x86.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-fsu.adb \
- s-osinte.ads<s-osinte-linux-fsu.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
- system.ads<system-linux-x86.ads
-
- THREADSLIB = -lgthreads -lmalloc
- endif
endif
ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
@@ -923,26 +810,15 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
GNATLIB_SHARED = gnatlib-shared-default
else
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-irix.ads \
- s-inmaop.adb<s-inmaop-dummy.adb \
- s-interr.adb<s-interr-sigaction.adb \
- s-intman.adb<s-intman-irix-athread.adb \
+ LIBGNAT_TARGET_PAIRS += \
s-mastop.adb<s-mastop-irix.adb \
- s-osinte.adb<s-osinte-irix.adb \
- s-osinte.ads<s-osinte-irix-athread.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-proinf.adb<s-proinf-irix-athread.adb \
- s-proinf.ads<s-proinf-irix-athread.ads \
- s-taprop.adb<s-taprop-irix-athread.adb \
- s-tasinf.adb<s-tasinf-irix-athread.adb \
- s-tasinf.ads<s-tasinf-irix-athread.ads \
- s-taspri.ads<s-taspri-posix.ads \
s-traceb.adb<s-traceb-mastop.adb \
g-soccon.ads<g-soccon-irix.ads \
system.ads<system-irix-o32.ads
endif
+ EH_MECHANISM=-gcc
TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-irix.adb
TGT_LIB = -lexc
MISCLIB = -lexc
@@ -967,6 +843,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
g-soccon.ads<g-soccon-hpux.ads \
system.ads<system-hpux.ads
+ EH_MECHANISM=-gcc
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
endif
@@ -987,6 +864,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
system.ads<system-hpux.ads
TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-hpux.adb
+ EH_MECHANISM=-gcc
TGT_LIB = /usr/lib/libcl.a
THREADSLIB = -lpthread
GMEM_LIB = gmemlib
@@ -995,27 +873,6 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual
LIBRARY_VERSION := $(LIB_VERSION)
-
- ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-excpol.adb<a-excpol-abort.adb \
- a-intnam.ads<a-intnam-hpux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-interr.adb<s-interr-sigaction.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-hpux-dce.adb \
- s-osinte.ads<s-osinte-hpux-dce.ads \
- s-parame.ads<s-parame-hpux.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-hpux-dce.adb \
- s-taspri.ads<s-taspri-hpux-dce.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
- g-soccon.ads<g-soccon-hpux.ads \
- system.ads<system-hpux.ads
-
- TGT_LIB =
- THREADSLIB = -lcma
- endif
endif
ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
@@ -1035,23 +892,6 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
THREADSLIB = -lpthreads
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
- ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-aix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-fsu.adb \
- s-osinte.ads<s-osinte-aix-fsu.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
- g-soccon.ads<g-soccon-aix.ads \
- system.ads<system-aix.ads
-
- THREADSLIB = -lgthreads -lmalloc
- endif
-
TOOLS_TARGET_PAIRS = \
mlib-tgt.adb<mlib-tgt-aix.adb \
indepsw.adb<indepsw-aix.adb
@@ -1086,27 +926,13 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
a-intnam.ads<a-intnam-lynxos.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-lynxos-3.adb \
- s-osinte.ads<s-osinte-lynxos-3.ads \
+ s-osinte.adb<s-osinte-lynxos.adb \
+ s-osinte.ads<s-osinte-lynxos.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<s-taprop-lynxos.adb \
+ s-taspri.ads<s-taspri-lynxos.ads \
+ s-tpopsp.adb<s-tpopsp-lynxos.adb \
system.ads<system-lynxos-ppc.ads
-
- ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-lynxos.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-lynxos.adb \
- s-osinte.ads<s-osinte-lynxos.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-lynxos.adb \
- s-taspri.ads<s-taspri-lynxos.ads \
- s-tpopsp.adb<s-tpopsp-lynxos.adb \
- system.ads<system-lynxos-ppc.ads
- endif
endif
endif
@@ -1143,6 +969,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-tru64.adb
+ EH_MECHANISM=-gcc
GMEM_LIB=gmemlib
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
@@ -1150,42 +977,42 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
LIBRARY_VERSION := $(LIB_VERSION)
endif
-ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(host))),)
+ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(host))),)
soext = .exe
hyphen = _
LN = cp -p
LN_S = cp -p
-ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
-AR = iar
-endif
-
.SUFFIXES: .sym
.o.sym:
@ gnu:[bin]vmssymvec $<
endif
-ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
+ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))),)
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
g-enblsp.adb<g-enblsp-vms-ia64.adb \
+ g-trasym.adb<g-trasym-vms-ia64.adb \
s-auxdec.ads<s-auxdec-vms_64.ads \
s-crtl.ads<s-crtl-vms64.ads \
s-osinte.adb<s-osinte-vms-ia64.adb \
s-osinte.ads<s-osinte-vms-ia64.ads \
+ s-vaflop.adb<s-vaflop-vms-ia64.adb \
system.ads<system-vms_64.ads
else
-ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
+ifeq ($(strip $(filter-out alpha64 dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
g-enblsp.adb<g-enblsp-vms-alpha.adb \
+ g-trasym.adb<g-trasym-vms-alpha.adb \
s-asthan.adb<s-asthan-vms-alpha.adb \
- s-crtl.ads<s-crtl-vms.ads \
+ s-auxdec.ads<s-auxdec-vms_64.ads \
+ s-crtl.ads<s-crtl-vms64.ads \
s-osinte.adb<s-osinte-vms.adb \
s-osinte.ads<s-osinte-vms.ads \
s-vaflop.adb<s-vaflop-vms-alpha.adb \
- system.ads<system-vms-zcx.ads
+ system.ads<system-vms_64.ads
endif
endif
ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),)
@@ -1208,10 +1035,7 @@ endif
g-soccon.ads<g-soccon-vms.ads \
g-socthi.ads<g-socthi-vms.ads \
g-socthi.adb<g-socthi-vms.adb \
- g-trasym.adb<g-trasym-vms.adb \
i-cstrea.adb<i-cstrea-vms.adb \
- i-cpp.adb<i-cpp-vms.adb \
- interfac.ads<interfac-vms.ads \
s-inmaop.adb<s-inmaop-vms.adb \
s-interr.adb<s-interr-vms.adb \
s-intman.adb<s-intman-vms.adb \
@@ -1240,8 +1064,9 @@ else
symbols-processing.adb<symbols-processing-vms-alpha.adb
endif
+ EH_MECHANISM=-gcc
GNATLIB_SHARED=gnatlib-shared-vms
-ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
+ifeq ($(strip $(filter-out alpha64 dec vms% openvms% alphavms%,$(targ))),)
EXTRA_LIBGNAT_SRCS=vmshandler.asm
EXTRA_LIBGNAT_OBJS=vmshandler.o
endif
@@ -1285,6 +1110,7 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
mlib-tgt.adb<mlib-tgt-mingw.adb \
indepsw.adb<indepsw-mingw.adb
+ EH_MECHANISM=-gcc
MISCLIB = -lwsock32
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
@@ -1301,6 +1127,7 @@ endif
ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
+ g-soccon.ads<g-soccon-linux-ppc.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.adb<s-osinte-posix.adb \
@@ -1316,6 +1143,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1341,6 +1169,7 @@ ifeq ($(strip $(filter-out sparc% linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1366,6 +1195,7 @@ ifeq ($(strip $(filter-out hppa% linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1377,6 +1207,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
a-numaux.ads<a-numaux-libc-x86.ads \
+ g-soccon.ads<g-soccon-linux-64.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.ads<s-osinte-linux.ads \
@@ -1391,6 +1222,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
MISCLIB=
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
@@ -1416,6 +1248,7 @@ ifeq ($(strip $(filter-out alpha% linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
MISCLIB=
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
@@ -1428,6 +1261,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
+ g-soccon.ads<g-soccon-linux-64.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.ads<s-osinte-linux.ads \
@@ -1442,6 +1276,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-gnu.adb
+ EH_MECHANISM=-gcc
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1468,6 +1303,7 @@ ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),)
TOOLS_TARGET_PAIRS = \
mlib-tgt.adb<mlib-tgt-darwin.adb
+ EH_MECHANISM=-gcc
GNATLIB_SHARED = gnatlib-shared-darwin
SO_OPTS = -Wl,-flat_namespace
RANLIB = ranlib -c
@@ -1477,6 +1313,12 @@ ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),)
soext = .dylib
endif
+ifneq ($(EH_MECHANISM),)
+ LIBGNAT_TARGET_PAIRS += a-exexpr.adb<a-exexpr$(EH_MECHANISM).adb
+ EXTRA_LIBGNAT_SRCS+=raise$(EH_MECHANISM).c
+ EXTRA_LIBGNAT_OBJS+=raise$(EH_MECHANISM).o
+endif
+
# The runtime library for gnat comprises two directories. One contains the
# Ada source files that the compiler (gnat1) needs -- these files are listed
# by ADA_INCLUDE_SRCS -- and the other contains the object files and their
@@ -1493,8 +1335,8 @@ LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
$(EXTRA_LIBGNAT_SRCS)
LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o \
- raise.o sysdep.o aux-io.o init.o initialize.o seh_init.o cal.o final.o \
- tracebak.o expect.o mkdir.o socket.o $(EXTRA_LIBGNAT_OBJS)
+ raise.o sysdep.o aux-io.o init.o initialize.o seh_init.o cal.o \
+ final.o tracebak.o expect.o mkdir.o socket.o $(EXTRA_LIBGNAT_OBJS)
# NOTE ??? - when the -I option for compiling Ada code is made to work,
# the library installation will change and there will be a
@@ -1665,7 +1507,7 @@ install-gnatlib: ../stamp-gnatlib
-$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-cd rts; for file in *$(arext);do \
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
- $(RANLIB) $(RANLIB_FLAGS) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
+ $(RANLIB_FOR_TARGET) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
done
-$(foreach file, $(EXTRA_ADALIB_FILES), \
$(INSTALL_DATA_DATE) rts/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
@@ -1761,19 +1603,21 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2
-f ../Makefile \
$(GNATRTL_OBJS)
$(RM) rts/libgnat$(arext) rts/libgnarl$(arext)
- $(AR) $(AR_FLAGS) rts/libgnat$(arext) \
+ $(AR_FOR_TARGET) $(AR_FLAGS) rts/libgnat$(arext) \
$(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS))
ifneq ($(PREFIX_OBJS),)
- $(AR) $(AR_FLAGS) rts/libgccprefix$(arext) $(PREFIX_OBJS);
- -$(RANLIB) rts/libgccprefix$(arext)
+ $(AR_FOR_TARGET) $(AR_FLAGS) rts/libgccprefix$(arext) \
+ $(PREFIX_OBJS);
+ $(RANLIB_FOR_TARGET) rts/libgccprefix$(arext)
endif
- -$(RANLIB) $(RANLIB_FLAGS) rts/libgnat$(arext)
- $(AR) $(AR_FLAGS) rts/libgnarl$(arext) \
+ $(RANLIB_FOR_TARGET) rts/libgnat$(arext)
+ $(AR_FOR_TARGET) $(AR_FLAGS) rts/libgnarl$(arext) \
$(addprefix rts/,$(GNATRTL_TASKING_OBJS))
- -$(RANLIB) $(RANLIB_FLAGS) rts/libgnarl$(arext)
+ $(RANLIB_FOR_TARGET) rts/libgnarl$(arext)
ifeq ($(GMEM_LIB),gmemlib)
- $(AR) $(AR_FLAGS) rts/libgmem$(arext) rts/memtrack.o
- -$(RANLIB) $(RANLIB_FLAGS) rts/libgmem$(arext)
+ $(AR_FOR_TARGET) $(AR_FLAGS) rts/libgmem$(arext) \
+ rts/memtrack.o
+ $(RANLIB_FOR_TARGET) rts/libgmem$(arext)
endif
$(CHMOD) a-wx rts/*.ali
touch ../stamp-gnatlib
@@ -1914,7 +1758,8 @@ gnatlib-shared:
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
$(GNATLIB_SHARED)
-gnatlib-sjlj: ../stamp-gnatlib1
+gnatlib-sjlj:
+ $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" ../stamp-gnatlib1
sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' rts/system.ads > rts/s.ads
$(MV) rts/s.ads rts/system.ads
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1923,7 +1768,8 @@ gnatlib-sjlj: ../stamp-gnatlib1
THREAD_KIND="$(THREAD_KIND)" \
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib
-gnatlib-zcx: ../stamp-gnatlib1
+gnatlib-zcx:
+ $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" ../stamp-gnatlib1
sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' rts/system.ads > rts/s.ads
$(MV) rts/s.ads rts/system.ads
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1998,16 +1844,18 @@ adadecode.o : adadecode.c adadecode.h
aux-io.o : aux-io.c
argv.o : argv.c
cal.o : cal.c
-deftarg.o : deftarg.c
+deftarg.o : deftarg.c
errno.o : errno.c
-exit.o : raise.h exit.c
+exit.o : adaint.h exit.c
expect.o : expect.c
-final.o : raise.h final.c
+final.o : final.c
gmem.o : gmem.c
link.o : link.c
mkdir.o : mkdir.c
socket.o : socket.c gsocket.h
sysdep.o : sysdep.c
+raise-gcc.o : raise-gcc.c raise.h
+raise.o : raise.c raise.h
gen-soccon: gen-soccon.c gsocket.h
$(CC) $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
@@ -2032,10 +1880,6 @@ seh_init.o : seh_init.c raise.h
$(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) -O0 \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
-raise.o : raise.c raise.h
- $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
-
# Need to keep the frame pointer in this file to pop the stack properly on
# some targets.
tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c
diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb
index a676b91c2ed..fb14eda5b08 100644
--- a/gcc/ada/a-except.adb
+++ b/gcc/ada/a-except.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
@@ -41,23 +41,11 @@ with System.Soft_Links; use System.Soft_Links;
package body Ada.Exceptions is
- procedure builtin_longjmp (buffer : Address; Flag : Integer);
- pragma No_Return (builtin_longjmp);
- pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
-
pragma Suppress (All_Checks);
-- We definitely do not want exceptions occurring within this unit, or
-- we are in big trouble. If an exceptional situation does occur, better
-- that it not be raised, since raising it can cause confusing chaos.
- Zero_Cost_Exceptions : Integer;
- pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
- -- Boolean indicating if we are handling exceptions using a zero cost
- -- mechanism.
- --
- -- Note that although we currently do not support it, the GCC3 back-end
- -- tables are also potentially useable for setjmp/longjmp processing.
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -409,12 +397,6 @@ package body Ada.Exceptions is
-- The following procedures provide an internal interface to help making
-- this explicit.
- procedure Save_Occurrence_And_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence);
- -- Copy all the components of Source to Target as well as the
- -- Private_Data pointer.
-
procedure Save_Occurrence_No_Private
(Target : out Exception_Occurrence;
Source : Exception_Occurrence);
@@ -783,81 +765,15 @@ package body Ada.Exceptions is
is
pragma Inspection_Point (E);
-- This is so the debugger can reliably inspect the parameter
-
- Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
- Excep : constant EOA := Get_Current_Excep.all;
-
begin
- -- WARNING : There should be no exception handler for this body
+ -- WARNING: There should be no exception handler for this body
-- because this would cause gigi to prepend a setup for a new
- -- jmpbuf to the sequence of statements. We would then always get
- -- this new buf in Jumpbuf_Ptr instead of the one for the exception
- -- we are handling, which would completely break the whole design
- -- of this procedure.
-
- -- Processing varies between zero cost and setjmp/lonjmp processing
-
- if Zero_Cost_Exceptions /= 0 then
-
- -- Use the GCC back-end to propagate the exception. Backtrace
- -- computation is performed, if required, by the underlying routine.
- -- Notifications for the debugger are also not performed here,
- -- because we do not yet know if the exception is handled.
-
- Exception_Propagation.Propagate_Exception (From_Signal_Handler);
-
- else
- -- Compute the backtrace for this occurrence if corresponding binder
- -- option has been set. Call_Chain takes care of the reraise case.
-
- Call_Chain (Excep);
-
- -- Note on above call to Call_Chain:
-
- -- We used to only do this if From_Signal_Handler was not set,
- -- based on the assumption that backtracing from a signal handler
- -- would not work due to stack layout oddities. However, since
-
- -- 1. The flag is never set in tasking programs (Notify_Exception
- -- performs regular raise statements), and
-
- -- 2. No problem has shown up in tasking programs around here so
- -- far, this turned out to be too strong an assumption.
-
- -- As, in addition, the test was
-
- -- 1. preventing the production of backtraces in non-tasking
- -- programs, and
-
- -- 2. introducing a behavior inconsistency between
- -- the tasking and non-tasking cases,
+ -- jmpbuf to the sequence of statements in case of built-in sjljl.
+ -- We would then always get this new buf in Jumpbuf_Ptr instead of the
+ -- one for the exception we are handling, which would completely break
+ -- the whole design of this procedure.
- -- we have simply removed it
-
- -- If the jump buffer pointer is non-null, transfer control using
- -- it. Otherwise announce an unhandled exception (note that this
- -- means that we have no finalizations to do other than at the outer
- -- level). Perform the necessary notification tasks in both cases.
-
- if Jumpbuf_Ptr /= Null_Address then
-
- if not Excep.Exception_Raised then
- Excep.Exception_Raised := True;
- Exception_Traces.Notify_Handled_Exception;
- end if;
-
- builtin_longjmp (Jumpbuf_Ptr, 1);
-
- else
- -- The pragma Inspection point here ensures that the debugger
- -- can inspect the parameter.
-
- pragma Inspection_Point (E);
-
- Exception_Traces.Notify_Unhandled_Exception;
- Exception_Traces.Unhandled_Exception_Terminate;
- end if;
- end if;
+ Exception_Propagation.Propagate_Exception (From_Signal_Handler);
end Process_Raise_Exception;
----------------------------
@@ -892,8 +808,23 @@ package body Ada.Exceptions is
-------------------------
procedure Raise_Current_Excep (E : Exception_Id) is
+
pragma Inspection_Point (E);
- -- This is so the debugger can reliably inspect the parameter
+ -- This is so the debugger can reliably inspect the parameter when
+ -- inserting a breakpoint at the start of this procedure.
+
+ Id : Exception_Id := E;
+ pragma Volatile (Id);
+ pragma Warnings (Off, Id);
+ -- In order to provide support for breakpoints on unhandled exceptions,
+ -- the debugger will also need to be able to inspect the value of E from
+ -- another (inner) frame. So we need to make sure that if E is passed in
+ -- a register, its value is also spilled on stack. For this, we store
+ -- the parameter value in a local variable, and add a pragma Volatile to
+ -- make sure it is spilled. The pragma Warnings (Off) is needed because
+ -- the compiler knows that Id is not referenced and that this use of
+ -- pragma Volatile is peculiar!
+
begin
Process_Raise_Exception (E => E, From_Signal_Handler => False);
end Raise_Current_Excep;
@@ -1263,19 +1194,6 @@ package body Ada.Exceptions is
end Save_Occurrence;
--------------------------------
- -- Save_Occurrence_And_Private --
- --------------------------------
-
- procedure Save_Occurrence_And_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence)
- is
- begin
- Save_Occurrence_No_Private (Target, Source);
- Target.Private_Data := Source.Private_Data;
- end Save_Occurrence_And_Private;
-
- --------------------------------
-- Save_Occurrence_No_Private --
--------------------------------
diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb
new file mode 100644
index 00000000000..22f057d18a4
--- /dev/null
+++ b/gcc/ada/a-exexpr-gcc.adb
@@ -0,0 +1,726 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005, 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 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the version using the GCC EH mechanism
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+with System.Storage_Elements; use System.Storage_Elements;
+
+separate (Ada.Exceptions)
+package body Exception_Propagation is
+
+ ------------------------------------------------
+ -- Entities to interface with the GCC runtime --
+ ------------------------------------------------
+
+ -- These come from "C++ ABI for Itanium: Exception handling", which is
+ -- the reference for GCC. They are used only when we are relying on
+ -- back-end tables for exception propagation, which in turn is currenly
+ -- only the case for Zero_Cost_Exceptions in GNAT5.
+
+ -- Return codes from the GCC runtime functions used to propagate
+ -- an exception.
+
+ type Unwind_Reason_Code is
+ (URC_NO_REASON,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Unreferenced
+ (URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Convention (C, Unwind_Reason_Code);
+
+ -- Phase identifiers
+
+ type Unwind_Action is
+ (UA_SEARCH_PHASE,
+ UA_CLEANUP_PHASE,
+ UA_HANDLER_FRAME,
+ UA_FORCE_UNWIND);
+
+ for Unwind_Action use
+ (UA_SEARCH_PHASE => 1,
+ UA_CLEANUP_PHASE => 2,
+ UA_HANDLER_FRAME => 4,
+ UA_FORCE_UNWIND => 8);
+
+ pragma Convention (C, Unwind_Action);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ type Exception_Class is mod 2 ** 64;
+
+ GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
+ -- "GNU-Ada\0"
+
+ type Unwind_Word is mod 2 ** System.Word_Size;
+ for Unwind_Word'Size use System.Word_Size;
+ -- Map the corresponding C type used in Unwind_Exception below
+
+ type Unwind_Exception is record
+ Class : Exception_Class := GNAT_Exception_Class;
+ Cleanup : System.Address := System.Null_Address;
+ Private1 : Unwind_Word;
+ Private2 : Unwind_Word;
+ end record;
+ -- Map the GCC struct used for exception handling
+
+ for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
+ -- The C++ ABI mandates the common exception header to be at least
+ -- doubleword aligned, and the libGCC implementation actually makes it
+ -- maximally aligned (see unwind.h). See additional comments on the
+ -- alignment below.
+
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+
+ -- A GNAT exception object to be dealt with by the personality routine
+ -- called by the GCC unwinding runtime.
+
+ type GNAT_GCC_Exception is record
+ Header : Unwind_Exception;
+ -- ABI Exception header first
+
+ Id : Exception_Id;
+ -- GNAT Exception identifier. This is filled by Propagate_Exception
+ -- and then used by the personality routine to determine if the context
+ -- it examines contains a handler for the exception beeing propagated.
+
+ N_Cleanups_To_Trigger : Integer;
+ -- Number of cleanup only frames encountered in SEARCH phase. This is
+ -- initialized to 0 by Propagate_Exception and maintained by the
+ -- personality routine to control a forced unwinding phase triggering
+ -- all the cleanups before calling Unhandled_Exception_Terminate when
+ -- an exception is not handled.
+
+ Next_Exception : EOA;
+ -- Used to create a linked list of exception occurrences
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ -- There is a subtle issue with the common header alignment, since the C
+ -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
+ -- Standard'Maximum_Alignment, and those two values don't quite represent
+ -- the same concepts and so may be decoupled someday. One typical reason
+ -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
+ -- allocator guarantees, and there are extra costs involved in allocating
+ -- objects aligned to such factors.
+
+ -- To deal with the potential alignment differences between the C and Ada
+ -- representations, the Ada part of the whole structure is only accessed
+ -- by the personality routine through the accessors declared below. Ada
+ -- specific fields are thus always accessed through consistent layout, and
+ -- we expect the actual alignment to always be large enough to avoid traps
+ -- from the C accesses to the common header. Besides, accessors aleviate
+ -- the need for a C struct whole conterpart, both painful and errorprone
+ -- to maintain anyway.
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GNAT_GCC_Exception is new
+ Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
+
+ procedure Free is new Unchecked_Deallocation
+ (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
+
+ procedure Free is new Unchecked_Deallocation
+ (Exception_Occurrence, EOA);
+
+ function CleanupUnwind_Handler
+ (UW_Version : Integer;
+ UW_Phases : Unwind_Action;
+ UW_Eclass : Exception_Class;
+ UW_Exception : access GNAT_GCC_Exception;
+ UW_Context : System.Address;
+ UW_Argument : System.Address) return Unwind_Reason_Code;
+ -- Hook called at each step of the forced unwinding we perform to
+ -- trigger cleanups found during the propagation of an unhandled
+ -- exception.
+
+ -- GCC runtime functions used. These are C non-void functions, actually,
+ -- but we ignore the return values. See raise.c as to why we are using
+ -- __gnat stubs for these.
+
+ procedure Unwind_RaiseException
+ (UW_Exception : access GNAT_GCC_Exception);
+ pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
+
+ procedure Unwind_ForcedUnwind
+ (UW_Exception : access GNAT_GCC_Exception;
+ UW_Handler : System.Address;
+ UW_Argument : System.Address);
+ pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
+
+ ------------------------------------------------------------------
+ -- Occurrence Stack Management Facilities for the GCC-EH Scheme --
+ ------------------------------------------------------------------
+
+ function Remove
+ (Top : EOA;
+ Excep : GNAT_GCC_Exception_Access) return Boolean;
+ -- Remove Excep from the stack starting at Top.
+ -- Return True if Excep was found and removed, false otherwise.
+
+ -- Hooks called when entering/leaving an exception handler for a given
+ -- occurrence, aimed at handling the stack of active occurrences. The
+ -- calls are generated by gigi in tree_transform/N_Exception_Handler.
+
+ procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, Begin_Handler, "__gnat_begin_handler");
+
+ procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, End_Handler, "__gnat_end_handler");
+
+ Setup_Key : constant := 16#DEAD#;
+ -- To handle the case of a task "transferring" an exception occurrence to
+ -- another task, for instance via Exceptional_Complete_Rendezvous, we need
+ -- to be able to identify occurrences which have been Setup and not yet
+ -- Propagated. We hijack one of the common header fields for that purpose,
+ -- setting it to a special key value during the setup process, clearing it
+ -- at the very beginning of the propagation phase, and expecting it never
+ -- to be reset to the special value later on. A 16-bit value is used rather
+ -- than a 32-bit value for static compatibility with 16-bit targets such as
+ -- AAMP (where type Unwind_Word will be 16 bits).
+
+ function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
+
+ procedure Set_Setup_And_Not_Propagated (E : EOA);
+ procedure Clear_Setup_And_Not_Propagated (E : EOA);
+
+ procedure Save_Occurrence_And_Private
+ (Target : out Exception_Occurrence;
+ Source : Exception_Occurrence);
+ -- Copy all the components of Source to Target as well as the
+ -- Private_Data pointer.
+
+ ------------------------------------------------------------
+ -- Accessors to basic components of a GNAT exception data --
+ ------------------------------------------------------------
+
+ -- As of today, these are only used by the C implementation of the
+ -- GCC propagation personality routine to avoid having to rely on a C
+ -- counterpart of the whole exception_data structure, which is both
+ -- painful and error prone. These subprograms could be moved to a
+ -- more widely visible location if need be.
+
+ function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
+ pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
+
+ function Language_For (E : Exception_Data_Ptr) return Character;
+ pragma Export (C, Language_For, "__gnat_language_for");
+
+ function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
+ pragma Export (C, Import_Code_For, "__gnat_import_code_for");
+
+ function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
+ return Exception_Id;
+ pragma Export (C, EID_For, "__gnat_eid_for");
+
+ procedure Adjust_N_Cleanups_For
+ (GNAT_Exception : GNAT_GCC_Exception_Access;
+ Adjustment : Integer);
+ pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");
+
+ ---------------------------------------------------------------------------
+ -- Objects to materialize "others" and "all others" in the GCC EH tables --
+ ---------------------------------------------------------------------------
+
+ -- Currently, these only have their address taken and compared so there is
+ -- no real point having whole exception data blocks allocated. In any case
+ -- the types should match what gigi and the personality routine expect.
+ -- The initial value is an arbitrary value that will not exceed the range
+ -- of Integer on 16-bit targets (such as AAMP).
+
+ Others_Value : constant Integer := 16#7FFF#;
+ pragma Export (C, Others_Value, "__gnat_others_value");
+
+ All_Others_Value : constant Integer := 16#7FFF#;
+ pragma Export (C, All_Others_Value, "__gnat_all_others_value");
+
+ ------------
+ -- Remove --
+ ------------
+
+ function Remove
+ (Top : EOA;
+ Excep : GNAT_GCC_Exception_Access) return Boolean
+ is
+ Prev : GNAT_GCC_Exception_Access := null;
+ Iter : EOA := Top;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ begin
+ -- Pop stack
+
+ loop
+ pragma Assert (Iter.Private_Data /= System.Null_Address);
+
+ GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
+
+ if GCC_Exception = Excep then
+ if Prev = null then
+
+ -- Special case for the top of the stack: shift the contents
+ -- of the next item to the top, since top is at a fixed
+ -- location and can't be changed.
+
+ Iter := GCC_Exception.Next_Exception;
+
+ if Iter = null then
+
+ -- Stack is now empty
+
+ Top.Private_Data := System.Null_Address;
+
+ else
+ Save_Occurrence_And_Private (Top.all, Iter.all);
+ Free (Iter);
+ end if;
+
+ else
+ Prev.Next_Exception := GCC_Exception.Next_Exception;
+ Free (Iter);
+ end if;
+
+ Free (GCC_Exception);
+
+ return True;
+ end if;
+
+ exit when GCC_Exception.Next_Exception = null;
+
+ Prev := GCC_Exception;
+ Iter := GCC_Exception.Next_Exception;
+ end loop;
+
+ return False;
+ end Remove;
+
+ ---------------------------
+ -- CleanupUnwind_Handler --
+ ---------------------------
+
+ function CleanupUnwind_Handler
+ (UW_Version : Integer;
+ UW_Phases : Unwind_Action;
+ UW_Eclass : Exception_Class;
+ UW_Exception : access GNAT_GCC_Exception;
+ UW_Context : System.Address;
+ UW_Argument : System.Address) return Unwind_Reason_Code
+ is
+ pragma Unreferenced
+ (UW_Version, UW_Phases, UW_Eclass, UW_Context, UW_Argument);
+
+ begin
+ -- Terminate as soon as we know there is nothing more to run. The
+ -- count is maintained by the personality routine.
+
+ if UW_Exception.N_Cleanups_To_Trigger = 0 then
+ Unhandled_Exception_Terminate;
+ end if;
+
+ -- We know there is at least one cleanup further up. Return so that it
+ -- is searched and entered, after which Unwind_Resume will be called
+ -- and this hook will gain control (with an updated count) again.
+
+ return URC_NO_REASON;
+ end CleanupUnwind_Handler;
+
+ ---------------------------------
+ -- Is_Setup_And_Not_Propagated --
+ ---------------------------------
+
+ function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
+ GCC_E : constant GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
+ end Is_Setup_And_Not_Propagated;
+
+ ------------------------------------
+ -- Clear_Setup_And_Not_Propagated --
+ ------------------------------------
+
+ procedure Clear_Setup_And_Not_Propagated (E : EOA) is
+ GCC_E : constant GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ pragma Assert (GCC_E /= null);
+ GCC_E.Header.Private1 := 0;
+ end Clear_Setup_And_Not_Propagated;
+
+ ----------------------------------
+ -- Set_Setup_And_Not_Propagated --
+ ----------------------------------
+
+ procedure Set_Setup_And_Not_Propagated (E : EOA) is
+ GCC_E : constant GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ pragma Assert (GCC_E /= null);
+ GCC_E.Header.Private1 := Setup_Key;
+ end Set_Setup_And_Not_Propagated;
+
+ --------------------------------
+ -- Save_Occurrence_And_Private --
+ --------------------------------
+
+ procedure Save_Occurrence_And_Private
+ (Target : out Exception_Occurrence;
+ Source : Exception_Occurrence)
+ is
+ begin
+ Save_Occurrence_No_Private (Target, Source);
+ Target.Private_Data := Source.Private_Data;
+ end Save_Occurrence_And_Private;
+
+ ---------------------
+ -- Setup_Exception --
+ ---------------------
+
+ -- In the GCC-EH implementation of the propagation scheme, this
+ -- subprogram should be understood as: Setup the exception occurrence
+ -- stack headed at Current for a forthcoming raise of Excep.
+
+ procedure Setup_Exception
+ (Excep : EOA;
+ Current : EOA;
+ Reraised : Boolean := False)
+ is
+ Top : constant EOA := Current;
+ Next : EOA;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ begin
+ -- The exception Excep is soon to be propagated, and the
+ -- storage used for that will be the occurrence statically allocated
+ -- for the current thread. This storage might currently be used for a
+ -- still active occurrence, so we need to push it on the thread's
+ -- occurrence stack (headed at that static occurrence) before it gets
+ -- clobbered.
+
+ -- What we do here is to trigger this push when need be, and allocate a
+ -- Private_Data block for the forthcoming Propagation.
+
+ -- Some tasking rendez-vous attempts lead to an occurrence transfer
+ -- from the server to the client (see Exceptional_Complete_Rendezvous).
+ -- In those cases Setup is called twice for the very same occurrence
+ -- before it gets propagated: once from the server, because this is
+ -- where the occurrence contents is elaborated and known, and then
+ -- once from the client when it detects the case and actually raises
+ -- the exception in its own context.
+
+ -- The Is_Setup_And_Not_Propagated predicate tells us when we are in
+ -- the second call to Setup for a Transferred occurrence, and there is
+ -- nothing to be done here in this situation. This predicate cannot be
+ -- True if we are dealing with a Reraise, and we may even be called
+ -- with a raw uninitialized Excep occurrence in this case so we should
+ -- not check anyway. Observe the front-end expansion for a "raise;" to
+ -- see that happening. We get a local occurrence and a direct call to
+ -- Save_Occurrence without the intermediate init-proc call.
+
+ if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
+ return;
+ end if;
+
+ -- Allocate what will be the Private_Data block for the exception
+ -- to be propagated.
+
+ GCC_Exception := new GNAT_GCC_Exception;
+
+ -- If the Top of the occurrence stack is not currently used for an
+ -- active exception (the stack is empty) we just need to setup the
+ -- Private_Data pointer.
+
+ -- Otherwise, we also need to shift the contents of the Top of the
+ -- stack in a freshly allocated entry and link everything together.
+
+ if Top.Private_Data /= System.Null_Address then
+ Next := new Exception_Occurrence;
+ Save_Occurrence_And_Private (Next.all, Top.all);
+
+ GCC_Exception.Next_Exception := Next;
+ Top.Private_Data := GCC_Exception.all'Address;
+ end if;
+
+ Top.Private_Data := GCC_Exception.all'Address;
+
+ Set_Setup_And_Not_Propagated (Top);
+ end Setup_Exception;
+
+ -------------------
+ -- Begin_Handler --
+ -------------------
+
+ procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
+ pragma Unreferenced (GCC_Exception);
+
+ begin
+ -- Every necessary operation related to the occurrence stack has
+ -- already been performed by Propagate_Exception. This hook remains for
+ -- potential future necessity in optimizing the overall scheme, as well
+ -- a useful debugging tool.
+
+ null;
+ end Begin_Handler;
+
+ -----------------
+ -- End_Handler --
+ -----------------
+
+ procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
+ Removed : Boolean;
+ begin
+ Removed := Remove (Get_Current_Excep.all, GCC_Exception);
+ pragma Assert (Removed);
+ end End_Handler;
+
+ -------------------------
+ -- Propagate_Exception --
+ -------------------------
+
+ -- Build an object suitable for the libgcc processing and call
+ -- Unwind_RaiseException to actually throw, taking care of handling
+ -- the two phase scheme it implements.
+
+ procedure Propagate_Exception (From_Signal_Handler : Boolean) is
+ pragma Unreferenced (From_Signal_Handler);
+
+ Excep : constant EOA := Get_Current_Excep.all;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ begin
+ pragma Assert (Excep.Private_Data /= System.Null_Address);
+
+ -- Retrieve the Private_Data for this occurrence and set the useful
+ -- flags for the personality routine, which will be called for each
+ -- frame via Unwind_RaiseException below.
+
+ GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
+
+ Clear_Setup_And_Not_Propagated (Excep);
+
+ GCC_Exception.Id := Excep.Id;
+ GCC_Exception.N_Cleanups_To_Trigger := 0;
+
+ -- Compute the backtrace for this occurrence if the corresponding
+ -- binder option has been set. Call_Chain takes care of the reraise
+ -- case.
+
+ -- ??? Using Call_Chain here means we are going to walk up the stack
+ -- once only for backtracing purposes before doing it again for the
+ -- propagation per se.
+
+ -- The first inspection is much lighter, though, as it only requires
+ -- partial unwinding of each frame. Additionally, although we could use
+ -- the personality routine to record the addresses while propagating,
+ -- this method has two drawbacks:
+
+ -- 1) the trace is incomplete if the exception is handled since we
+ -- don't walk past the frame with the handler,
+
+ -- and
+
+ -- 2) we would miss the frames for which our personality routine is not
+ -- called, e.g. if C or C++ calls are on the way.
+
+ Call_Chain (Excep);
+
+ -- Perform a standard raise first. If a regular handler is found, it
+ -- will be entered after all the intermediate cleanups have run. If
+ -- there is no regular handler, control will get back to after the
+ -- call, with N_Cleanups_To_Trigger set to the number of frames with
+ -- cleanups found on the way up, and none of these already run.
+
+ Unwind_RaiseException (GCC_Exception);
+
+ -- If we get here we know the exception is not handled, as otherwise
+ -- Unwind_RaiseException arranges for the handler to be entered. Take
+ -- the necessary steps to enable the debugger to gain control while the
+ -- stack is still intact.
+
+ Notify_Unhandled_Exception;
+
+ -- Now, if cleanups have been found, run a forced unwind to trigger
+ -- them. Control should not resume there, as the unwinding hook calls
+ -- Unhandled_Exception_Terminate as soon as the last cleanup has been
+ -- triggered.
+
+ if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
+ Unwind_ForcedUnwind (GCC_Exception,
+ CleanupUnwind_Handler'Address,
+ System.Null_Address);
+ end if;
+
+ -- We get here when there is no handler or cleanup to be run at all.
+ -- The debugger has been notified before the second step above.
+
+ Unhandled_Exception_Terminate;
+ end Propagate_Exception;
+
+ ---------------------------
+ -- Adjust_N_Cleanups_For --
+ ---------------------------
+
+ procedure Adjust_N_Cleanups_For
+ (GNAT_Exception : GNAT_GCC_Exception_Access;
+ Adjustment : Integer)
+ is
+ begin
+ GNAT_Exception.N_Cleanups_To_Trigger :=
+ GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;
+ end Adjust_N_Cleanups_For;
+
+ -------------
+ -- EID_For --
+ -------------
+
+ function EID_For
+ (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
+ is
+ begin
+ return GNAT_Exception.Id;
+ end EID_For;
+
+ ---------------------
+ -- Import_Code_For --
+ ---------------------
+
+ function Import_Code_For
+ (E : SSL.Exception_Data_Ptr) return Exception_Code
+ is
+ begin
+ return E.all.Import_Code;
+ end Import_Code_For;
+
+ --------------------------
+ -- Is_Handled_By_Others --
+ --------------------------
+
+ function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
+ begin
+ return not E.all.Not_Handled_By_Others;
+ end Is_Handled_By_Others;
+
+ ------------------
+ -- Language_For --
+ ------------------
+
+ function Language_For (E : SSL.Exception_Data_Ptr) return Character is
+ begin
+ return E.all.Lang;
+ end Language_For;
+
+ -----------
+ -- Notes --
+ -----------
+
+ -- The current model implemented for the stack of occurrences is a
+ -- simplification of previous attempts, which all prooved to be flawed or
+ -- would have needed significant additional circuitry to be made to work
+ -- correctly.
+
+ -- We now represent every propagation by a new entry on the stack, which
+ -- means that an exception occurrence may appear more than once (e.g. when
+ -- it is reraised during the course of its own handler).
+
+ -- This may seem overcostly compared to the C++ model as implemented in
+ -- the g++ v3 libstd. This is actually understandable when one considers
+ -- the extra variations of possible run-time configurations induced by the
+ -- freedom offered by the Save_Occurrence/Reraise_Occurrence public
+ -- interface.
+
+ -- The basic point is that arranging for an occurrence to always appear at
+ -- most once on the stack requires a way to determine if a given occurence
+ -- is already there, which is not as easy as it might seem.
+
+ -- An attempt was made to use the Private_Data pointer for this purpose.
+ -- It did not work because:
+
+ -- 1) The Private_Data has to be saved by Save_Occurrence to be usable
+ -- as a key in case of a later reraise,
+
+ -- 2) There is no easy way to synchronize End_Handler for an occurrence
+ -- and the data attached to potential copies, so these copies may end
+ -- up pointing to stale data. Moreover ...
+
+ -- 3) The same address may be reused for different occurrences, which
+ -- defeats the idea of using it as a key.
+
+ -- The example below illustrates:
+
+ -- Saved_CE : Exception_Occurrence;
+
+ -- begin
+ -- raise Constraint_Error;
+ -- exception
+ -- when CE: others =>
+ -- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA
+ -- end;
+
+ -- <= Saved_CE.PDA is stale (!)
+
+ -- begin
+ -- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!)
+ -- exception
+ -- when others =>
+ -- Reraise_Occurrence (Saved_CE);
+ -- end;
+
+ -- Not releasing the Private_Data via End_Handler could be an option,
+ -- but making this to work while still avoiding memory leaks is far
+ -- from trivial.
+
+ -- The current scheme has the advantage of beeing simple, and induces
+ -- extra costs only in reraise cases which is acceptable.
+
+end Exception_Propagation;
diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb
index 8cccf1699e9..165b5cef3d8 100644
--- a/gcc/ada/a-exexpr.adb
+++ b/gcc/ada/a-exexpr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
@@ -31,10 +31,8 @@
-- --
------------------------------------------------------------------------------
-with Interfaces;
-
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
+-- This is the default version, using the __builtin_setjmp/longjmp EH
+-- mechanism.
with System.Storage_Elements; use System.Storage_Elements;
@@ -45,681 +43,80 @@ pragma Warnings (Off);
separate (Ada.Exceptions)
package body Exception_Propagation is
- ------------------------------------------------
- -- Entities to interface with the GCC runtime --
- ------------------------------------------------
-
- -- These come from "C++ ABI for Itanium: Exception handling", which is
- -- the reference for GCC. They are used only when we are relying on
- -- back-end tables for exception propagation, which in turn is currenly
- -- only the case for Zero_Cost_Exceptions in GNAT5.
-
- -- Return codes from the GCC runtime functions used to propagate
- -- an exception.
-
- type Unwind_Reason_Code is
- (URC_NO_REASON,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Unreferenced
- (URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Convention (C, Unwind_Reason_Code);
-
- -- Phase identifiers
-
- type Unwind_Action is
- (UA_SEARCH_PHASE,
- UA_CLEANUP_PHASE,
- UA_HANDLER_FRAME,
- UA_FORCE_UNWIND);
-
- for Unwind_Action use
- (UA_SEARCH_PHASE => 1,
- UA_CLEANUP_PHASE => 2,
- UA_HANDLER_FRAME => 4,
- UA_FORCE_UNWIND => 8);
-
- pragma Convention (C, Unwind_Action);
-
- -- Mandatory common header for any exception object handled by the
- -- GCC unwinding runtime.
-
- subtype Exception_Class is Interfaces.Unsigned_64;
-
- GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
- -- "GNU-Ada\0"
-
- type Unwind_Word is mod 2 ** System.Word_Size;
- for Unwind_Word'Size use System.Word_Size;
- -- Map the corresponding C type used in Unwind_Exception below
-
- type Unwind_Exception is record
- Class : Exception_Class := GNAT_Exception_Class;
- Cleanup : System.Address := System.Null_Address;
- Private1 : Unwind_Word;
- Private2 : Unwind_Word;
- end record;
- -- Map the GCC struct used for exception handling
-
- for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
- -- The C++ ABI mandates the common exception header to be at least
- -- doubleword aligned, and the libGCC implementation actually makes it
- -- maximally aligned (see unwind.h). See additional comments on the
- -- alignment below.
-
- --------------------------------------------------------------
- -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
- --------------------------------------------------------------
-
- -- A GNAT exception object to be dealt with by the personality routine
- -- called by the GCC unwinding runtime.
-
- type GNAT_GCC_Exception is record
- Header : Unwind_Exception;
- -- ABI Exception header first
-
- Id : Exception_Id;
- -- GNAT Exception identifier. This is filled by Propagate_Exception
- -- and then used by the personality routine to determine if the context
- -- it examines contains a handler for the exception beeing propagated.
-
- N_Cleanups_To_Trigger : Integer;
- -- Number of cleanup only frames encountered in SEARCH phase. This is
- -- initialized to 0 by Propagate_Exception and maintained by the
- -- personality routine to control a forced unwinding phase triggering
- -- all the cleanups before calling Unhandled_Exception_Terminate when
- -- an exception is not handled.
-
- Next_Exception : EOA;
- -- Used to create a linked list of exception occurrences
- end record;
-
- pragma Convention (C, GNAT_GCC_Exception);
-
- -- There is a subtle issue with the common header alignment, since the C
- -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
- -- Standard'Maximum_Alignment, and those two values don't quite represent
- -- the same concepts and so may be decoupled someday. One typical reason
- -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
- -- allocator guarantees, and there are extra costs involved in allocating
- -- objects aligned to such factors.
-
- -- To deal with the potential alignment differences between the C and Ada
- -- representations, the Ada part of the whole structure is only accessed
- -- by the personality routine through the accessors declared below. Ada
- -- specific fields are thus always accessed through consistent layout, and
- -- we expect the actual alignment to always be large enough to avoid traps
- -- from the C accesses to the common header. Besides, accessors aleviate
- -- the need for a C struct whole conterpart, both painful and errorprone
- -- to maintain anyway.
-
- type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
-
- function To_GNAT_GCC_Exception is new
- Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
-
- procedure Free is new Unchecked_Deallocation
- (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
-
- procedure Free is new Unchecked_Deallocation
- (Exception_Occurrence, EOA);
-
- function CleanupUnwind_Handler
- (UW_Version : Integer;
- UW_Phases : Unwind_Action;
- UW_Eclass : Exception_Class;
- UW_Exception : access GNAT_GCC_Exception;
- UW_Context : System.Address;
- UW_Argument : System.Address) return Unwind_Reason_Code;
- -- Hook called at each step of the forced unwinding we perform to
- -- trigger cleanups found during the propagation of an unhandled
- -- exception.
-
- -- GCC runtime functions used. These are C non-void functions, actually,
- -- but we ignore the return values. See raise.c as to why we are using
- -- __gnat stubs for these.
-
- procedure Unwind_RaiseException
- (UW_Exception : access GNAT_GCC_Exception);
- pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
-
- procedure Unwind_ForcedUnwind
- (UW_Exception : access GNAT_GCC_Exception;
- UW_Handler : System.Address;
- UW_Argument : System.Address);
- pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
-
- ------------------------------------------------------------------
- -- Occurrence Stack Management Facilities for the GCC-EH Scheme --
- ------------------------------------------------------------------
-
- function Remove
- (Top : EOA;
- Excep : GNAT_GCC_Exception_Access) return Boolean;
- -- Remove Excep from the stack starting at Top.
- -- Return True if Excep was found and removed, false otherwise.
-
- -- Hooks called when entering/leaving an exception handler for a given
- -- occurrence, aimed at handling the stack of active occurrences. The
- -- calls are generated by gigi in tree_transform/N_Exception_Handler.
-
- procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
- pragma Export (C, Begin_Handler, "__gnat_begin_handler");
-
- procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
- pragma Export (C, End_Handler, "__gnat_end_handler");
-
- Setup_Key : constant := 16#DEAD#;
- -- To handle the case of a task "transferring" an exception occurrence to
- -- another task, for instance via Exceptional_Complete_Rendezvous, we need
- -- to be able to identify occurrences which have been Setup and not yet
- -- Propagated. We hijack one of the common header fields for that purpose,
- -- setting it to a special key value during the setup process, clearing it
- -- at the very beginning of the propagation phase, and expecting it never
- -- to be reset to the special value later on. A 16-bit value is used rather
- -- than a 32-bit value for static compatibility with 16-bit targets such as
- -- AAMP (where type Unwind_Word will be 16 bits).
-
- function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
-
- procedure Set_Setup_And_Not_Propagated (E : EOA);
- procedure Clear_Setup_And_Not_Propagated (E : EOA);
-
- ------------------------------------------------------------
- -- Accessors to basic components of a GNAT exception data --
- ------------------------------------------------------------
-
- -- As of today, these are only used by the C implementation of the
- -- GCC propagation personality routine to avoid having to rely on a C
- -- counterpart of the whole exception_data structure, which is both
- -- painful and error prone. These subprograms could be moved to a
- -- more widely visible location if need be.
-
- function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
- pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
-
- function Language_For (E : Exception_Data_Ptr) return Character;
- pragma Export (C, Language_For, "__gnat_language_for");
-
- function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
- pragma Export (C, Import_Code_For, "__gnat_import_code_for");
-
- function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
- return Exception_Id;
- pragma Export (C, EID_For, "__gnat_eid_for");
-
- procedure Adjust_N_Cleanups_For
- (GNAT_Exception : GNAT_GCC_Exception_Access;
- Adjustment : Integer);
- pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");
-
- ---------------------------------------------------------------------------
- -- Objects to materialize "others" and "all others" in the GCC EH tables --
- ---------------------------------------------------------------------------
-
- -- Currently, these only have their address taken and compared so there is
- -- no real point having whole exception data blocks allocated. In any case
- -- the types should match what gigi and the personality routine expect.
- -- The initial value is an arbitrary value that will not exceed the range
- -- of Integer on 16-bit targets (such as AAMP).
-
- Others_Value : constant Integer := 16#7FFF#;
- pragma Export (C, Others_Value, "__gnat_others_value");
-
- All_Others_Value : constant Integer := 16#7FFF#;
- pragma Export (C, All_Others_Value, "__gnat_all_others_value");
-
- ------------
- -- Remove --
- ------------
-
- function Remove
- (Top : EOA;
- Excep : GNAT_GCC_Exception_Access) return Boolean
- is
- Prev : GNAT_GCC_Exception_Access := null;
- Iter : EOA := Top;
- GCC_Exception : GNAT_GCC_Exception_Access;
-
- begin
- -- Pop stack
-
- loop
- pragma Assert (Iter.Private_Data /= System.Null_Address);
-
- GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
-
- if GCC_Exception = Excep then
- if Prev = null then
-
- -- Special case for the top of the stack: shift the contents
- -- of the next item to the top, since top is at a fixed
- -- location and can't be changed.
-
- Iter := GCC_Exception.Next_Exception;
-
- if Iter = null then
-
- -- Stack is now empty
-
- Top.Private_Data := System.Null_Address;
-
- else
- Save_Occurrence_And_Private (Top.all, Iter.all);
- Free (Iter);
- end if;
-
- else
- Prev.Next_Exception := GCC_Exception.Next_Exception;
- Free (Iter);
- end if;
-
- Free (GCC_Exception);
-
- return True;
- end if;
-
- exit when GCC_Exception.Next_Exception = null;
-
- Prev := GCC_Exception;
- Iter := GCC_Exception.Next_Exception;
- end loop;
-
- return False;
- end Remove;
-
- ---------------------------
- -- CleanupUnwind_Handler --
- ---------------------------
-
- function CleanupUnwind_Handler
- (UW_Version : Integer;
- UW_Phases : Unwind_Action;
- UW_Eclass : Exception_Class;
- UW_Exception : access GNAT_GCC_Exception;
- UW_Context : System.Address;
- UW_Argument : System.Address) return Unwind_Reason_Code
- is
- begin
- -- Terminate as soon as we know there is nothing more to run. The
- -- count is maintained by the personality routine.
-
- if UW_Exception.N_Cleanups_To_Trigger = 0 then
- Unhandled_Exception_Terminate;
- end if;
-
- -- We know there is at least one cleanup further up. Return so that it
- -- is searched and entered, after which Unwind_Resume will be called
- -- and this hook will gain control (with an updated count) again.
-
- return URC_NO_REASON;
- end CleanupUnwind_Handler;
-
- ---------------------------------
- -- Is_Setup_And_Not_Propagated --
- ---------------------------------
-
- function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
- GCC_E : GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (E.Private_Data);
- begin
- return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
- end Is_Setup_And_Not_Propagated;
-
- ------------------------------------
- -- Clear_Setup_And_Not_Propagated --
- ------------------------------------
-
- procedure Clear_Setup_And_Not_Propagated (E : EOA) is
- GCC_E : GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (E.Private_Data);
- begin
- pragma Assert (GCC_E /= null);
- GCC_E.Header.Private1 := 0;
- end Clear_Setup_And_Not_Propagated;
-
- ----------------------------------
- -- Set_Setup_And_Not_Propagated --
- ----------------------------------
-
- procedure Set_Setup_And_Not_Propagated (E : EOA) is
- GCC_E : GNAT_GCC_Exception_Access :=
- To_GNAT_GCC_Exception (E.Private_Data);
- begin
- pragma Assert (GCC_E /= null);
- GCC_E.Header.Private1 := Setup_Key;
- end Set_Setup_And_Not_Propagated;
+ procedure builtin_longjmp (buffer : Address; Flag : Integer);
+ pragma No_Return (builtin_longjmp);
+ pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
---------------------
-- Setup_Exception --
---------------------
- -- In the GCC-EH implementation of the propagation scheme, this
- -- subprogram should be understood as : Setup the exception occurrence
- -- stack headed at Current for a forthcoming raise of Excep.
-
- -- In the GNAT-SJLJ case this "stack" only exists implicitely, by way of
- -- local occurrence declarations together with save/restore operations
- -- generated by the front-end, and this routine has nothing to do.
-
- -- The differenciation is done here and not in the callers to avoid having
- -- to spread out the test in numerous places.
-
procedure Setup_Exception
(Excep : EOA;
Current : EOA;
Reraised : Boolean := False)
is
- Top : constant EOA := Current;
- Next : EOA;
- GCC_Exception : GNAT_GCC_Exception_Access;
-
- begin
- -- Just return if we're not in the GCC-EH case. What is otherwise
- -- performed is useless and even harmful since it potentially involves
- -- dynamic allocations that would never be released, and participates
- -- in the Setup_And_Not_Propagated predicate management, only properly
- -- handled by the rest of the GCC-EH scheme.
-
- if Zero_Cost_Exceptions = 0 then
- return;
- end if;
-
- -- Otherwise, the exception Excep is soon to be propagated, and the
- -- storage used for that will be the occurrence statically allocated
- -- for the current thread. This storage might currently be used for a
- -- still active occurrence, so we need to push it on the thread's
- -- occurrence stack (headed at that static occurrence) before it gets
- -- clobbered.
-
- -- What we do here is to trigger this push when need be, and allocate a
- -- Private_Data block for the forthcoming Propagation.
-
- -- Some tasking rendez-vous attempts lead to an occurrence transfer
- -- from the server to the client (see Exceptional_Complete_Rendezvous).
- -- In those cases Setup is called twice for the very same occurrence
- -- before it gets propagated: once from the server, because this is
- -- where the occurrence contents is elaborated and known, and then
- -- once from the client when it detects the case and actually raises
- -- the exception in its own context.
-
- -- The Is_Setup_And_Not_Propagated predicate tells us when we are in
- -- the second call to Setup for a Transferred occurrence, and there is
- -- nothing to be done here in this situation. This predicate cannot be
- -- True if we are dealing with a Reraise, and we may even be called
- -- with a raw uninitialized Excep occurrence in this case so we should
- -- not check anyway. Observe the front-end expansion for a "raise;" to
- -- see that happening. We get a local occurrence and a direct call to
- -- Save_Occurrence without the intermediate init-proc call.
-
- if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
- return;
- end if;
-
- -- Allocate what will be the Private_Data block for the exception
- -- to be propagated.
-
- GCC_Exception := new GNAT_GCC_Exception;
-
- -- If the Top of the occurrence stack is not currently used for an
- -- active exception (the stack is empty) we just need to setup the
- -- Private_Data pointer.
-
- -- Otherwise, we also need to shift the contents of the Top of the
- -- stack in a freshly allocated entry and link everything together.
-
- if Top.Private_Data /= System.Null_Address then
- Next := new Exception_Occurrence;
- Save_Occurrence_And_Private (Next.all, Top.all);
-
- GCC_Exception.Next_Exception := Next;
- Top.Private_Data := GCC_Exception.all'Address;
- end if;
-
- Top.Private_Data := GCC_Exception.all'Address;
-
- Set_Setup_And_Not_Propagated (Top);
- end Setup_Exception;
-
- -------------------
- -- Begin_Handler --
- -------------------
-
- procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
+ pragma Unreferenced (Excep, Current, Reraised);
begin
- -- Every necessary operation related to the occurrence stack has
- -- already been performed by Propagate_Exception. This hook remains for
- -- potential future necessity in optimizing the overall scheme, as well
- -- a useful debugging tool.
+ -- In the GNAT-SJLJ case this "stack" only exists implicitely, by way of
+ -- local occurrence declarations together with save/restore operations
+ -- generated by the front-end, and this routine has nothing to do.
null;
- end Begin_Handler;
-
- -----------------
- -- End_Handler --
- -----------------
-
- procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
- Removed : Boolean;
- begin
- Removed := Remove (Get_Current_Excep.all, GCC_Exception);
- pragma Assert (Removed);
- end End_Handler;
+ end Setup_Exception;
-------------------------
-- Propagate_Exception --
-------------------------
- -- Build an object suitable for the libgcc processing and call
- -- Unwind_RaiseException to actually throw, taking care of handling
- -- the two phase scheme it implements.
-
procedure Propagate_Exception (From_Signal_Handler : Boolean) is
- Excep : EOA := Get_Current_Excep.all;
- GCC_Exception : GNAT_GCC_Exception_Access;
-
+ Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
+ Excep : constant EOA := Get_Current_Excep.all;
begin
- pragma Assert (Excep.Private_Data /= System.Null_Address);
+ -- Compute the backtrace for this occurrence if corresponding binder
+ -- option has been set. Call_Chain takes care of the reraise case.
- -- Retrieve the Private_Data for this occurrence and set the useful
- -- flags for the personality routine, which will be called for each
- -- frame via Unwind_RaiseException below.
-
- GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
-
- Clear_Setup_And_Not_Propagated (Excep);
-
- GCC_Exception.Id := Excep.Id;
- GCC_Exception.N_Cleanups_To_Trigger := 0;
-
- -- Compute the backtrace for this occurrence if the corresponding
- -- binder option has been set. Call_Chain takes care of the reraise
- -- case.
+ Call_Chain (Excep);
- -- ??? Using Call_Chain here means we are going to walk up the stack
- -- once only for backtracing purposes before doing it again for the
- -- propagation per se.
+ -- Note on above call to Call_Chain:
- -- The first inspection is much lighter, though, as it only requires
- -- partial unwinding of each frame. Additionally, although we could use
- -- the personality routine to record the addresses while propagating,
- -- this method has two drawbacks:
+ -- We used to only do this if From_Signal_Handler was not set,
+ -- based on the assumption that backtracing from a signal handler
+ -- would not work due to stack layout oddities. However, since
- -- 1) the trace is incomplete if the exception is handled since we
- -- don't walk past the frame with the handler,
+ -- 1. The flag is never set in tasking programs (Notify_Exception
+ -- performs regular raise statements), and
- -- and
+ -- 2. No problem has shown up in tasking programs around here so
+ -- far, this turned out to be too strong an assumption.
- -- 2) we would miss the frames for which our personality routine is not
- -- called, e.g. if C or C++ calls are on the way.
+ -- As, in addition, the test was
- Call_Chain (Excep);
+ -- 1. preventing the production of backtraces in non-tasking
+ -- programs, and
- -- Perform a standard raise first. If a regular handler is found, it
- -- will be entered after all the intermediate cleanups have run. If
- -- there is no regular handler, control will get back to after the
- -- call, with N_Cleanups_To_Trigger set to the number of frames with
- -- cleanups found on the way up, and none of these already run.
+ -- 2. introducing a behavior inconsistency between
+ -- the tasking and non-tasking cases,
- Unwind_RaiseException (GCC_Exception);
+ -- we have simply removed it
- -- If we get here we know the exception is not handled, as otherwise
- -- Unwind_RaiseException arranges for the handler to be entered. Take
- -- the necessary steps to enable the debugger to gain control while the
- -- stack is still intact.
+ -- If the jump buffer pointer is non-null, transfer control using
+ -- it. Otherwise announce an unhandled exception (note that this
+ -- means that we have no finalizations to do other than at the outer
+ -- level). Perform the necessary notification tasks in both cases.
- Notify_Unhandled_Exception;
+ if Jumpbuf_Ptr /= Null_Address then
+ if not Excep.Exception_Raised then
+ Excep.Exception_Raised := True;
+ Exception_Traces.Notify_Handled_Exception;
+ end if;
- -- Now, if cleanups have been found, run a forced unwind to trigger
- -- them. Control should not resume there, as the unwinding hook calls
- -- Unhandled_Exception_Terminate as soon as the last cleanup has been
- -- triggered.
+ builtin_longjmp (Jumpbuf_Ptr, 1);
- if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
- Unwind_ForcedUnwind (GCC_Exception,
- CleanupUnwind_Handler'Address,
- System.Null_Address);
+ else
+ Exception_Traces.Notify_Unhandled_Exception;
+ Exception_Traces.Unhandled_Exception_Terminate;
end if;
-
- -- We get here when there is no handler or cleanup to be run at
- -- all. The debugger has been notified before the second step above.
-
- Unhandled_Exception_Terminate;
end Propagate_Exception;
- ---------------------------
- -- Adjust_N_Cleanups_For --
- ---------------------------
-
- procedure Adjust_N_Cleanups_For
- (GNAT_Exception : GNAT_GCC_Exception_Access;
- Adjustment : Integer)
- is
- begin
- GNAT_Exception.N_Cleanups_To_Trigger :=
- GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;
- end Adjust_N_Cleanups_For;
-
- -------------
- -- EID_For --
- -------------
-
- function EID_For
- (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
- is
- begin
- return GNAT_Exception.Id;
- end EID_For;
-
- ---------------------
- -- Import_Code_For --
- ---------------------
-
- function Import_Code_For
- (E : SSL.Exception_Data_Ptr) return Exception_Code
- is
- begin
- return E.all.Import_Code;
- end Import_Code_For;
-
- --------------------------
- -- Is_Handled_By_Others --
- --------------------------
-
- function Is_Handled_By_Others
- (E : SSL.Exception_Data_Ptr) return Boolean
- is
- begin
- return not E.all.Not_Handled_By_Others;
- end Is_Handled_By_Others;
-
- ------------------
- -- Language_For --
- ------------------
-
- function Language_For
- (E : SSL.Exception_Data_Ptr) return Character
- is
- begin
- return E.all.Lang;
- end Language_For;
-
- -----------
- -- Notes --
- -----------
-
- -- The current model implemented for the stack of occurrences is a
- -- simplification of previous attempts, which all prooved to be flawed or
- -- would have needed significant additional circuitry to be made to work
- -- correctly.
-
- -- We now represent every propagation by a new entry on the stack, which
- -- means that an exception occurrence may appear more than once (e.g. when
- -- it is reraised during the course of its own handler).
-
- -- This may seem overcostly compared to the C++ model as implemented in
- -- the g++ v3 libstd. This is actually understandable when one considers
- -- the extra variations of possible run-time configurations induced by the
- -- freedom offered by the Save_Occurrence/Reraise_Occurrence public
- -- interface.
-
- -- The basic point is that arranging for an occurrence to always appear at
- -- most once on the stack requires a way to determine if a given occurence
- -- is already there, which is not as easy as it might seem.
-
- -- An attempt was made to use the Private_Data pointer for this purpose.
- -- It did not work because:
-
- -- 1) The Private_Data has to be saved by Save_Occurrence to be usable
- -- as a key in case of a later reraise,
-
- -- 2) There is no easy way to synchronize End_Handler for an occurrence
- -- and the data attached to potential copies, so these copies may end
- -- up pointing to stale data. Moreover ...
-
- -- 3) The same address may be reused for different occurrences, which
- -- defeats the idea of using it as a key.
-
- -- The example below illustrates:
-
- -- Saved_CE : Exception_Occurrence;
-
- -- begin
- -- raise Constraint_Error;
- -- exception
- -- when CE: others =>
- -- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA
- -- end;
-
- -- <= Saved_CE.PDA is stale (!)
-
- -- begin
- -- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!)
- -- exception
- -- when others =>
- -- Reraise_Occurrence (Saved_CE);
- -- end;
-
- -- Not releasing the Private_Data via End_Handler could be an option,
- -- but making this to work while still avoiding memory leaks is far
- -- from trivial.
-
- -- The current scheme has the advantage of beeing simple, and induces
- -- extra costs only in reraise cases which is acceptable.
-
end Exception_Propagation;
diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
new file mode 100644
index 00000000000..0f9b94c7cd9
--- /dev/null
+++ b/gcc/ada/raise-gcc.c
@@ -0,0 +1,1150 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * R A I S E - G C C *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 1992-2005, 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 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
+ * Boston, MA 02110-1301, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* Code related to the integration of the GCC mechanism for exception
+ handling. */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2
+ it does. To avoid branching raise.c just for that purpose, we kludge by
+ looking for a symbol always defined by tm.h and if it's not defined,
+ we include it. */
+#ifndef FIRST_PSEUDO_REGISTER
+#include "coretypes.h"
+#include "tm.h"
+#endif
+#include "tsystem.h"
+#include <sys/stat.h>
+typedef char bool;
+# define true 1
+# define false 0
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+#include "raise.h"
+
+/* The names of a couple of "standard" routines for unwinding/propagation
+ actually vary depending on the underlying GCC scheme for exception handling
+ (SJLJ or DWARF). We need a consistently named interface to import from
+ a-except, so wrappers are defined here.
+
+ Besides, eventhough the compiler is never setup to use the GCC propagation
+ circuitry, it still relies on exceptions internally and part of the sources
+ to handle to exceptions are shared with the run-time library. We need
+ dummy definitions for the wrappers to satisfy the linker in this case.
+
+ The types to be used by those wrappers in the run-time library are target
+ types exported by unwind.h. We used to piggyback on them for the compiler
+ stubs, but there is no guarantee that unwind.h is always in sight so we
+ define our own set below. These are dummy types as the wrappers are never
+ called in the compiler case. */
+
+#ifdef IN_RTS
+
+#include "unwind.h"
+
+typedef struct _Unwind_Context _Unwind_Context;
+typedef struct _Unwind_Exception _Unwind_Exception;
+
+#else
+
+typedef void _Unwind_Context;
+typedef void _Unwind_Exception;
+typedef int _Unwind_Reason_Code;
+
+#endif
+
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException (_Unwind_Exception *);
+
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
+
+
+#ifdef IN_RTS /* For eh personality routine */
+
+#include "dwarf2.h"
+#include "unwind-dw2-fde.h"
+#include "unwind-pe.h"
+
+
+/* --------------------------------------------------------------
+ -- The DB stuff below is there for debugging purposes only. --
+ -------------------------------------------------------------- */
+
+#define DB_PHASES 0x1
+#define DB_CSITE 0x2
+#define DB_ACTIONS 0x4
+#define DB_REGIONS 0x8
+
+#define DB_ERR 0x1000
+
+/* The "action" stuff below is also there for debugging purposes only. */
+
+typedef struct
+{
+ _Unwind_Action phase;
+ char * description;
+} phase_descriptor;
+
+static phase_descriptor phase_descriptors[]
+ = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" },
+ { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" },
+ { _UA_HANDLER_FRAME, "HANDLER_FRAME" },
+ { _UA_FORCE_UNWIND, "FORCE_UNWIND" },
+ { -1, 0}};
+
+static int
+db_accepted_codes (void)
+{
+ static int accepted_codes = -1;
+
+ if (accepted_codes == -1)
+ {
+ char * db_env = (char *) getenv ("EH_DEBUG");
+
+ accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0;
+ /* Arranged for ERR stuff to always be visible when the variable
+ is defined. One may just set the variable to 0 to see the ERR
+ stuff only. */
+ }
+
+ return accepted_codes;
+}
+
+#define DB_INDENT_INCREASE 0x01
+#define DB_INDENT_DECREASE 0x02
+#define DB_INDENT_OUTPUT 0x04
+#define DB_INDENT_NEWLINE 0x08
+#define DB_INDENT_RESET 0x10
+
+#define DB_INDENT_UNIT 8
+
+static void
+db_indent (int requests)
+{
+ static int current_indentation_level = 0;
+
+ if (requests & DB_INDENT_RESET)
+ {
+ current_indentation_level = 0;
+ }
+
+ if (requests & DB_INDENT_INCREASE)
+ {
+ current_indentation_level ++;
+ }
+
+ if (requests & DB_INDENT_DECREASE)
+ {
+ current_indentation_level --;
+ }
+
+ if (requests & DB_INDENT_NEWLINE)
+ {
+ fprintf (stderr, "\n");
+ }
+
+ if (requests & DB_INDENT_OUTPUT)
+ {
+ fprintf (stderr, "%*s",
+ current_indentation_level * DB_INDENT_UNIT, " ");
+ }
+
+}
+
+static void ATTRIBUTE_PRINTF_2
+db (int db_code, char * msg_format, ...)
+{
+ if (db_accepted_codes () & db_code)
+ {
+ va_list msg_args;
+
+ db_indent (DB_INDENT_OUTPUT);
+
+ va_start (msg_args, msg_format);
+ vfprintf (stderr, msg_format, msg_args);
+ va_end (msg_args);
+ }
+}
+
+static void
+db_phases (int phases)
+{
+ phase_descriptor *a = phase_descriptors;
+
+ if (! (db_accepted_codes() & DB_PHASES))
+ return;
+
+ db (DB_PHASES, "\n");
+
+ for (; a->description != 0; a++)
+ if (phases & a->phase)
+ db (DB_PHASES, "%s ", a->description);
+
+ db (DB_PHASES, " :\n");
+}
+
+
+/* ---------------------------------------------------------------
+ -- Now come a set of useful structures and helper routines. --
+ --------------------------------------------------------------- */
+
+/* There are three major runtime tables involved, generated by the
+ GCC back-end. Contents slightly vary depending on the underlying
+ implementation scheme (dwarf zero cost / sjlj).
+
+ =======================================
+ * Tables for the dwarf zero cost case *
+ =======================================
+
+ call_site []
+ -------------------------------------------------------------------
+ * region-start | region-length | landing-pad | first-action-index *
+ -------------------------------------------------------------------
+
+ Identify possible actions to be taken and where to resume control
+ for that when an exception propagates through a pc inside the region
+ delimited by start and length.
+
+ A null landing-pad indicates that nothing is to be done.
+
+ Otherwise, first-action-index provides an entry into the action[]
+ table which heads a list of possible actions to be taken (see below).
+
+ If it is determined that indeed an action should be taken, that
+ is, if one action filter matches the exception being propagated,
+ then control should be transfered to landing-pad.
+
+ A null first-action-index indicates that there are only cleanups
+ to run there.
+
+ action []
+ -------------------------------
+ * action-filter | next-action *
+ -------------------------------
+
+ This table contains lists (called action chains) of possible actions
+ associated with call-site entries described in the call-site [] table.
+ There is at most one action list per call-site entry.
+
+ A null action-filter indicates a cleanup.
+
+ Non null action-filters provide an index into the ttypes [] table
+ (see below), from which information may be retrieved to check if it
+ matches the exception being propagated.
+
+ action-filter > 0 means there is a regular handler to be run,
+
+ action-filter < 0 means there is a some "exception_specification"
+ data to retrieve, which is only relevant for C++
+ and should never show up for Ada.
+
+ next-action indexes the next entry in the list. 0 indicates there is
+ no other entry.
+
+ ttypes []
+ ---------------
+ * ttype-value *
+ ---------------
+
+ A null value indicates a catch-all handler in C++, and an "others"
+ handler in Ada.
+
+ Non null values are used to match the exception being propagated:
+ In C++ this is a pointer to some rtti data, while in Ada this is an
+ exception id.
+
+ The special id value 1 indicates an "all_others" handler.
+
+ For C++, this table is actually also used to store "exception
+ specification" data. The differentiation between the two kinds
+ of entries is made by the sign of the associated action filter,
+ which translates into positive or negative offsets from the
+ so called base of the table:
+
+ Exception Specification data is stored at positive offsets from
+ the ttypes table base, which Exception Type data is stored at
+ negative offsets:
+
+ ---------------------------------------------------------------------------
+
+ Here is a quick summary of the tables organization:
+
+ +-- Unwind_Context (pc, ...)
+ |
+ |(pc)
+ |
+ | CALL-SITE[]
+ |
+ | +=============================================================+
+ | | region-start + length | landing-pad | first-action-index |
+ | +=============================================================+
+ +-> | pc range 0 => no-action 0 => cleanups only |
+ | !0 => jump @ N --+ |
+ +====================================================== | ====+
+ |
+ |
+ ACTION [] |
+ |
+ +==========================================================+ |
+ | action-filter | next-action | |
+ +==========================================================+ |
+ | 0 => cleanup | |
+ | >0 => ttype index for handler ------+ 0 => end of chain | <-+
+ | <0 => ttype index for spec data | |
+ +==================================== | ===================+
+ |
+ |
+ TTYPES [] |
+ | Offset negated from
+ +=====================+ | the actual base.
+ | ttype-value | |
+ +============+=====================+ |
+ | | 0 => "others" | |
+ | ... | 1 => "all others" | <---+
+ | | X => exception id |
+ | handlers +---------------------+
+ | | ... |
+ | ... | ... |
+ | | ... |
+ +============+=====================+ <<------ Table base
+ | ... | ... |
+ | specs | ... | (should not see negative filter
+ | ... | ... | values for Ada).
+ +============+=====================+
+
+
+ ============================
+ * Tables for the sjlj case *
+ ============================
+
+ So called "function contexts" are pushed on a context stack by calls to
+ _Unwind_SjLj_Register on function entry, and popped off at exit points by
+ calls to _Unwind_SjLj_Unregister. The current call_site for a function is
+ updated in the function context as the function's code runs along.
+
+ The generic unwinding engine in _Unwind_RaiseException walks the function
+ context stack and not the actual call chain.
+
+ The ACTION and TTYPES tables remain unchanged, which allows to search them
+ during the propagation phase to determine wether or not the propagated
+ exception is handled somewhere. When it is, we only "jump" up once directly
+ to the context where the handler will be found. Besides, this allows "break
+ exception unhandled" to work also
+
+ The CALL-SITE table is setup differently, though: the pc attached to the
+ unwind context is a direct index into the table, so the entries in this
+ table do not hold region bounds any more.
+
+ A special index (-1) is used to indicate that no action is possibly
+ connected with the context at hand, so null landing pads cannot appear
+ in the table.
+
+ Additionally, landing pad values in the table do not represent code address
+ to jump at, but so called "dispatch" indices used by a common landing pad
+ for the function to switch to the appropriate post-landing-pad.
+
+ +-- Unwind_Context (pc, ...)
+ |
+ | pc = call-site index
+ | 0 => terminate (should not see this for Ada)
+ | -1 => no-action
+ |
+ | CALL-SITE[]
+ |
+ | +=====================================+
+ | | landing-pad | first-action-index |
+ | +=====================================+
+ +-> | 0 => cleanups only |
+ | dispatch index N |
+ +=====================================+
+
+
+ ===================================
+ * Basic organization of this unit *
+ ===================================
+
+ The major point of this unit is to provide an exception propagation
+ personality routine for Ada. This is __gnat_eh_personality.
+
+ It is provided with a pointer to the propagated exception, an unwind
+ context describing a location the propagation is going through, and a
+ couple of other arguments including a description of the current
+ propagation phase.
+
+ It shall return to the generic propagation engine what is to be performed
+ next, after possible context adjustments, depending on what it finds in the
+ traversed context (a handler for the exception, a cleanup, nothing, ...),
+ and on the propagation phase.
+
+ A number of structures and subroutines are used for this purpose, as
+ sketched below:
+
+ o region_descriptor: General data associated with the context (base pc,
+ call-site table, action table, ttypes table, ...)
+
+ o action_descriptor: Data describing the action to be taken for the
+ propagated exception in the provided context (kind of action: nothing,
+ handler, cleanup; pointer to the action table entry, ...).
+
+ raise
+ |
+ ... (a-except.adb)
+ |
+ Propagate_Exception (a-exexpr.adb)
+ |
+ |
+ _Unwind_RaiseException (libgcc)
+ |
+ | (Ada frame)
+ |
+ +--> __gnat_eh_personality (context, exception)
+ |
+ +--> get_region_descriptor_for (context)
+ |
+ +--> get_action_descriptor_for (context, exception, region)
+ | |
+ | +--> get_call_site_action_for (context, region)
+ | (one version for each underlying scheme)
+ |
+ +--> setup_to_install (context)
+
+ This unit is inspired from the C++ version found in eh_personality.cc,
+ part of libstdc++-v3.
+
+*/
+
+
+/* This is an incomplete "proxy" of the structure of exception objects as
+ built by the GNAT runtime library. Accesses to other fields than the common
+ header are performed through subprogram calls to alleviate the need of an
+ exact counterpart here and potential alignment/size issues for the common
+ header. See a-exexpr.adb. */
+
+typedef struct
+{
+ _Unwind_Exception common;
+ /* ABI header, maximally aligned. */
+} _GNAT_Exception;
+
+/* The two constants below are specific ttype identifiers for special
+ exception ids. Their type should match what a-exexpr exports. */
+
+extern const int __gnat_others_value;
+#define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value)
+
+extern const int __gnat_all_others_value;
+#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value)
+
+/* Describe the useful region data associated with an unwind context. */
+
+typedef struct
+{
+ /* The base pc of the region. */
+ _Unwind_Ptr base;
+
+ /* Pointer to the Language Specific Data for the region. */
+ _Unwind_Ptr lsda;
+
+ /* Call-Site data associated with this region. */
+ unsigned char call_site_encoding;
+ const unsigned char *call_site_table;
+
+ /* The base to which are relative landing pad offsets inside the call-site
+ entries . */
+ _Unwind_Ptr lp_base;
+
+ /* Action-Table associated with this region. */
+ const unsigned char *action_table;
+
+ /* Ttype data associated with this region. */
+ unsigned char ttype_encoding;
+ const unsigned char *ttype_table;
+ _Unwind_Ptr ttype_base;
+
+} region_descriptor;
+
+static void
+db_region_for (region_descriptor *region, _Unwind_Context *uw_context)
+{
+ _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
+
+ if (! (db_accepted_codes () & DB_REGIONS))
+ return;
+
+ db (DB_REGIONS, "For ip @ 0x%08x => ", ip);
+
+ if (region->lsda)
+ db (DB_REGIONS, "lsda @ 0x%x", region->lsda);
+ else
+ db (DB_REGIONS, "no lsda");
+
+ db (DB_REGIONS, "\n");
+}
+
+/* Retrieve the ttype entry associated with FILTER in the REGION's
+ ttype table. */
+
+static const _Unwind_Ptr
+get_ttype_entry_for (region_descriptor *region, long filter)
+{
+ _Unwind_Ptr ttype_entry;
+
+ filter *= size_of_encoded_value (region->ttype_encoding);
+ read_encoded_value_with_base
+ (region->ttype_encoding, region->ttype_base,
+ region->ttype_table - filter, &ttype_entry);
+
+ return ttype_entry;
+}
+
+/* Fill out the REGION descriptor for the provided UW_CONTEXT. */
+
+static void
+get_region_description_for (_Unwind_Context *uw_context,
+ region_descriptor *region)
+{
+ const unsigned char * p;
+ _Unwind_Word tmp;
+ unsigned char lpbase_encoding;
+
+ /* Get the base address of the lsda information. If the provided context
+ is null or if there is no associated language specific data, there's
+ nothing we can/should do. */
+ region->lsda
+ = (_Unwind_Ptr) (uw_context
+ ? _Unwind_GetLanguageSpecificData (uw_context) : 0);
+
+ if (! region->lsda)
+ return;
+
+ /* Parse the lsda and fill the region descriptor. */
+ p = (char *)region->lsda;
+
+ region->base = _Unwind_GetRegionStart (uw_context);
+
+ /* Find @LPStart, the base to which landing pad offsets are relative. */
+ lpbase_encoding = *p++;
+ if (lpbase_encoding != DW_EH_PE_omit)
+ p = read_encoded_value
+ (uw_context, lpbase_encoding, p, &region->lp_base);
+ else
+ region->lp_base = region->base;
+
+ /* Find @TType, the base of the handler and exception spec type data. */
+ region->ttype_encoding = *p++;
+ if (region->ttype_encoding != DW_EH_PE_omit)
+ {
+ p = read_uleb128 (p, &tmp);
+ region->ttype_table = p + tmp;
+ }
+ else
+ region->ttype_table = 0;
+
+ region->ttype_base
+ = base_of_encoded_value (region->ttype_encoding, uw_context);
+
+ /* Get the encoding and length of the call-site table; the action table
+ immediately follows. */
+ region->call_site_encoding = *p++;
+ region->call_site_table = read_uleb128 (p, &tmp);
+
+ region->action_table = region->call_site_table + tmp;
+}
+
+
+/* Describe an action to be taken when propagating an exception up to
+ some context. */
+
+typedef enum
+{
+ /* Found some call site base data, but need to analyze further
+ before being able to decide. */
+ unknown,
+
+ /* There is nothing relevant in the context at hand. */
+ nothing,
+
+ /* There are only cleanups to run in this context. */
+ cleanup,
+
+ /* There is a handler for the exception in this context. */
+ handler
+} action_kind;
+
+/* filter value for cleanup actions. */
+const int cleanup_filter = 0;
+
+typedef struct
+{
+ /* The kind of action to be taken. */
+ action_kind kind;
+
+ /* A pointer to the action record entry. */
+ const unsigned char *table_entry;
+
+ /* Where we should jump to actually take an action (trigger a cleanup or an
+ exception handler). */
+ _Unwind_Ptr landing_pad;
+
+ /* If we have a handler matching our exception, these are the filter to
+ trigger it and the corresponding id. */
+ _Unwind_Sword ttype_filter;
+ _Unwind_Ptr ttype_entry;
+
+} action_descriptor;
+
+static void
+db_action_for (action_descriptor *action, _Unwind_Context *uw_context)
+{
+ _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
+
+ db (DB_ACTIONS, "For ip @ 0x%08x => ", ip);
+
+ switch (action->kind)
+ {
+ case unknown:
+ db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n",
+ action->landing_pad, action->table_entry);
+ break;
+
+ case nothing:
+ db (DB_ACTIONS, "Nothing\n");
+ break;
+
+ case cleanup:
+ db (DB_ACTIONS, "Cleanup\n");
+ break;
+
+ case handler:
+ db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter);
+ break;
+
+ default:
+ db (DB_ACTIONS, "Err? Unexpected action kind !\n");
+ break;
+ }
+
+ return;
+}
+
+
+/* Search the call_site_table of REGION for an entry appropriate for the
+ UW_CONTEXT's ip. If one is found, store the associated landing_pad and
+ action_table entry, and set the ACTION kind to unknown for further
+ analysis. Otherwise, set the ACTION kind to nothing.
+
+ There are two variants of this routine, depending on the underlying
+ mechanism (dwarf/sjlj), which account for differences in the tables
+ organization.
+*/
+
+#ifdef __USING_SJLJ_EXCEPTIONS__
+
+#define __builtin_eh_return_data_regno(x) x
+
+static void
+get_call_site_action_for (_Unwind_Context *uw_context,
+ region_descriptor *region,
+ action_descriptor *action)
+{
+ _Unwind_Ptr call_site
+ = _Unwind_GetIP (uw_context) - 1;
+ /* Subtract 1 because GetIP returns the actual call_site value + 1. */
+
+ /* call_site is a direct index into the call-site table, with two special
+ values : -1 for no-action and 0 for "terminate". The latter should never
+ show up for Ada. To test for the former, beware that _Unwind_Ptr might be
+ unsigned. */
+
+ if ((int)call_site < 0)
+ {
+ action->kind = nothing;
+ return;
+ }
+ else if (call_site == 0)
+ {
+ db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n");
+ action->kind = nothing;
+ return;
+ }
+ else
+ {
+ _Unwind_Word cs_lp, cs_action;
+
+ /* Let the caller know there may be an action to take, but let it
+ determine the kind. */
+ action->kind = unknown;
+
+ /* We have a direct index into the call-site table, but this table is
+ made of leb128 values, the encoding length of which is variable. We
+ can't merely compute an offset from the index, then, but have to read
+ all the entries before the one of interest. */
+
+ const unsigned char * p = region->call_site_table;
+
+ do {
+ p = read_uleb128 (p, &cs_lp);
+ p = read_uleb128 (p, &cs_action);
+ } while (--call_site);
+
+
+ action->landing_pad = cs_lp + 1;
+
+ if (cs_action)
+ action->table_entry = region->action_table + cs_action - 1;
+ else
+ action->table_entry = 0;
+
+ return;
+ }
+}
+
+#else
+/* ! __USING_SJLJ_EXCEPTIONS__ */
+
+static void
+get_call_site_action_for (_Unwind_Context *uw_context,
+ region_descriptor *region,
+ action_descriptor *action)
+{
+ _Unwind_Ptr ip
+ = _Unwind_GetIP (uw_context) - 1;
+ /* Subtract 1 because GetIP yields a call return address while we are
+ interested in information for the call point. This does not always yield
+ the exact call instruction address but always brings the ip back within
+ the corresponding region.
+
+ ??? When unwinding up from a signal handler triggered by a trap on some
+ instruction, we usually have the faulting instruction address here and
+ subtracting 1 might get us into the wrong region. */
+
+ const unsigned char * p
+ = region->call_site_table;
+
+ /* Unless we are able to determine otherwise ... */
+ action->kind = nothing;
+
+ db (DB_CSITE, "\n");
+
+ while (p < region->action_table)
+ {
+ _Unwind_Ptr cs_start, cs_len, cs_lp;
+ _Unwind_Word cs_action;
+
+ /* Note that all call-site encodings are "absolute" displacements. */
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_start);
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_len);
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp);
+ p = read_uleb128 (p, &cs_action);
+
+ db (DB_CSITE,
+ "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n",
+ region->base+cs_start, cs_start, cs_len,
+ region->lp_base+cs_lp, cs_lp);
+
+ /* The table is sorted, so if we've passed the ip, stop. */
+ if (ip < region->base + cs_start)
+ break;
+
+ /* If we have a match, fill the ACTION fields accordingly. */
+ else if (ip < region->base + cs_start + cs_len)
+ {
+ /* Let the caller know there may be an action to take, but let it
+ determine the kind. */
+ action->kind = unknown;
+
+ if (cs_lp)
+ action->landing_pad = region->lp_base + cs_lp;
+ else
+ action->landing_pad = 0;
+
+ if (cs_action)
+ action->table_entry = region->action_table + cs_action - 1;
+ else
+ action->table_entry = 0;
+
+ db (DB_CSITE, "+++\n");
+ return;
+ }
+ }
+
+ db (DB_CSITE, "---\n");
+}
+
+#endif
+
+/* With CHOICE an exception choice representing an "exception - when"
+ argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated
+ occurrence, return true iif the latter matches the former, that is, if
+ PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE.
+ This takes care of the special Non_Ada_Error case on VMS. */
+
+#define Is_Handled_By_Others __gnat_is_handled_by_others
+#define Language_For __gnat_language_for
+#define Import_Code_For __gnat_import_code_for
+#define EID_For __gnat_eid_for
+#define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for
+
+extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
+extern char Language_For (_Unwind_Ptr eid);
+
+extern Exception_Code Import_Code_For (_Unwind_Ptr eid);
+
+extern Exception_Id EID_For (_GNAT_Exception * e);
+extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n);
+
+static int
+is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
+{
+ /* Pointer to the GNAT exception data corresponding to the propagated
+ occurrence. */
+ _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
+
+ /* Base matching rules: An exception data (id) matches itself, "when
+ all_others" matches anything and "when others" matches anything unless
+ explicitly stated otherwise in the propagated occurrence. */
+
+ bool is_handled =
+ choice == E
+ || choice == GNAT_ALL_OTHERS
+ || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
+
+ /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
+ may have different exception data pointers that should match for the
+ same condition code, if both an export and an import have been
+ registered. The import code for both the choice and the propagated
+ occurrence are expected to have been masked off regarding severity
+ bits already (at registration time for the former and from within the
+ low level exception vector for the latter). */
+#ifdef VMS
+ #define Non_Ada_Error system__aux_dec__non_ada_error
+ extern struct Exception_Data Non_Ada_Error;
+
+ is_handled |=
+ (Language_For (E) == 'V'
+ && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
+ && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
+ && Import_Code_For (choice) == Import_Code_For (E))
+ || choice == (_Unwind_Ptr)&Non_Ada_Error));
+#endif
+
+ return is_handled;
+}
+
+/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
+ UW_CONTEXT in REGION. */
+
+static void
+get_action_description_for (_Unwind_Context *uw_context,
+ _Unwind_Exception *uw_exception,
+ region_descriptor *region,
+ action_descriptor *action)
+{
+ _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
+
+ /* Search the call site table first, which may get us a landing pad as well
+ as the head of an action record list. */
+ get_call_site_action_for (uw_context, region, action);
+ db_action_for (action, uw_context);
+
+ /* If there is not even a call_site entry, we are done. */
+ if (action->kind == nothing)
+ return;
+
+ /* Otherwise, check what we have at the place of the call site. */
+
+ /* No landing pad => no cleanups or handlers. */
+ if (action->landing_pad == 0)
+ {
+ action->kind = nothing;
+ return;
+ }
+
+ /* Landing pad + null table entry => only cleanups. */
+ else if (action->table_entry == 0)
+ {
+ action->kind = cleanup;
+ action->ttype_filter = cleanup_filter;
+ /* The filter initialization is not strictly necessary, as cleanup-only
+ landing pads don't look at the filter value. It is there to ensure
+ we don't pass random values and so trigger potential confusion when
+ installing the context later on. */
+ return;
+ }
+
+ /* Landing pad + Table entry => handlers + possible cleanups. */
+ else
+ {
+ const unsigned char * p = action->table_entry;
+
+ _Unwind_Sword ar_filter, ar_disp;
+
+ action->kind = nothing;
+
+ while (1)
+ {
+ p = read_sleb128 (p, &ar_filter);
+ read_sleb128 (p, &ar_disp);
+ /* Don't assign p here, as it will be incremented by ar_disp
+ below. */
+
+ /* Null filters are for cleanups. */
+ if (ar_filter == cleanup_filter)
+ {
+ action->kind = cleanup;
+ action->ttype_filter = cleanup_filter;
+ /* The filter initialization is required here, to ensure
+ the target landing pad branches to the cleanup code if
+ we happen not to find a matching handler. */
+ }
+
+ /* Positive filters are for regular handlers. */
+ else if (ar_filter > 0)
+ {
+ /* See if the filter we have is for an exception which matches
+ the one we are propagating. */
+ _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter);
+
+ if (is_handled_by (choice, gnat_exception))
+ {
+ action->kind = handler;
+ action->ttype_filter = ar_filter;
+ action->ttype_entry = choice;
+ return;
+ }
+ }
+
+ /* Negative filter values are for C++ exception specifications.
+ Should not be there for Ada :/ */
+ else
+ db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n");
+
+ if (ar_disp == 0)
+ return;
+
+ p += ar_disp;
+ }
+ }
+}
+
+/* Setup in UW_CONTEXT the eh return target IP and data registers, which will
+ be restored with the others and retrieved by the landing pad once the jump
+ occurred. */
+
+static void
+setup_to_install (_Unwind_Context *uw_context,
+ _Unwind_Exception *uw_exception,
+ _Unwind_Ptr uw_landing_pad,
+ int uw_filter)
+{
+#ifndef EH_RETURN_DATA_REGNO
+ /* We should not be called if the appropriate underlying support is not
+ there. */
+ abort ();
+#else
+ /* 1/ exception object pointer, which might be provided back to
+ _Unwind_Resume (and thus to this personality routine) if we are jumping
+ to a cleanup. */
+ _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0),
+ (_Unwind_Word)uw_exception);
+
+ /* 2/ handler switch value register, which will also be used by the target
+ landing pad to decide what action it shall take. */
+ _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1),
+ (_Unwind_Word)uw_filter);
+
+ /* Setup the address we should jump at to reach the code where there is the
+ "something" we found. */
+ _Unwind_SetIP (uw_context, uw_landing_pad);
+#endif
+}
+
+/* The following is defined from a-except.adb. Its purpose is to enable
+ automatic backtraces upon exception raise, as provided through the
+ GNAT.Traceback facilities. */
+extern void __gnat_notify_handled_exception (void);
+extern void __gnat_notify_unhandled_exception (void);
+
+/* Below is the eh personality routine per se. We currently assume that only
+ GNU-Ada exceptions are met. */
+
+_Unwind_Reason_Code
+__gnat_eh_personality (int uw_version,
+ _Unwind_Action uw_phases,
+ _Unwind_Exception_Class uw_exception_class,
+ _Unwind_Exception *uw_exception,
+ _Unwind_Context *uw_context)
+{
+ _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
+
+ region_descriptor region;
+ action_descriptor action;
+
+ if (uw_version != 1)
+ return _URC_FATAL_PHASE1_ERROR;
+
+ db_indent (DB_INDENT_RESET);
+ db_phases (uw_phases);
+ db_indent (DB_INDENT_INCREASE);
+
+ /* Get the region description for the context we were provided with. This
+ will tell us if there is some lsda, call_site, action and/or ttype data
+ for the associated ip. */
+ get_region_description_for (uw_context, &region);
+ db_region_for (&region, uw_context);
+
+ /* No LSDA => no handlers or cleanups => we shall unwind further up. */
+ if (! region.lsda)
+ return _URC_CONTINUE_UNWIND;
+
+ /* Search the call-site and action-record tables for the action associated
+ with this IP. */
+ get_action_description_for (uw_context, uw_exception, &region, &action);
+ db_action_for (&action, uw_context);
+
+ /* Whatever the phase, if there is nothing relevant in this frame,
+ unwinding should just go on. */
+ if (action.kind == nothing)
+ return _URC_CONTINUE_UNWIND;
+
+ /* If we found something in search phase, we should return a code indicating
+ what to do next depending on what we found. If we only have cleanups
+ around, we shall try to unwind further up to find a handler, otherwise,
+ tell we have a handler, which will trigger the second phase. */
+ if (uw_phases & _UA_SEARCH_PHASE)
+ {
+ if (action.kind == cleanup)
+ {
+ Adjust_N_Cleanups_For (gnat_exception, 1);
+ return _URC_CONTINUE_UNWIND;
+ }
+ else
+ {
+ /* Trigger the appropriate notification routines before the second
+ phase starts, which ensures the stack is still intact. */
+ __gnat_notify_handled_exception ();
+
+ return _URC_HANDLER_FOUND;
+ }
+ }
+
+ /* We found something in cleanup/handler phase, which might be the handler
+ or a cleanup for a handled occurrence, or a cleanup for an unhandled
+ occurrence (we are in a FORCED_UNWIND phase in this case). Install the
+ context to get there. */
+
+ /* If we are going to install a cleanup context, decrement the cleanup
+ count. This is required in a FORCED_UNWINDing phase (for an unhandled
+ exception), as this is used from the forced unwinding handler in
+ Ada.Exceptions.Exception_Propagation to decide wether unwinding should
+ proceed further or Unhandled_Exception_Terminate should be called. */
+ if (action.kind == cleanup)
+ Adjust_N_Cleanups_For (gnat_exception, -1);
+
+ setup_to_install
+ (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
+
+ return _URC_INSTALL_CONTEXT;
+}
+
+/* Define the consistently named wrappers imported by Propagate_Exception. */
+
+#ifdef __USING_SJLJ_EXCEPTIONS__
+
+#undef _Unwind_RaiseException
+
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException (_Unwind_Exception *e)
+{
+ return _Unwind_SjLj_RaiseException (e);
+}
+
+
+#undef _Unwind_ForcedUnwind
+
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
+ void * handler,
+ void * argument)
+{
+ return _Unwind_SjLj_ForcedUnwind (e, handler, argument);
+}
+
+
+#else /* __USING_SJLJ_EXCEPTIONS__ */
+
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException (_Unwind_Exception *e)
+{
+ return _Unwind_RaiseException (e);
+}
+
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
+ void * handler,
+ void * argument)
+{
+ return _Unwind_ForcedUnwind (e, handler, argument);
+}
+
+#endif /* __USING_SJLJ_EXCEPTIONS__ */
+
+#else
+/* ! IN_RTS */
+
+/* Define the corresponding stubs for the compiler. */
+
+/* We don't want fancy_abort here. */
+#undef abort
+
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED)
+{
+ abort ();
+}
+
+
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED,
+ void * handler ATTRIBUTE_UNUSED,
+ void * argument ATTRIBUTE_UNUSED)
+{
+ abort ();
+}
+
+#endif /* IN_RTS */
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
index 48d94232a23..490c6b2ee7d 100644
--- a/gcc/ada/raise.c
+++ b/gcc/ada/raise.c
@@ -30,23 +30,15 @@
* *
****************************************************************************/
-/* Routines to support runtime exception handling */
+/* Shared routines to support exception handling.
+ Note that _gnat_builtin_longjmp should disappear at some point, replaced
+ by direct call to __builtin_longjmp from Ada code.
+ __gnat_unhandled_terminate is code shared between all exception handling
+ mechanisms */
#ifdef IN_RTS
#include "tconfig.h"
-/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2
- it does. To avoid branching raise.c just for that purpose, we kludge by
- looking for a symbol always defined by tm.h and if it's not defined,
- we include it. */
-#ifndef FIRST_PSEUDO_REGISTER
-#include "coretypes.h"
-#include "tm.h"
-#endif
#include "tsystem.h"
-#include <sys/stat.h>
-typedef char bool;
-# define true 1
-# define false 0
#else
#include "config.h"
#include "system.h"
@@ -72,1106 +64,16 @@ _gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED)
void
__gnat_unhandled_terminate (void)
{
- /* Special termination handling for VMS */
-
#ifdef VMS
- {
- long prvhnd;
-
- /* Remove the exception vector so it won't intercept any errors
- in the call to exit, and go into and endless loop */
-
- SYS$SETEXV (1, 0, 3, &prvhnd);
- __gnat_os_exit (1);
- }
-
-/* Termination handling for all other systems. */
-
-#elif !defined (__RT__)
- __gnat_os_exit (1);
-#endif
-}
-
-/* Below is the code related to the integration of the GCC mechanism for
- exception handling. */
-
-/* The names of a couple of "standard" routines for unwinding/propagation
- actually vary depending on the underlying GCC scheme for exception handling
- (SJLJ or DWARF). We need a consistently named interface to import from
- a-except, so wrappers are defined here.
-
- Besides, eventhough the compiler is never setup to use the GCC propagation
- circuitry, it still relies on exceptions internally and part of the sources
- to handle to exceptions are shared with the run-time library. We need
- dummy definitions for the wrappers to satisfy the linker in this case.
-
- The types to be used by those wrappers in the run-time library are target
- types exported by unwind.h. We used to piggyback on them for the compiler
- stubs, but there is no guarantee that unwind.h is always in sight so we
- define our own set below. These are dummy types as the wrappers are never
- called in the compiler case. */
-
-#ifdef IN_RTS
-
-#include "unwind.h"
-
-typedef struct _Unwind_Context _Unwind_Context;
-typedef struct _Unwind_Exception _Unwind_Exception;
-
-#else
-
-typedef void _Unwind_Context;
-typedef void _Unwind_Exception;
-typedef int _Unwind_Reason_Code;
-
-#endif
-
-_Unwind_Reason_Code
-__gnat_Unwind_RaiseException (_Unwind_Exception *);
-
-_Unwind_Reason_Code
-__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
-
-
-#ifdef IN_RTS /* For eh personality routine */
-
-#include "dwarf2.h"
-#include "unwind-dw2-fde.h"
-#include "unwind-pe.h"
-
-
-/* --------------------------------------------------------------
- -- The DB stuff below is there for debugging purposes only. --
- -------------------------------------------------------------- */
-
-#define DB_PHASES 0x1
-#define DB_CSITE 0x2
-#define DB_ACTIONS 0x4
-#define DB_REGIONS 0x8
-
-#define DB_ERR 0x1000
-
-/* The "action" stuff below is also there for debugging purposes only. */
-
-typedef struct
-{
- _Unwind_Action phase;
- char * description;
-} phase_descriptor;
-
-static phase_descriptor phase_descriptors[]
- = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" },
- { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" },
- { _UA_HANDLER_FRAME, "HANDLER_FRAME" },
- { _UA_FORCE_UNWIND, "FORCE_UNWIND" },
- { -1, 0}};
-
-static int
-db_accepted_codes (void)
-{
- static int accepted_codes = -1;
-
- if (accepted_codes == -1)
- {
- char * db_env = (char *) getenv ("EH_DEBUG");
-
- accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0;
- /* Arranged for ERR stuff to always be visible when the variable
- is defined. One may just set the variable to 0 to see the ERR
- stuff only. */
- }
-
- return accepted_codes;
-}
-
-#define DB_INDENT_INCREASE 0x01
-#define DB_INDENT_DECREASE 0x02
-#define DB_INDENT_OUTPUT 0x04
-#define DB_INDENT_NEWLINE 0x08
-#define DB_INDENT_RESET 0x10
-
-#define DB_INDENT_UNIT 8
-
-static void
-db_indent (int requests)
-{
- static int current_indentation_level = 0;
-
- if (requests & DB_INDENT_RESET)
- {
- current_indentation_level = 0;
- }
-
- if (requests & DB_INDENT_INCREASE)
- {
- current_indentation_level ++;
- }
-
- if (requests & DB_INDENT_DECREASE)
- {
- current_indentation_level --;
- }
-
- if (requests & DB_INDENT_NEWLINE)
- {
- fprintf (stderr, "\n");
- }
-
- if (requests & DB_INDENT_OUTPUT)
- {
- fprintf (stderr, "%*s",
- current_indentation_level * DB_INDENT_UNIT, " ");
- }
-
-}
-
-static void ATTRIBUTE_PRINTF_2
-db (int db_code, char * msg_format, ...)
-{
- if (db_accepted_codes () & db_code)
- {
- va_list msg_args;
-
- db_indent (DB_INDENT_OUTPUT);
-
- va_start (msg_args, msg_format);
- vfprintf (stderr, msg_format, msg_args);
- va_end (msg_args);
- }
-}
-
-static void
-db_phases (int phases)
-{
- phase_descriptor *a = phase_descriptors;
-
- if (! (db_accepted_codes() & DB_PHASES))
- return;
-
- db (DB_PHASES, "\n");
-
- for (; a->description != 0; a++)
- if (phases & a->phase)
- db (DB_PHASES, "%s ", a->description);
-
- db (DB_PHASES, " :\n");
-}
-
-
-/* ---------------------------------------------------------------
- -- Now come a set of useful structures and helper routines. --
- --------------------------------------------------------------- */
-
-/* There are three major runtime tables involved, generated by the
- GCC back-end. Contents slightly vary depending on the underlying
- implementation scheme (dwarf zero cost / sjlj).
-
- =======================================
- * Tables for the dwarf zero cost case *
- =======================================
-
- call_site []
- -------------------------------------------------------------------
- * region-start | region-length | landing-pad | first-action-index *
- -------------------------------------------------------------------
-
- Identify possible actions to be taken and where to resume control
- for that when an exception propagates through a pc inside the region
- delimited by start and length.
-
- A null landing-pad indicates that nothing is to be done.
-
- Otherwise, first-action-index provides an entry into the action[]
- table which heads a list of possible actions to be taken (see below).
-
- If it is determined that indeed an action should be taken, that
- is, if one action filter matches the exception being propagated,
- then control should be transfered to landing-pad.
-
- A null first-action-index indicates that there are only cleanups
- to run there.
-
- action []
- -------------------------------
- * action-filter | next-action *
- -------------------------------
-
- This table contains lists (called action chains) of possible actions
- associated with call-site entries described in the call-site [] table.
- There is at most one action list per call-site entry.
-
- A null action-filter indicates a cleanup.
-
- Non null action-filters provide an index into the ttypes [] table
- (see below), from which information may be retrieved to check if it
- matches the exception being propagated.
-
- action-filter > 0 means there is a regular handler to be run,
-
- action-filter < 0 means there is a some "exception_specification"
- data to retrieve, which is only relevant for C++
- and should never show up for Ada.
-
- next-action indexes the next entry in the list. 0 indicates there is
- no other entry.
-
- ttypes []
- ---------------
- * ttype-value *
- ---------------
-
- A null value indicates a catch-all handler in C++, and an "others"
- handler in Ada.
-
- Non null values are used to match the exception being propagated:
- In C++ this is a pointer to some rtti data, while in Ada this is an
- exception id.
-
- The special id value 1 indicates an "all_others" handler.
-
- For C++, this table is actually also used to store "exception
- specification" data. The differentiation between the two kinds
- of entries is made by the sign of the associated action filter,
- which translates into positive or negative offsets from the
- so called base of the table:
-
- Exception Specification data is stored at positive offsets from
- the ttypes table base, which Exception Type data is stored at
- negative offsets:
-
- ---------------------------------------------------------------------------
-
- Here is a quick summary of the tables organization:
-
- +-- Unwind_Context (pc, ...)
- |
- |(pc)
- |
- | CALL-SITE[]
- |
- | +=============================================================+
- | | region-start + length | landing-pad | first-action-index |
- | +=============================================================+
- +-> | pc range 0 => no-action 0 => cleanups only |
- | !0 => jump @ N --+ |
- +====================================================== | ====+
- |
- |
- ACTION [] |
- |
- +==========================================================+ |
- | action-filter | next-action | |
- +==========================================================+ |
- | 0 => cleanup | |
- | >0 => ttype index for handler ------+ 0 => end of chain | <-+
- | <0 => ttype index for spec data | |
- +==================================== | ===================+
- |
- |
- TTYPES [] |
- | Offset negated from
- +=====================+ | the actual base.
- | ttype-value | |
- +============+=====================+ |
- | | 0 => "others" | |
- | ... | 1 => "all others" | <---+
- | | X => exception id |
- | handlers +---------------------+
- | | ... |
- | ... | ... |
- | | ... |
- +============+=====================+ <<------ Table base
- | ... | ... |
- | specs | ... | (should not see negative filter
- | ... | ... | values for Ada).
- +============+=====================+
-
-
- ============================
- * Tables for the sjlj case *
- ============================
-
- So called "function contexts" are pushed on a context stack by calls to
- _Unwind_SjLj_Register on function entry, and popped off at exit points by
- calls to _Unwind_SjLj_Unregister. The current call_site for a function is
- updated in the function context as the function's code runs along.
-
- The generic unwinding engine in _Unwind_RaiseException walks the function
- context stack and not the actual call chain.
-
- The ACTION and TTYPES tables remain unchanged, which allows to search them
- during the propagation phase to determine wether or not the propagated
- exception is handled somewhere. When it is, we only "jump" up once directly
- to the context where the handler will be found. Besides, this allows "break
- exception unhandled" to work also
-
- The CALL-SITE table is setup differently, though: the pc attached to the
- unwind context is a direct index into the table, so the entries in this
- table do not hold region bounds any more.
-
- A special index (-1) is used to indicate that no action is possibly
- connected with the context at hand, so null landing pads cannot appear
- in the table.
-
- Additionally, landing pad values in the table do not represent code address
- to jump at, but so called "dispatch" indices used by a common landing pad
- for the function to switch to the appropriate post-landing-pad.
-
- +-- Unwind_Context (pc, ...)
- |
- | pc = call-site index
- | 0 => terminate (should not see this for Ada)
- | -1 => no-action
- |
- | CALL-SITE[]
- |
- | +=====================================+
- | | landing-pad | first-action-index |
- | +=====================================+
- +-> | 0 => cleanups only |
- | dispatch index N |
- +=====================================+
-
-
- ===================================
- * Basic organization of this unit *
- ===================================
-
- The major point of this unit is to provide an exception propagation
- personality routine for Ada. This is __gnat_eh_personality.
-
- It is provided with a pointer to the propagated exception, an unwind
- context describing a location the propagation is going through, and a
- couple of other arguments including a description of the current
- propagation phase.
-
- It shall return to the generic propagation engine what is to be performed
- next, after possible context adjustments, depending on what it finds in the
- traversed context (a handler for the exception, a cleanup, nothing, ...),
- and on the propagation phase.
-
- A number of structures and subroutines are used for this purpose, as
- sketched below:
-
- o region_descriptor: General data associated with the context (base pc,
- call-site table, action table, ttypes table, ...)
-
- o action_descriptor: Data describing the action to be taken for the
- propagated exception in the provided context (kind of action: nothing,
- handler, cleanup; pointer to the action table entry, ...).
-
- raise
- |
- ... (a-except.adb)
- |
- Propagate_Exception (a-exexpr.adb)
- |
- |
- _Unwind_RaiseException (libgcc)
- |
- | (Ada frame)
- |
- +--> __gnat_eh_personality (context, exception)
- |
- +--> get_region_descriptor_for (context)
- |
- +--> get_action_descriptor_for (context, exception, region)
- | |
- | +--> get_call_site_action_for (context, region)
- | (one version for each underlying scheme)
- |
- +--> setup_to_install (context)
-
- This unit is inspired from the C++ version found in eh_personality.cc,
- part of libstdc++-v3.
-
-*/
-
-
-/* This is an incomplete "proxy" of the structure of exception objects as
- built by the GNAT runtime library. Accesses to other fields than the common
- header are performed through subprogram calls to alleviate the need of an
- exact counterpart here and potential alignment/size issues for the common
- header. See a-exexpr.adb. */
-
-typedef struct
-{
- _Unwind_Exception common;
- /* ABI header, maximally aligned. */
-} _GNAT_Exception;
-
-/* The two constants below are specific ttype identifiers for special
- exception ids. Their type should match what a-exexpr exports. */
-
-extern const int __gnat_others_value;
-#define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value)
-
-extern const int __gnat_all_others_value;
-#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value)
-
-/* Describe the useful region data associated with an unwind context. */
-
-typedef struct
-{
- /* The base pc of the region. */
- _Unwind_Ptr base;
-
- /* Pointer to the Language Specific Data for the region. */
- _Unwind_Ptr lsda;
-
- /* Call-Site data associated with this region. */
- unsigned char call_site_encoding;
- const unsigned char *call_site_table;
-
- /* The base to which are relative landing pad offsets inside the call-site
- entries . */
- _Unwind_Ptr lp_base;
-
- /* Action-Table associated with this region. */
- const unsigned char *action_table;
-
- /* Ttype data associated with this region. */
- unsigned char ttype_encoding;
- const unsigned char *ttype_table;
- _Unwind_Ptr ttype_base;
-
-} region_descriptor;
-
-static void
-db_region_for (region_descriptor *region, _Unwind_Context *uw_context)
-{
- _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
-
- if (! (db_accepted_codes () & DB_REGIONS))
- return;
-
- db (DB_REGIONS, "For ip @ 0x%08x => ", ip);
-
- if (region->lsda)
- db (DB_REGIONS, "lsda @ 0x%x", region->lsda);
- else
- db (DB_REGIONS, "no lsda");
-
- db (DB_REGIONS, "\n");
-}
-
-/* Retrieve the ttype entry associated with FILTER in the REGION's
- ttype table. */
-
-static const _Unwind_Ptr
-get_ttype_entry_for (region_descriptor *region, long filter)
-{
- _Unwind_Ptr ttype_entry;
-
- filter *= size_of_encoded_value (region->ttype_encoding);
- read_encoded_value_with_base
- (region->ttype_encoding, region->ttype_base,
- region->ttype_table - filter, &ttype_entry);
-
- return ttype_entry;
-}
-
-/* Fill out the REGION descriptor for the provided UW_CONTEXT. */
-
-static void
-get_region_description_for (_Unwind_Context *uw_context,
- region_descriptor *region)
-{
- const unsigned char * p;
- _Unwind_Word tmp;
- unsigned char lpbase_encoding;
-
- /* Get the base address of the lsda information. If the provided context
- is null or if there is no associated language specific data, there's
- nothing we can/should do. */
- region->lsda
- = (_Unwind_Ptr) (uw_context
- ? _Unwind_GetLanguageSpecificData (uw_context) : 0);
-
- if (! region->lsda)
- return;
-
- /* Parse the lsda and fill the region descriptor. */
- p = (char *)region->lsda;
-
- region->base = _Unwind_GetRegionStart (uw_context);
-
- /* Find @LPStart, the base to which landing pad offsets are relative. */
- lpbase_encoding = *p++;
- if (lpbase_encoding != DW_EH_PE_omit)
- p = read_encoded_value
- (uw_context, lpbase_encoding, p, &region->lp_base);
- else
- region->lp_base = region->base;
-
- /* Find @TType, the base of the handler and exception spec type data. */
- region->ttype_encoding = *p++;
- if (region->ttype_encoding != DW_EH_PE_omit)
- {
- p = read_uleb128 (p, &tmp);
- region->ttype_table = p + tmp;
- }
- else
- region->ttype_table = 0;
-
- region->ttype_base
- = base_of_encoded_value (region->ttype_encoding, uw_context);
-
- /* Get the encoding and length of the call-site table; the action table
- immediately follows. */
- region->call_site_encoding = *p++;
- region->call_site_table = read_uleb128 (p, &tmp);
-
- region->action_table = region->call_site_table + tmp;
-}
-
-
-/* Describe an action to be taken when propagating an exception up to
- some context. */
-
-typedef enum
-{
- /* Found some call site base data, but need to analyze further
- before being able to decide. */
- unknown,
-
- /* There is nothing relevant in the context at hand. */
- nothing,
-
- /* There are only cleanups to run in this context. */
- cleanup,
-
- /* There is a handler for the exception in this context. */
- handler
-} action_kind;
-
-
-typedef struct
-{
- /* The kind of action to be taken. */
- action_kind kind;
-
- /* A pointer to the action record entry. */
- const unsigned char *table_entry;
-
- /* Where we should jump to actually take an action (trigger a cleanup or an
- exception handler). */
- _Unwind_Ptr landing_pad;
-
- /* If we have a handler matching our exception, these are the filter to
- trigger it and the corresponding id. */
- _Unwind_Sword ttype_filter;
- _Unwind_Ptr ttype_entry;
-
-} action_descriptor;
-
-
-static void
-db_action_for (action_descriptor *action, _Unwind_Context *uw_context)
-{
- _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
-
- db (DB_ACTIONS, "For ip @ 0x%08x => ", ip);
-
- switch (action->kind)
- {
- case unknown:
- db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n",
- action->landing_pad, action->table_entry);
- break;
-
- case nothing:
- db (DB_ACTIONS, "Nothing\n");
- break;
-
- case cleanup:
- db (DB_ACTIONS, "Cleanup\n");
- break;
-
- case handler:
- db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter);
- break;
-
- default:
- db (DB_ACTIONS, "Err? Unexpected action kind !\n");
- break;
- }
-
- return;
-}
-
-
-/* Search the call_site_table of REGION for an entry appropriate for the
- UW_CONTEXT's ip. If one is found, store the associated landing_pad and
- action_table entry, and set the ACTION kind to unknown for further
- analysis. Otherwise, set the ACTION kind to nothing.
-
- There are two variants of this routine, depending on the underlying
- mechanism (dwarf/sjlj), which account for differences in the tables
- organization.
-*/
-
-#ifdef __USING_SJLJ_EXCEPTIONS__
-
-#define __builtin_eh_return_data_regno(x) x
-
-static void
-get_call_site_action_for (_Unwind_Context *uw_context,
- region_descriptor *region,
- action_descriptor *action)
-{
- _Unwind_Ptr call_site
- = _Unwind_GetIP (uw_context) - 1;
- /* Subtract 1 because GetIP returns the actual call_site value + 1. */
-
- /* call_site is a direct index into the call-site table, with two special
- values : -1 for no-action and 0 for "terminate". The latter should never
- show up for Ada. To test for the former, beware that _Unwind_Ptr might be
- unsigned. */
-
- if ((int)call_site < 0)
- {
- action->kind = nothing;
- return;
- }
- else if (call_site == 0)
- {
- db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n");
- action->kind = nothing;
- return;
- }
- else
- {
- _Unwind_Word cs_lp, cs_action;
-
- /* Let the caller know there may be an action to take, but let it
- determine the kind. */
- action->kind = unknown;
-
- /* We have a direct index into the call-site table, but this table is
- made of leb128 values, the encoding length of which is variable. We
- can't merely compute an offset from the index, then, but have to read
- all the entries before the one of interest. */
-
- const unsigned char * p = region->call_site_table;
-
- do {
- p = read_uleb128 (p, &cs_lp);
- p = read_uleb128 (p, &cs_action);
- } while (--call_site);
-
-
- action->landing_pad = cs_lp + 1;
-
- if (cs_action)
- action->table_entry = region->action_table + cs_action - 1;
- else
- action->table_entry = 0;
-
- return;
- }
-}
-
-#else
-/* ! __USING_SJLJ_EXCEPTIONS__ */
-
-static void
-get_call_site_action_for (_Unwind_Context *uw_context,
- region_descriptor *region,
- action_descriptor *action)
-{
- _Unwind_Ptr ip
- = _Unwind_GetIP (uw_context) - 1;
- /* Subtract 1 because GetIP yields a call return address while we are
- interested in information for the call point. This does not always yield
- the exact call instruction address but always brings the ip back within
- the corresponding region.
-
- ??? When unwinding up from a signal handler triggered by a trap on some
- instruction, we usually have the faulting instruction address here and
- subtracting 1 might get us into the wrong region. */
-
- const unsigned char * p
- = region->call_site_table;
-
- /* Unless we are able to determine otherwise ... */
- action->kind = nothing;
-
- db (DB_CSITE, "\n");
-
- while (p < region->action_table)
- {
- _Unwind_Ptr cs_start, cs_len, cs_lp;
- _Unwind_Word cs_action;
-
- /* Note that all call-site encodings are "absolute" displacements. */
- p = read_encoded_value (0, region->call_site_encoding, p, &cs_start);
- p = read_encoded_value (0, region->call_site_encoding, p, &cs_len);
- p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp);
- p = read_uleb128 (p, &cs_action);
-
- db (DB_CSITE,
- "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n",
- region->base+cs_start, cs_start, cs_len,
- region->lp_base+cs_lp, cs_lp);
-
- /* The table is sorted, so if we've passed the ip, stop. */
- if (ip < region->base + cs_start)
- break;
-
- /* If we have a match, fill the ACTION fields accordingly. */
- else if (ip < region->base + cs_start + cs_len)
- {
- /* Let the caller know there may be an action to take, but let it
- determine the kind. */
- action->kind = unknown;
-
- if (cs_lp)
- action->landing_pad = region->lp_base + cs_lp;
- else
- action->landing_pad = 0;
-
- if (cs_action)
- action->table_entry = region->action_table + cs_action - 1;
- else
- action->table_entry = 0;
-
- db (DB_CSITE, "+++\n");
- return;
- }
- }
-
- db (DB_CSITE, "---\n");
-}
-
-#endif
-
-/* With CHOICE an exception choice representing an "exception - when"
- argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated
- occurrence, return true iif the latter matches the former, that is, if
- PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE.
- This takes care of the special Non_Ada_Error case on VMS. */
-
-#define Is_Handled_By_Others __gnat_is_handled_by_others
-#define Language_For __gnat_language_for
-#define Import_Code_For __gnat_import_code_for
-#define EID_For __gnat_eid_for
-#define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for
-
-extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
-extern char Language_For (_Unwind_Ptr eid);
-
-extern Exception_Code Import_Code_For (_Unwind_Ptr eid);
-
-extern Exception_Id EID_For (_GNAT_Exception * e);
-extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n);
-
-static int
-is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
-{
- /* Pointer to the GNAT exception data corresponding to the propagated
- occurrence. */
- _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
-
- /* Base matching rules: An exception data (id) matches itself, "when
- all_others" matches anything and "when others" matches anything unless
- explicitly stated otherwise in the propagated occurrence. */
-
- bool is_handled =
- choice == E
- || choice == GNAT_ALL_OTHERS
- || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
-
- /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
- may have different exception data pointers that should match for the
- same condition code, if both an export and an import have been
- registered. The import code for both the choice and the propagated
- occurrence are expected to have been masked off regarding severity
- bits already (at registration time for the former and from within the
- low level exception vector for the latter). */
-#ifdef VMS
- #define Non_Ada_Error system__aux_dec__non_ada_error
- extern struct Exception_Data Non_Ada_Error;
-
- is_handled |=
- (Language_For (E) == 'V'
- && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
- && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
- && Import_Code_For (choice) == Import_Code_For (E))
- || choice == (_Unwind_Ptr)&Non_Ada_Error));
-#endif
-
- return is_handled;
-}
-
-/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
- UW_CONTEXT in REGION. */
-
-static void
-get_action_description_for (_Unwind_Context *uw_context,
- _Unwind_Exception *uw_exception,
- region_descriptor *region,
- action_descriptor *action)
-{
- _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
-
- /* Search the call site table first, which may get us a landing pad as well
- as the head of an action record list. */
- get_call_site_action_for (uw_context, region, action);
- db_action_for (action, uw_context);
-
- /* If there is not even a call_site entry, we are done. */
- if (action->kind == nothing)
- return;
-
- /* Otherwise, check what we have at the place of the call site */
-
- /* No landing pad => no cleanups or handlers. */
- if (action->landing_pad == 0)
- {
- action->kind = nothing;
- return;
- }
-
- /* Landing pad + null table entry => only cleanups. */
- else if (action->table_entry == 0)
- {
- action->kind = cleanup;
- return;
- }
-
- /* Landing pad + Table entry => handlers + possible cleanups. */
- else
- {
- const unsigned char * p = action->table_entry;
-
- _Unwind_Sword ar_filter, ar_disp;
-
- action->kind = nothing;
-
- while (1)
- {
- p = read_sleb128 (p, &ar_filter);
- read_sleb128 (p, &ar_disp);
- /* Don't assign p here, as it will be incremented by ar_disp
- below. */
-
- /* Null filters are for cleanups. */
- if (ar_filter == 0)
- action->kind = cleanup;
-
- /* Positive filters are for regular handlers. */
- else if (ar_filter > 0)
- {
- /* See if the filter we have is for an exception which matches
- the one we are propagating. */
- _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter);
-
- if (is_handled_by (choice, gnat_exception))
- {
- action->ttype_filter = ar_filter;
- action->ttype_entry = choice;
- action->kind = handler;
- return;
- }
- }
-
- /* Negative filter values are for C++ exception specifications.
- Should not be there for Ada :/ */
- else
- db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n");
-
- if (ar_disp == 0)
- return;
-
- p += ar_disp;
- }
- }
-}
-
-/* Setup in UW_CONTEXT the eh return target IP and data registers, which will
- be restored with the others and retrieved by the landing pad once the jump
- occurred. */
-
-static void
-setup_to_install (_Unwind_Context *uw_context,
- _Unwind_Exception *uw_exception,
- _Unwind_Ptr uw_landing_pad,
- int uw_filter)
-{
-#ifndef EH_RETURN_DATA_REGNO
- /* We should not be called if the appropriate underlying support is not
- there. */
- abort ();
-#else
- /* 1/ exception object pointer, which might be provided back to
- _Unwind_Resume (and thus to this personality routine) if we are jumping
- to a cleanup. */
- _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0),
- (_Unwind_Word)uw_exception);
+ /* Special termination handling for VMS */
+ long prvhnd;
- /* 2/ handler switch value register, which will also be used by the target
- landing pad to decide what action it shall take. */
- _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1),
- (_Unwind_Word)uw_filter);
+ /* Remove the exception vector so it won't intercept any errors
+ in the call to exit, and go into and endless loop */
- /* Setup the address we should jump at to reach the code where there is the
- "something" we found. */
- _Unwind_SetIP (uw_context, uw_landing_pad);
+ SYS$SETEXV (1, 0, 3, &prvhnd);
#endif
-}
-
-/* The following is defined from a-except.adb. Its purpose is to enable
- automatic backtraces upon exception raise, as provided through the
- GNAT.Traceback facilities. */
-extern void __gnat_notify_handled_exception (void);
-extern void __gnat_notify_unhandled_exception (void);
-
-/* Below is the eh personality routine per se. We currently assume that only
- GNU-Ada exceptions are met. */
-
-_Unwind_Reason_Code
-__gnat_eh_personality (int uw_version,
- _Unwind_Action uw_phases,
- _Unwind_Exception_Class uw_exception_class,
- _Unwind_Exception *uw_exception,
- _Unwind_Context *uw_context)
-{
- _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
-
- region_descriptor region;
- action_descriptor action;
-
- if (uw_version != 1)
- return _URC_FATAL_PHASE1_ERROR;
-
- db_indent (DB_INDENT_RESET);
- db_phases (uw_phases);
- db_indent (DB_INDENT_INCREASE);
-
- /* Get the region description for the context we were provided with. This
- will tell us if there is some lsda, call_site, action and/or ttype data
- for the associated ip. */
- get_region_description_for (uw_context, &region);
- db_region_for (&region, uw_context);
-
- /* No LSDA => no handlers or cleanups => we shall unwind further up. */
- if (! region.lsda)
- return _URC_CONTINUE_UNWIND;
-
- /* Search the call-site and action-record tables for the action associated
- with this IP. */
- get_action_description_for (uw_context, uw_exception, &region, &action);
- db_action_for (&action, uw_context);
-
- /* Whatever the phase, if there is nothing relevant in this frame,
- unwinding should just go on. */
- if (action.kind == nothing)
- return _URC_CONTINUE_UNWIND;
- /* If we found something in search phase, we should return a code indicating
- what to do next depending on what we found. If we only have cleanups
- around, we shall try to unwind further up to find a handler, otherwise,
- tell we have a handler, which will trigger the second phase. */
- if (uw_phases & _UA_SEARCH_PHASE)
- {
- if (action.kind == cleanup)
- {
- Adjust_N_Cleanups_For (gnat_exception, 1);
- return _URC_CONTINUE_UNWIND;
- }
- else
- {
- /* Trigger the appropriate notification routines before the second
- phase starts, which ensures the stack is still intact. */
- __gnat_notify_handled_exception ();
-
- return _URC_HANDLER_FOUND;
- }
- }
-
- /* We found something in cleanup/handler phase, which might be the handler
- or a cleanup for a handled occurrence, or a cleanup for an unhandled
- occurrence (we are in a FORCED_UNWIND phase in this case). Install the
- context to get there. */
-
- /* If we are going to install a cleanup context, decrement the cleanup
- count. This is required in a FORCED_UNWINDing phase (for an unhandled
- exception), as this is used from the forced unwinding handler in
- Ada.Exceptions.Exception_Propagation to decide wether unwinding should
- proceed further or Unhandled_Exception_Terminate should be called. */
- if (action.kind == cleanup)
- Adjust_N_Cleanups_For (gnat_exception, -1);
-
- setup_to_install
- (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
-
- return _URC_INSTALL_CONTEXT;
+ /* Default termination handling */
+ __gnat_os_exit (1);
}
-
-/* Define the consistently named wrappers imported by Propagate_Exception. */
-
-#ifdef __USING_SJLJ_EXCEPTIONS__
-
-#undef _Unwind_RaiseException
-
-_Unwind_Reason_Code
-__gnat_Unwind_RaiseException (_Unwind_Exception *e)
-{
- return _Unwind_SjLj_RaiseException (e);
-}
-
-
-#undef _Unwind_ForcedUnwind
-
-_Unwind_Reason_Code
-__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
- void * handler,
- void * argument)
-{
- return _Unwind_SjLj_ForcedUnwind (e, handler, argument);
-}
-
-
-#else /* __USING_SJLJ_EXCEPTIONS__ */
-
-_Unwind_Reason_Code
-__gnat_Unwind_RaiseException (_Unwind_Exception *e)
-{
- return _Unwind_RaiseException (e);
-}
-
-_Unwind_Reason_Code
-__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
- void * handler,
- void * argument)
-{
- return _Unwind_ForcedUnwind (e, handler, argument);
-}
-
-#endif /* __USING_SJLJ_EXCEPTIONS__ */
-
-#else
-/* ! IN_RTS */
-
-/* Define the corresponding stubs for the compiler. */
-
-/* We don't want fancy_abort here. */
-#undef abort
-
-_Unwind_Reason_Code
-__gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED)
-{
- abort ();
-}
-
-
-_Unwind_Reason_Code
-__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED,
- void * handler ATTRIBUTE_UNUSED,
- void * argument ATTRIBUTE_UNUSED)
-{
- abort ();
-}
-
-#endif /* IN_RTS */
View Lorry Controller Status