From patchwork Mon Aug 29 11:06:16 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112025 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id BF6B4B6F8F for ; Mon, 29 Aug 2011 21:06:46 +1000 (EST) Received: (qmail 23439 invoked by alias); 29 Aug 2011 11:06:43 -0000 Received: (qmail 23427 invoked by uid 22791); 29 Aug 2011 11:06:37 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 29 Aug 2011 11:06:18 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 520DB2BB0EA; Mon, 29 Aug 2011 07:06:17 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id VhNGof5+DUxL; Mon, 29 Aug 2011 07:06:17 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id D338F2BB0E1; Mon, 29 Aug 2011 07:06:16 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id D11DD3FEE8; Mon, 29 Aug 2011 07:06:16 -0400 (EDT) Date: Mon, 29 Aug 2011 07:06:16 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Tristan Gingold Subject: [Ada] Allow foreign exceptions Message-ID: <20110829110616.GA29274@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org With this new feature, foreign exceptions can be caught in 'when others' handlers and will correctly propagate through Ada frames (including at-end handlers). No pure Ada test. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-29 Tristan Gingold * a-exexpr-gcc.adb (Unwind_Exception): Remove default value, made it convention C. (GCC_Exception_Access): New type. (Unwind_DeleteException): New imported procedure (Foreign_Exception): Import it. (GNAT_GCC_Exception): Simply have the occurrence inside. (To_GCC_Exception): New function. (To_GNAT_GCC_Exception): New function. (GNAT_GCC_Exception_Cleanup): New procedure.. (Propagate_GCC_Exception): New procedure. (Reraise_GCC_Exception): New procedure. (Setup_Current_Excep): New procedure. (CleanupUnwind_Handler): Change type of UW_Exception parameter. (Unwind_RaiseException): Ditto. (Unwind_ForcedUnwind): Ditto. (Remove): Removed. (Begin_Handler): Change type of parameter. (End_Handler): Ditto. Now delete the exception if still present. (Setup_Key): Removed. (Is_Setup_And_Not_Propagated): Removed. (Set_Setup_And_Not_Propagated): Ditto. (Clear_Setup_And_Not_Propagated): Ditto. (Save_Occurrence_And_Private): Ditto. (EID_For): Add 'not null' constraint on parameter. (Setup_Exception): Does nothing. (Propagate_Exception): Simplified. * exp_ch11.adb (Expand_N_Raise_Statement): In back-end exception model, re-raise is not expanded anymore. * s-except.ads (Foreign_Exception): New exception - placeholder for non Ada exceptions. * raise-gcc.c (__gnat_setup_current_excep): Declare (CXX_EXCEPTION_CLASS): Define (not yet used) (GNAT_EXCEPTION_CLASS): Define. (is_handled_by): Handle foreign exceptions. (PERSONALITY_FUNCTION): Call __gnat_setup_current_excep. Index: a-exexpr-gcc.adb =================================================================== --- a-exexpr-gcc.adb (revision 178192) +++ a-exexpr-gcc.adb (working copy) @@ -104,11 +104,12 @@ -- 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; + Class : Exception_Class; + Cleanup : System.Address; Private1 : Unwind_Word; Private2 : Unwind_Word; end record; + pragma Convention (C, Unwind_Exception); -- Map the GCC struct used for exception handling for Unwind_Exception'Alignment use Standard'Maximum_Alignment; @@ -117,6 +118,19 @@ -- maximally aligned (see unwind.h). See additional comments on the -- alignment below. + type GCC_Exception_Access is access all Unwind_Exception; + pragma Convention (C, GCC_Exception_Access); + -- Pointer to a GCC exception + + procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); + pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); + -- Procedure to free any GCC exception + + Foreign_Exception : aliased System.Standard_Library.Exception_Data; + pragma Import (Ada, Foreign_Exception, + "system__exceptions__foreign_exception"); + -- Id for foreign exceptions + -------------------------------------------------------------- -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- -------------------------------------------------------------- @@ -128,13 +142,8 @@ 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 being propagated. - - Next_Exception : EOA; - -- Used to create a linked list of exception occurrences + Occurrence : Exception_Occurrence; + -- The Ada occurrence end record; pragma Convention (C, GNAT_GCC_Exception); @@ -158,20 +167,40 @@ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + function To_GCC_Exception is new + Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access); + function To_GNAT_GCC_Exception is new - Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access); + Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access); - procedure Free is new Unchecked_Deallocation - (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access); + pragma Convention (C, GNAT_GCC_Exception_Cleanup); + -- Procedure called when a GNAT GCC exception is free. - procedure Free is new Unchecked_Deallocation - (Exception_Occurrence, EOA); + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Propagate_GCC_Exception); + -- Propagate a GCC exception + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Reraise_GCC_Exception); + pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); + -- Called to implement raise without exception, ie reraise. Called + -- directly from gigi. + + procedure Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access); + pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); + -- Write Get_Current_Excep.all from GCC_Exception + function CleanupUnwind_Handler (UW_Version : Integer; UW_Phases : Unwind_Action; UW_Eclass : Exception_Class; - UW_Exception : not null access GNAT_GCC_Exception; + UW_Exception : not null GCC_Exception_Access; UW_Context : System.Address; UW_Argument : System.Address) return Unwind_Reason_Code; -- Hook called at each step of the forced unwinding we perform to @@ -183,57 +212,25 @@ -- __gnat stubs for these. procedure Unwind_RaiseException - (UW_Exception : not null access GNAT_GCC_Exception); + (UW_Exception : not null GCC_Exception_Access); pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); procedure Unwind_ForcedUnwind - (UW_Exception : not null access GNAT_GCC_Exception; + (UW_Exception : not null GCC_Exception_Access; 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); + procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); pragma Export (C, Begin_Handler, "__gnat_begin_handler"); - procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + procedure End_Handler (GCC_Exception : 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 Pointer -- -------------------------------------------------------------------- @@ -254,7 +251,7 @@ 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) + function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id; pragma Export (C, EID_For, "__gnat_eid_for"); @@ -274,65 +271,25 @@ All_Others_Value : constant Integer := 16#7FFF#; pragma Export (C, All_Others_Value, "__gnat_all_others_value"); - ------------ - -- Remove -- - ------------ + -------------------------------- + -- GNAT_GCC_Exception_Cleanup -- + -------------------------------- - 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; + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access) is + pragma Unreferenced (Reason); + procedure Free is new Unchecked_Deallocation + (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + + Copy : GNAT_GCC_Exception_Access := Excep; begin - -- Pop stack + -- Simply free the memory - loop - pragma Assert (Iter.Private_Data /= System.Null_Address); + Free (Copy); + end GNAT_GCC_Exception_Cleanup; - 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 -- --------------------------- @@ -341,17 +298,16 @@ (UW_Version : Integer; UW_Phases : Unwind_Action; UW_Eclass : Exception_Class; - UW_Exception : not null access GNAT_GCC_Exception; + UW_Exception : not null GCC_Exception_Access; UW_Context : System.Address; UW_Argument : System.Address) return Unwind_Reason_Code is - pragma Unreferenced - (UW_Version, UW_Eclass, UW_Exception, UW_Context, UW_Argument); - + pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument); begin -- Terminate when the end of the stack is reached if UW_Phases >= UA_END_OF_STACK then + Setup_Current_Excep (UW_Exception); Unhandled_Exception_Terminate; end if; @@ -362,54 +318,6 @@ 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 -- --------------------- @@ -423,80 +331,56 @@ Current : EOA; Reraised : Boolean := False) is - Top : constant EOA := Current; - Next : EOA; - GCC_Exception : GNAT_GCC_Exception_Access; - + pragma Unreferenced (Excep, Current, Reraised); 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. + -- In the GNAT-SJLJ case this "stack" only exists implicitly, by way of + -- local occurrence declarations together with save/restore operations + -- generated by the front-end, and this routine has nothing to do. - -- What we do here is to trigger this push when need be, and allocate a - -- Private_Data block for the forthcoming Propagation. + null; + end Setup_Exception; - -- 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. + ------------------------- + -- Setup_Current_Excep -- + ------------------------- - -- 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. + procedure Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) is + Excep : constant EOA := Get_Current_Excep.all; + begin + -- Setup the exception occurrence - if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then - return; - end if; + if GCC_Exception.Class = GNAT_Exception_Class then - -- Allocate what will be the Private_Data block for the exception - -- to be propagated. + -- From the GCC exception - GCC_Exception := new GNAT_GCC_Exception; + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Excep.all := GNAT_Occurrence.Occurrence; + end; + else - -- 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. + -- A default one - -- 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; + Excep.Id := Foreign_Exception'Access; + Excep.Msg_Length := 0; + Excep.Cleanup_Flag := False; + Excep.Exception_Raised := True; + Excep.Pid := Local_Partition_ID; + Excep.Num_Tracebacks := 0; + Excep.Private_Data := System.Null_Address; end if; + end Setup_Current_Excep; - 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 + procedure Begin_Handler (GCC_Exception : not null 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; @@ -504,13 +388,68 @@ -- End_Handler -- ----------------- - procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is - Removed : Boolean; + procedure End_Handler (GCC_Exception : GCC_Exception_Access) is begin - Removed := Remove (Get_Current_Excep.all, GCC_Exception); - pragma Assert (Removed); + if GCC_Exception /= null then + + -- The exception might have been reraised, in this case the cleanup + -- mustn't be called. + + Unwind_DeleteException (GCC_Exception); + end if; end End_Handler; + ----------------------------- + -- Reraise_GCC_Exception -- + ----------------------------- + + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) is + begin + -- Simply propagate it + Propagate_GCC_Exception (GCC_Exception); + end Reraise_GCC_Exception; + + ----------------------------- + -- Propagate_GCC_Exception -- + ----------------------------- + + -- Call Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) is + begin + -- 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, it will return. + + 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. + + Setup_Current_Excep (GCC_Exception); + Notify_Unhandled_Exception; + + -- Now, un a forced unwind to trigger cleanups. Control should not + -- resume there, if there are cleanups and in any cases as the + -- unwinding hook calls Unhandled_Exception_Terminate when end of stack + -- is reached. + + Unwind_ForcedUnwind (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); + + -- We get here in case of error. + -- The debugger has been notified before the second step above. + + Setup_Current_Excep (GCC_Exception); + Unhandled_Exception_Terminate; + end Propagate_GCC_Exception; + ------------------------- -- Propagate_Exception -- ------------------------- @@ -530,18 +469,6 @@ 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; - -- Compute the backtrace for this occurrence if the corresponding -- binder option has been set. Call_Chain takes care of the reraise -- case. @@ -565,32 +492,17 @@ 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, it will return. + -- Allocate the GCC exception - Unwind_RaiseException (GCC_Exception); + GCC_Exception := new GNAT_GCC_Exception' + (Header => (Class => GNAT_Exception_Class, + Cleanup => GNAT_GCC_Exception_Cleanup'Address, + Private1 => 0, + Private2 => 0), + Occurrence => Excep.all); - -- 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, un a forced unwind to trigger cleanups. Control should not - -- resume there, if there are cleanups and in any cases as the - -- unwinding hook calls Unhandled_Exception_Terminate when end of stack - -- is reached. - - Unwind_ForcedUnwind (GCC_Exception, - CleanupUnwind_Handler'Address, - System.Null_Address); - - -- We get here in case of error. - -- The debugger has been notified before the second step above. - - Unhandled_Exception_Terminate; + -- Propagate it. + Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception)); end Propagate_Exception; ------------- @@ -598,10 +510,10 @@ ------------- function EID_For - (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id + (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id is begin - return GNAT_Exception.Id; + return GNAT_Exception.Occurrence.Id; end EID_For; --------------------- @@ -633,67 +545,4 @@ 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 proved 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 occurrence - -- 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 being simple, and induces - -- extra costs only in reraise cases which is acceptable. - end Exception_Propagation; Index: exp_ch11.adb =================================================================== --- exp_ch11.adb (revision 178195) +++ exp_ch11.adb (working copy) @@ -1665,6 +1665,15 @@ -- does not have a choice parameter specification, then we provide one. else + + -- Don't expand if back end exception handling active + + if VM_Target = No_VM + and then Exception_Mechanism = Back_End_Exceptions + then + return; + end if; + -- Find innermost enclosing exception handler (there must be one, -- since the semantics has already verified that this raise statement -- is valid, and a raise with no arguments is only permitted in the Index: s-except.ads =================================================================== --- s-except.ads (revision 178194) +++ s-except.ads (working copy) @@ -81,4 +81,9 @@ private ZCX_By_Default : constant Boolean := System.ZCX_By_Default; + Foreign_Exception : exception; + pragma Unreferenced (Foreign_Exception); + -- This hidden exception is used to represent non-Ada exception to + -- Ada handlers. It is in fact referenced by its linking name. + end System.Exceptions; Index: raise-gcc.c =================================================================== --- raise-gcc.c (revision 178188) +++ raise-gcc.c (working copy) @@ -101,6 +101,7 @@ _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); +extern void __gnat_setup_current_excep (_Unwind_Exception *); #ifdef IN_RTS /* For eh personality routine */ @@ -108,7 +109,11 @@ #include "unwind-dw2-fde.h" #include "unwind-pe.h" +/* The known and handled exception classes. */ +#define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL +#define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL + /* -------------------------------------------------------------- -- The DB stuff below is there for debugging purposes only. -- -------------------------------------------------------------- */ @@ -853,39 +858,51 @@ 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); + if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS) + { + /* 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. */ + /* 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)); + 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). */ + /* 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; +# 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)); + 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; + return is_handled; + } + else + { +# define Foreign_Exception system__exceptions__foreign_exception; + extern struct Exception_Data Foreign_Exception; + + return choice == GNAT_ALL_OTHERS + || choice == GNAT_OTHERS + || choice == (_Unwind_Ptr)&Foreign_Exception; + } } /* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to @@ -1079,9 +1096,6 @@ Condition Handling Facility. */ int uw_version = (int) version_arg; _Unwind_Action uw_phases = (_Unwind_Action) phases_arg; - - _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; - region_descriptor region; action_descriptor action; @@ -1089,7 +1103,7 @@ possible variation on VMS for IA64. */ if (uw_version != 1) { - #if defined (VMS) && defined (__IA64) +#if defined (VMS) && defined (__IA64) /* Assume we're called with sigargs/mechargs arguments if really unexpected bits are set in our first two formals. Redirect to the @@ -1103,7 +1117,7 @@ if ((unsigned int)uw_version & version_unexpected_bits_mask && (unsigned int)uw_phases & phases_unexpected_bits_mask) return __gnat_handle_vms_condition (version_arg, phases_arg); - #endif +#endif return _URC_FATAL_PHASE1_ERROR; } @@ -1160,6 +1174,9 @@ setup_to_install (uw_context, uw_exception, action.landing_pad, action.ttype_filter); + /* Write current exception, so that it can be retrieved from Ada. */ + __gnat_setup_current_excep (uw_exception); + return _URC_INSTALL_CONTEXT; }