From: Arnaud Charlet Date: Tue, 15 Nov 2005 13:52:55 +0000 (+0100) Subject: a-except.adb (Zero_Cost_Exceptions): Removed, no longer used. X-Git-Tag: releases/gcc-4.1.0~843 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=982f26e474453b112f6516208db854f287ace66d;p=thirdparty%2Fgcc.git a-except.adb (Zero_Cost_Exceptions): Removed, no longer used. * 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 From-SVN: r106959 --- diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index f13fed7fb762..0dfe8ae18165 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -348,6 +348,11 @@ s-osprim.adb 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 a676b91c2ed7..fb14eda5b087 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; @@ -1262,19 +1193,6 @@ package body Ada.Exceptions is return Target; 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 000000000000..22f057d18a4e --- /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 8cccf1699e9f..165b5cef3d81 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 000000000000..0f9b94c7cd93 --- /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 +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, ®ion->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, ®ion); + db_region_for (®ion, 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, ®ion, &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 48d94232a232..490c6b2ee7d3 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 -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, ®ion->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, ®ion); - db_region_for (®ion, 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, ®ion, &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 */