Patchwork [Ada] Allow foreign exceptions

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 11:06 a.m.
Message ID <20110829110616.GA29274@adacore.com>
Download mbox | patch
Permalink /patch/112025/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 11:06 a.m.
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  <gingold@adacore.com>

	* 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.

Patch

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;
 }