[Ada] Improve last exception info availability from C++ handlers

[Pierre-Marie de Rodat <derodat at adacore dot com>]

The Most_Recent_Exception service failed to provide accurate information on an
Ada exception caught by a C++ handler for foreign exceptions. The service
relies on updates of a "current exception buffer" from live exception objects
at various points of the propagation process and this update was not performed
early enough for the case of foreign exception handlers in non-Ada handlers.

The correction applied here consists in moving one of the updates earlier in
the raise process, just before unwinding starts, then refine the update API to
prevent a redundant copy during the unwinding search phase for the same
exception.

The example below, compiled with

gcc -c b.cc
gnatmake -g main.adb -largs b.o --LINK=g++

is expected to run and display

ada info:
Checking Most_Recent_Exception for CONSTRAINT_ERROR ... OK!

// b.cc

extern "C" {
 void foo ();
 extern void _ada_trigger ();
 extern void _ada_occurrence_info ();
}

void foo ()
{
 try {
   _ada_trigger ();
 } catch (const abi::__foreign_exception &e) {
   printf ("ada info:\n");
   _ada_occurrence_info();
 }
}

-- main.adb

with EH;
procedure Main is
begin
  EH.Foo;
end;

-- eh.adb

with Gnat.Most_Recent_Exception;
with Ada.Text_IO; use Ada.Text_IO;

package body EH is

  procedure Ada_Trigger is
  begin
     raise Constraint_Error;
  end;

  procedure Ada_Occurrence_Info is
  begin
     Check_MRE ("CONSTRAINT_ERROR");
  end;

  function Pre_Check_MRE (Ename : String) return Exception_Id is
     MROA : Exception_Occurrence_Access :=
       GNAT.Most_Recent_Exception.Occurrence_Access;
  begin
     Put ("Checking Most_Recent_Exception for " & Ename & " ... ");

     if MROA = null then
        Put_Line ("Most recent exception occurrence access is NULL");
        return Null_Id;
     else
        return Exception_Identity (MROA.all);
     end if;
  end;

  procedure Diagnose_MRE (MRID : Exception_Id; Ok : Boolean) is
  begin
     if Ok then
        Put_Line ("OK!");
     else
        Put_Line ("Err, Most_Recent_Exception was " & Exception_Name (MRID));
     end if;
  end;

  procedure Check_MRE (Eid : Exception_Id) is
     MRID : Exception_Id := Pre_Check_MRE (Ename => Exception_Name (Eid));
  begin
     Diagnose_MRE (MRID, Ok => Eid = MRID);
  end;

  procedure Check_MRE (Ename : String) is
     MRID : Exception_Id := Pre_Check_MRE (Ename => Ename);
  begin
     Diagnose_MRE (MRID, Ok => Ename = Exception_Name (MRID));
  end;

end;

-- eh.ads

with Ada.Exceptions; use Ada.Exceptions;
package EH is
  procedure Ada_Trigger with
    Export, Convention => C, External_Name => "_ada_trigger";

  procedure Ada_Occurrence_Info with
    Export, Convention => C, External_Name => "_ada_occurrence_info";

  procedure Foo with Import, Convention => C, External_Name => "foo";

  procedure Check_MRE (Eid : Exception_Id);
  procedure Check_MRE (Ename : String);

end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-06-11  Olivier Hainque  <hainque@adacore.com>

gcc/ada/

	* libgnat/s-excmac*.ads: Factorize Unwind_Action definitions ...
	* libgnat/a-exexpr.adb: ... Here, then add comments describing the
	major datastructures associated with the current exception raised.
	(Setup_Current_Excep): Accept a "Phase" argument conveying the
	unwinding phase during which this subprogram is called.  For an Ada
	exception, don't update the current exception buffer from the raised
	exception object during SEARCH_PHASE, as this is redundant with the
	call now issued just before propagation starts.
	(Propagate_GCC_Exception): Move call to Setup_Current_Excep ahead of
	the unwinding start, conveying Phase 0.
	(Unhandled_Except_Handler): Pass UA_CLEANUP_PHASE as the Phase value on
	the call to Setup_Current_Excep.
	* raise-gcc.c (personality_body): Pass uw_phases as the Phase argument
	on calls to Setup_Current_Excep.

--- gcc/ada/libgnat/a-exexpr.adb
+++ gcc/ada/libgnat/a-exexpr.adb
@@ -29,7 +29,56 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This is the version using the GCC EH mechanism
+--  This is the version using the GCC EH mechanism, which could rely on
+--  different underlying unwinding engines, for example DWARF or ARM unwind
+--  info based. Here is a sketch of the most prominent data structures
+--  involved:
+
+--      (s-excmac.ads)
+--      GNAT_GCC_Exception:
+--      *-----------------------------------*
+--  o-->|          (s-excmac.ads)           |
+--  |   | Header : <gcc occurrence type>    |
+--  |   |   - Class                         |
+--  |   |   ...                             |    Constraint_Error:
+--  |   |-----------------------------------*    Program_Error:
+--  |   |              (a-except.ads)       |    Foreign_Exception:
+--  |   | Occurrence : Exception_Occurrence |
+--  |   |                                   |    (s-stalib. ads)
+--  |   |   - Id : Exception_Id  --------------> Exception_Data
+--  o------ - Machine_Occurrence            |   *------------------------*
+--      |   - Msg                           |   | Not_Handled_By_Others  |
+--      |   - Traceback                     |   | Lang                   |
+--      |   ...                             |   | Foreign_Data --o       |
+--      *-----------------------------------*   | Full_Name      |       |
+--        ||                                    | ...            |       |
+--        ||          foreign rtti blob         *----------------|-------*
+--        ||          *---------------*                          |
+--        ||          |   ...   ...   |<-------------------------o
+--        ||          *---------------*
+--        ||
+--     Setup_Current_Excep()
+--        ||
+--        ||   Latch into ATCB or
+--        ||   environment Current Exception Buffer:
+--        ||
+--        vv
+--     <> : Exception_Occurrence
+--     *---------------------------*
+--     | ...  ...  ... ... ... ... * --- Get_Current_Excep() ---->
+--     *---------------------------*
+
+--  On "raise" events, the runtime allocates a new GNAT_GCC_Exception
+--  instance and eventually calls into libgcc's Unwind_RaiseException.
+--  This part handles the object through the header part only.
+
+--  During execution, Get_Current_Excep provides a pointer to the
+--  Exception_Occurrence being raised or last raised by the current task.
+
+--  This is actually the address of a statically allocated
+--  Exception_Occurrence attached to the current ATCB or to the environment
+--  thread into which an occurrence being raised is synchronized at critical
+--  points during the raise process, via Setup_Current_Excep.
 
 with Ada.Unchecked_Conversion;
 with Ada.Unchecked_Deallocation;
@@ -51,6 +100,22 @@ package body Exception_Propagation is
    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
    --------------------------------------------------------------
 
+   --  Phase identifiers (Unwind Actions)
+
+   type Unwind_Action is new Integer;
+   pragma Convention (C, Unwind_Action);
+
+   UA_SEARCH_PHASE  : constant Unwind_Action := 1;
+   UA_CLEANUP_PHASE : constant Unwind_Action := 2;
+   UA_HANDLER_FRAME : constant Unwind_Action := 4;
+   UA_FORCE_UNWIND  : constant Unwind_Action := 8;
+   UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
+
+   pragma Unreferenced
+     (UA_HANDLER_FRAME,
+      UA_FORCE_UNWIND,
+      UA_END_OF_STACK);
+
    procedure GNAT_GCC_Exception_Cleanup
      (Reason : Unwind_Reason_Code;
       Excep  : not null GNAT_GCC_Exception_Access);
@@ -70,10 +135,19 @@ package body Exception_Propagation is
    --  directly from gigi.
 
    function Setup_Current_Excep
-     (GCC_Exception : not null GCC_Exception_Access) return EOA;
+     (GCC_Exception : not null GCC_Exception_Access;
+      Phase : Unwind_Action) return EOA;
    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
-   --  Write Get_Current_Excep.all from GCC_Exception. Called by the
-   --  personality routine.
+   --  Acknowledge GCC_Exception as the current exception object being
+   --  raised, which could be an Ada or a foreign exception object.  Return
+   --  a pointer to the embedded Ada occurrence for an Ada exception object,
+   --  to the current exception buffer otherwise.
+   --
+   --  Synchronize the current exception buffer as needed for possible
+   --  accesses through Get_Current_Except.all afterwards, depending on the
+   --  Phase bits, received either from the personality routine, from a
+   --  forced_unwind cleanup handler, or just before the start of propagation
+   --  for an Ada exception (Phase 0 in this case).
 
    procedure Unhandled_Except_Handler
      (GCC_Exception : not null GCC_Exception_Access);
@@ -236,27 +310,41 @@ package body Exception_Propagation is
    -------------------------
 
    function Setup_Current_Excep
-     (GCC_Exception : not null GCC_Exception_Access) return EOA
+     (GCC_Exception : not null GCC_Exception_Access;
+      Phase : Unwind_Action) return EOA
    is
       Excep : constant EOA := Get_Current_Excep.all;
 
    begin
-      --  Setup the exception occurrence
 
       if GCC_Exception.Class = GNAT_Exception_Class then
 
-         --  From the GCC exception
+         --  Ada exception : latch the occurrence data in the Current
+         --  Exception Buffer if needed and return a pointer to the original
+         --  Ada exception object. This particular object was specifically
+         --  allocated for this raise and is thus more precise than the fixed
+         --  Current Exception Buffer address.
 
          declare
             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
                                 To_GNAT_GCC_Exception (GCC_Exception);
          begin
-            Excep.all := GNAT_Occurrence.Occurrence;
+
+            --  When reaching here during SEARCH_PHASE, no need to
+            --  replicate the copy performed at the propagation start.
+
+            if Phase /= UA_SEARCH_PHASE then
+               Excep.all := GNAT_Occurrence.Occurrence;
+            end if;
             return GNAT_Occurrence.Occurrence'Access;
          end;
 
       else
-         --  A default one
+
+         --  Foreign exception (caught by Ada handler, reaching here from
+         --  personality routine) : The original exception object doesn't hold
+         --  an Ada occurrence info.  Set the foreign data pointer in the
+         --  Current Exception Buffer and return the address of the latter.
 
          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 
@@ -312,7 +400,12 @@ package body Exception_Propagation is
    procedure Propagate_GCC_Exception
      (GCC_Exception : not null GCC_Exception_Access)
    is
-      Excep : EOA;
+      --  Acknowledge the current exception info now, before unwinding
+      --  starts so it is available even from C++ handlers involved before
+      --  our personality routine.
+
+      Excep : constant EOA :=
+        Setup_Current_Excep (GCC_Exception, Phase => 0);
 
    begin
       --  Perform a standard raise first. If a regular handler is found, it
@@ -326,7 +419,6 @@ package body Exception_Propagation is
       --  the necessary steps to enable the debugger to gain control while the
       --  stack is still intact.
 
-      Excep := Setup_Current_Excep (GCC_Exception);
       Notify_Unhandled_Exception (Excep);
 
       --  Now, un a forced unwind to trigger cleanups. Control should not
@@ -392,7 +484,7 @@ package body Exception_Propagation is
    is
       Excep : EOA;
    begin
-      Excep := Setup_Current_Excep (GCC_Exception);
+      Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE);
       Unhandled_Exception_Terminate (Excep);
    end Unhandled_Except_Handler;
 

--- gcc/ada/libgnat/s-excmac__arm.ads
+++ gcc/ada/libgnat/s-excmac__arm.ads
@@ -58,6 +58,7 @@ package System.Exceptions.Machine is
       URC_INSTALL_CONTEXT,
       URC_CONTINUE_UNWIND,
       URC_FAILURE);
+   pragma Convention (C, Unwind_Reason_Code);
 
    pragma Unreferenced
      (URC_OK,
@@ -71,9 +72,7 @@ package System.Exceptions.Machine is
       URC_CONTINUE_UNWIND,
       URC_FAILURE);
 
-   pragma Convention (C, Unwind_Reason_Code);
-   subtype Unwind_Action is Unwind_Reason_Code;
-   --  Phase identifiers
+   --  ARM Unwinding State
 
    type uint32_t is mod 2**32;
    pragma Convention (C, uint32_t);

--- gcc/ada/libgnat/s-excmac__gcc.ads
+++ gcc/ada/libgnat/s-excmac__gcc.ads
@@ -75,24 +75,6 @@ package System.Exceptions.Machine is
 
    pragma Convention (C, Unwind_Reason_Code);
 
-   --  Phase identifiers
-
-   type Unwind_Action is new Integer;
-   pragma Convention (C, Unwind_Action);
-
-   UA_SEARCH_PHASE  : constant Unwind_Action := 1;
-   UA_CLEANUP_PHASE : constant Unwind_Action := 2;
-   UA_HANDLER_FRAME : constant Unwind_Action := 4;
-   UA_FORCE_UNWIND  : constant Unwind_Action := 8;
-   UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
-
-   pragma Unreferenced
-     (UA_SEARCH_PHASE,
-      UA_CLEANUP_PHASE,
-      UA_HANDLER_FRAME,
-      UA_FORCE_UNWIND,
-      UA_END_OF_STACK);
-
    --  Mandatory common header for any exception object handled by the
    --  GCC unwinding runtime.
 

--- gcc/ada/raise-gcc.c
+++ gcc/ada/raise-gcc.c
@@ -106,8 +106,9 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *);
 _Unwind_Reason_Code
 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *);
 
-extern struct Exception_Occurrence *__gnat_setup_current_excep
- (_Unwind_Exception *);
+extern struct Exception_Occurrence *
+__gnat_setup_current_excep (_Unwind_Exception *, _Unwind_Action);
+
 extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
 
 #ifdef CERT
@@ -1220,12 +1221,14 @@ personality_body (_Unwind_Action uw_phases,
       else
 	{
 #ifndef CERT
-	  struct Exception_Occurrence *excep;
-
 	  /* Trigger the appropriate notification routines before the second
-	     phase starts, which ensures the stack is still intact.
-             First, setup the Ada occurrence.  */
-          excep = __gnat_setup_current_excep (uw_exception);
+	     phase starts, when the stack is still intact.  First install what
+	     needs to be installed in the current exception buffer and fetch
+	     the Ada occurrence pointer to use.  */
+
+	  struct Exception_Occurrence *excep
+	    = __gnat_setup_current_excep (uw_exception, uw_phases);
+
 	  if (action.kind == unhandler)
 	    __gnat_notify_unhandled_exception (excep);
 	  else
@@ -1245,10 +1248,10 @@ personality_body (_Unwind_Action uw_phases,
     (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
 
 #ifndef CERT
-  /* Write current exception, so that it can be retrieved from Ada.  It was
-     already done during phase 1 (just above), but in between, one or several
-     exceptions may have been raised (in cleanup handlers).  */
-  __gnat_setup_current_excep (uw_exception);
+  /* Write current exception so that it can be retrieved from Ada.  It was
+     already done during phase 1, but one or several exceptions may have been
+     raised in cleanup handlers in between.  */
+  __gnat_setup_current_excep (uw_exception, uw_phases);
 #endif
 
   return _URC_INSTALL_CONTEXT;