Fix protect-unwind

ChangeLog

@@ -1,3 +1,71 @@
+
+2018-06-02  Lionel Henry  <lionel@rstudio.com>
+
+        * inst/unitTests/runit.interface.R: New test for the case where
+        the client package was compiled without protected evaluation
+        enabled. On R 3.5, longjump exceptions thrown from imported
+        functions are still caught and dealt with properly by the client
+        package.
+
+        * inst/unitTests/runit.interface.R: Test both Rcpp_eval() and
+        Rcpp_fast_eval().
+
+2018-06-01  Lionel Henry  <lionel@rstudio.com>
+
+        * inst/unitTests/runit.interface.R: New tests for interfaces and unwind.
+        These tests build two packages, and that exports a function via
+        Rcpp::interfaces(cpp) and the other that calls it. The attributes are
+        regenerated and the packages rebuilt each time the tests are run. The
+        tests check in particular that the C++ stack is properly unwound when a
+        long jump occurs.
+
+2018-05-31  Lionel Henry  <lionel@rstudio.com>
+
+        * inst/include/Rcpp/api/meat/Rcpp_eval.h: Fix protected evaluation.
+
+        Setting `RCPP_PROTECTED_EVAL` before including Rcpp.h enables a new R
+        3.5 API for safe evaluation of R code. R longjumps are now correctly
+        intercepted and rethrown. Thanks to this the C++ stack is now safely
+        unwound when a longjump is detected while calling into R code. This
+        includes the following cases: thrown errors, caught condition of any
+        class, long return, restart invokation, debugger exit. Note that this is
+        still experimental!
+
+        When `RCPP_PROTECTED_EVAL` is enabled, Rcpp_eval() uses the
+        protect-unwind API under the hood in order to gain safety. It is fully
+        backward-compatibile and still catches errors and interrupts to rethrow
+        them as typed C++ exceptions. If you don't need to catch those, consider
+        using Rcpp_fast_eval() instead to avoid the catching overhead.
+
+        Rcpp_fast_eval() is a wrapper around Rf_eval(). Unlike Rcpp_eval(), it
+        does not evaluate R code within tryCatch() and thus avoids the overhead
+        of wrapping and evaluating the expression in a tryCatch() call. When
+        Rcpp is compiled with a lower version than R 3.5, Rcpp_fast_eval() falls
+        back to Rf_eval() without any protection from long jumps, even when
+        `RCPP_PROTECTED_EVAL` is set. Either add R 3.5 to your `Depends` or make
+        sure the legacy Rcpp_eval() function is called instead of Rcpp_fast_eval()
+        when your package is compiled with an older version of R.
+
+        Note that Rcpp_fast_eval() behaves a bit differently to Rcpp_eval(). The
+        former has the semantics of the C function Rf_eval() whereas the latter
+        behaves like the R function base::eval(). This has subtle implications
+        for control flow. For instance evaluating a return() expression within a
+        frame environment returns from that frame rather than from the
+        Rcpp_eval() call.
+
+        * inst/include/Rcpp/macros/macros.h: Leave the try/catch scope before
+        resuming jump to ensure proper destruction of the exception reference.
+
+        * inst/include/Rcpp/exceptions.h: Functions to create and check a
+        longjump sentinel. This sentinel is used as return value in contexts
+        where it is not safe to resume a jump (i.e. in the glue code of cpp
+        interfaces).
+
+        * inst/include/Rcpp/macros/macros.h: Return a longjump sentinel in
+        END_RCPP_RETURN_ERROR.
+
+        * src/attributes.cpp: Detect longjump sentinels and resume jump.
+
 2018-05-09  Dirk Eddelbuettel  <edd@debian.org>
 
         * DESCRIPTION: Release 0.12.17

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Rcpp
 Title: Seamless R and C++ Integration
-Version: 0.12.17
+Version: 0.12.17.1
 Date: 2018-05-09
 Author: Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou,
  Nathan Russell, Douglas Bates and John Chambers

inst/include/Rcpp/Environment.h

@@ -109,11 +109,7 @@ namespace Rcpp{
 
             /* We need to evaluate if it is a promise */
             if( TYPEOF(res) == PROMSXP){
-#if defined(RCPP_USE_UNWIND_PROTECT)
-                res = internal::Rcpp_eval_impl(res, env);
-#else
-                res = Rf_eval(res, env);
-#endif
+                res = internal::Rcpp_eval_impl( res, env ) ;
             }
             return res ;
         }
@@ -133,11 +129,7 @@ namespace Rcpp{
 
             /* We need to evaluate if it is a promise */
             if( TYPEOF(res) == PROMSXP){
-#if defined(RCPP_USE_UNWIND_PROTECT)
-                res = internal::Rcpp_eval_impl(res, env);
-#else
-                res = Rf_eval(res, env);
-#endif
+                res = internal::Rcpp_eval_impl( res, env ) ;
             }
             return res ;
         }
@@ -159,11 +151,7 @@ namespace Rcpp{
 
             /* We need to evaluate if it is a promise */
             if( TYPEOF(res) == PROMSXP){
-#if defined(RCPP_USE_UNWIND_PROTECT)
-                res = internal::Rcpp_eval_impl(res, env);
-#else
-                res = Rf_eval(res, env);
-#endif
+                res = internal::Rcpp_eval_impl( res, env ) ;
             }
             return res ;
         }
@@ -186,11 +174,7 @@ namespace Rcpp{
 
             /* We need to evaluate if it is a promise */
             if( TYPEOF(res) == PROMSXP){
-#if defined(RCPP_USE_UNWIND_PROTECT)
-                res = internal::Rcpp_eval_impl(res, env);
-#else
-                res = Rf_eval(res, env);
-#endif
+                res = internal::Rcpp_eval_impl( res, env ) ;
             }
             return res ;
         }

inst/include/Rcpp/Language.h

@@ -145,18 +145,10 @@ namespace Rcpp{
         }
 
         SEXP fast_eval() const {
-#if defined(RCPP_USE_UNWIND_PROTECT)
-            return internal::Rcpp_eval_impl( Storage::get__(), R_GlobalEnv);
-#else
-            return Rf_eval(Storage::get__(), R_GlobalEnv);
-#endif
+            return internal::Rcpp_eval_impl( Storage::get__(), R_GlobalEnv) ;
         }
         SEXP fast_eval(SEXP env ) const {
-#if defined(RCPP_USE_UNWIND_PROTECT)
             return internal::Rcpp_eval_impl( Storage::get__(), env) ;
-#else
-            return Rf_eval(Storage::get__(), env);
-#endif
         }
 
         void update( SEXP x){

inst/include/Rcpp/api/meat/Rcpp_eval.h

@@ -21,14 +21,12 @@
 #include <Rcpp/Interrupt.h>
 #include <Rversion.h>
 
-// outer definition from RcppCommon.h
-#if defined(RCPP_USE_UNWIND_PROTECT)
-  #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
-     // file-local and only used here 
-     #define RCPP_USE_PROTECT_UNWIND
-  #endif
+#if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+#define RCPP_USE_PROTECT_UNWIND
+#include <csetjmp>
 #endif
 
+
 namespace Rcpp {
 namespace internal {
 
@@ -39,18 +37,17 @@ namespace internal {
         SEXP env;
         EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { }
     };
+    struct EvalUnwindData {
+        std::jmp_buf jmpbuf;
+    };
 
-    inline void Rcpp_maybe_throw(void* data, Rboolean jump) {
+    // First jump back to the protected context with a C longjmp because
+    // `Rcpp_protected_eval()` is called from C and we can't safely throw
+    // exceptions across C frames.
+    inline void Rcpp_maybe_throw(void* unwind_data, Rboolean jump) {
         if (jump) {
-            SEXP token = static_cast<SEXP>(data);
-
-            // Keep the token protected while unwinding because R code might run
-            // in C++ destructors. Can't use PROTECT() for this because
-            // UNPROTECT() might be called in a destructor, for instance if a
-            // Shield<SEXP> is on the stack.
-            ::R_PreserveObject(token);
-
-            throw LongjumpException(token);
+            EvalUnwindData* data = static_cast<EvalUnwindData*>(unwind_data);
+            longjmp(data->jmpbuf, 1);
         }
     }
 
@@ -80,9 +77,21 @@ namespace internal {
 
     inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
         internal::EvalData data(expr, env);
+        internal::EvalUnwindData unwind_data;
         Shield<SEXP> token(::R_MakeUnwindCont());
+
+        if (setjmp(unwind_data.jmpbuf)) {
+            // Keep the token protected while unwinding because R code might run
+            // in C++ destructors. Can't use PROTECT() for this because
+            // UNPROTECT() might be called in a destructor, for instance if a
+            // Shield<SEXP> is on the stack.
+            ::R_PreserveObject(token);
+
+            throw internal::LongjumpException(token);
+        }
+
         return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data,
-                                 internal::Rcpp_maybe_throw, token,
+                                 internal::Rcpp_maybe_throw, &unwind_data,
                                  token);
     }
 
@@ -112,11 +121,7 @@ inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
     SET_TAG(CDDR(call), ::Rf_install("error"));
     SET_TAG(CDDR(CDR(call)), ::Rf_install("interrupt"));
 
-#if defined(RCPP_USE_UNWIND_PROTECT)
-    Shield<SEXP> res(::Rf_eval(call, R_GlobalEnv))			// execute the call
-#else
     Shield<SEXP> res(internal::Rcpp_eval_impl(call, R_GlobalEnv));
-#endif
 
     // check for condition results (errors, interrupts)
     if (Rf_inherits(res, "condition")) {
@@ -125,12 +130,7 @@ inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
 
             Shield<SEXP> conditionMessageCall(::Rf_lang2(::Rf_install("conditionMessage"), res));
 
-#if defined(RCPP_USE_UNWIND_PROTECT)
-            Shield<SEXP> conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall,
-                                                                   R_GlobalEnv));
-#else
-            Shield<SEXP> conditionMessage(::Rf_eval(conditionMessageCall, R_GlobalEnv));
-#endif
+            Shield<SEXP> conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall, R_GlobalEnv));
             throw eval_error(CHAR(STRING_ELT(conditionMessage, 0)));
         }
 

inst/include/Rcpp/exceptions.h

@@ -111,23 +111,51 @@ namespace Rcpp {
         throw Rcpp::exception(message.c_str());
     }                                                        // #nocov end
 
-#if defined(RCPP_USE_UNWIND_PROTECT)
     namespace internal {
 
+        inline SEXP longjumpSentinel(SEXP token) {
+            SEXP sentinel = PROTECT(Rf_allocVector(VECSXP, 1));
+            SET_VECTOR_ELT(sentinel, 0, token);
+
+            SEXP sentinelClass = PROTECT(Rf_mkString("Rcpp:longjumpSentinel"));
+            Rf_setAttrib(sentinel, R_ClassSymbol, sentinelClass) ;
+
+            UNPROTECT(2);
+            return sentinel;
+        }
+
+        inline bool isLongjumpSentinel(SEXP x) {
+            return
+                Rf_inherits(x, "Rcpp:longjumpSentinel") &&
+                TYPEOF(x) == VECSXP &&
+                Rf_length(x) == 1;
+        }
+
+        inline SEXP getLongjumpToken(SEXP sentinel) {
+            return VECTOR_ELT(sentinel, 0);
+        }
+
         struct LongjumpException {
             SEXP token;
-            LongjumpException(SEXP token_) : token(token_) { }
+            LongjumpException(SEXP token_) : token(token_) {
+                if (isLongjumpSentinel(token)) {
+                    token = getLongjumpToken(token);
+                }
+            }
         };
 
         inline void resumeJump(SEXP token) {
+            if (isLongjumpSentinel(token)) {
+                token = getLongjumpToken(token);
+            }
             ::R_ReleaseObject(token);
-#if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+#if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
             ::R_ContinueUnwind(token);
 #endif
+            Rf_error("Internal error: Rcpp longjump failed to resume");
         }
 
     } // namespace internal
-#endif
 
 } // namespace Rcpp