Use new protect-unwind API for evaluation of R code

lionel- · lionel- · commit c3dd7ab17901 · 2017-12-14T15:23:05.000+01:00
diff --git a/ChangeLog b/ChangeLog
@@ -1,3 +1,44 @@
+
+2017-12-13  Lionel Henry  <lionel@rstudio.com>
+
+        * inst/include/Rcpp/api/meat/Rcpp_eval.h: Add Rcpp_fast_eval() for safe
+        and fast evaluation of R code using the new protect-unwind API in R 3.5.
+        Unlike Rcpp_eval(), this does not evaluate R code within tryCatch() in
+        order to avoid the catching overhead. R longjumps are now correctly
+        intercepted and rethrown. Following this change the C++ stack is now
+        safely unwound when a longjump is detected while calling into R code.
+        This includes the following cases: caught condition of any class, long
+        return, restart jump, debugger exit.
+
+        Rcpp_eval() also uses the protect-unwind API in order to gain safety.
+        To maintain compatibility it still catches errors and interrupts in
+        order to rethrow them as typed C++ exceptions. If you don't need to
+        catch those, consider using Rcpp_fast_eval() instead to avoid the
+        overhead.
+
+        These improvements are only available for R 3.5.0 and greater. When
+        compiled with old versions of R, Rcpp_fast_eval() falls back to
+        Rcpp_eval(). This is in contrast to internal::Rcpp_eval_impl() which
+        falls back to Rf_eval() and which is used in performance-sensititive
+        places.
+
+        Note that with this change, Rcpp_eval() now behaves like the C function
+        Rf_eval() whereas it used to behave like the R function base::eval().
+        This has subtle implications for control flow. For instance evaluating a
+        return() expression within a frame environment now returns from that
+        frame rather than from the Rcpp_eval() call. The old semantics were a
+        consequence of using evalq() internally and were not documented.
+
+        * inst/include/Rcpp/exceptions.h: Add LongjumpException and
+        resumeJump() to support Rcpp_fast_eval().
+
+        * inst/include/Rcpp/macros/macros.h: Catch LongjumpException and call
+        resumeJump(). If resumeJump() doesn't jump (on old R versions), throw an
+        R error (this normally should not happen).
+
+        * inst/include/RcppCommon.h: Add Rcpp_fast_eval() to the public API and
+        internal::Rcpp_eval_impl() to the private API.
+
 2017-12-05  Kevin Ushey  <kevinushey@gmail.com>
 
         * inst/include/Rcpp/Environment.h: Use public R APIs
diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd
@@ -11,6 +11,20 @@
       set an initial format string (Dirk in \ghpr{777} fixing \ghit{776}).
       \item The 'new' Date and Datetime vectors now have \code{is_na} methods
       too. (Dirk in \ghpr{783} fixing \ghit{781}).
+
+      \item Evaluation of R code is now safer when compiled against R
+      3.5. Longjumps of all kinds (condition catching, returns,
+      restarts, debugger exit) are appropriately detected and handled,
+      e.g. the C++ stack unwinds correctly. The new function
+      \code{Rcpp_fast_eval()} can be used for performance-sensitive
+      evaluation of R code. Unlike \code{Rcpp_eval()}, it does not try
+      to catch errors with \code{tryEval} in order to avoid the catching
+      overhead. While this is safe thanks to the stack unwinding
+      protection, this also means that R errors are not transformed to
+      an \code{Rcpp::exception}. If you are relying on error rethrowing,
+      you have to use the slower \code{Rcpp_eval()}. On old R versions
+      \code{Rcpp_fast_eval()} falls back to \code{Rcpp_eval()} so it is
+      safe to use against any versions of R.
     }
     \item Changes in Rcpp Attributes:
     \itemize{
diff --git a/inst/include/Rcpp/api/meat/Rcpp_eval.h b/inst/include/Rcpp/api/meat/Rcpp_eval.h
@@ -19,8 +19,70 @@
 #define Rcpp_api_meat_Rcpp_eval_h
 
 #include <Rcpp/Interrupt.h>
+#include <Rversion.h>
+
+#if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+#define R_HAS_UNWIND
+#endif
+
 
 namespace Rcpp {
+namespace internal {
+
+#ifdef R_HAS_UNWIND
+
+    struct EvalData {
+        SEXP expr;
+        SEXP env;
+        EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { }
+    };
+
+    inline void Rcpp_maybe_throw(void* data, Rboolean jump) {
+        if (jump) {
+            throw LongjumpException(static_cast<SEXP>(data));
+        }
+    }
+
+    inline SEXP Rcpp_protected_eval(void* eval_data) {
+        EvalData* data = static_cast<EvalData*>(eval_data);
+        return ::Rf_eval(data->expr, data->env);
+    }
+
+    // This is used internally instead of Rf_eval() to make evaluation safer
+    inline SEXP Rcpp_eval_impl(SEXP expr, SEXP env) {
+        return Rcpp_fast_eval(expr, env);
+    }
+
+#else // R < 3.5.0
+
+    // Fall back to Rf_eval() when the protect-unwind API is unavailable
+    inline SEXP Rcpp_eval_impl(SEXP expr, SEXP env) {
+        return ::Rf_eval(expr, env);
+    }
+
+#endif
+
+} // namespace internal
+
+
+#ifdef R_HAS_UNWIND
+
+    inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
+        internal::EvalData data(expr, env);
+        Shield<SEXP> token(::R_MakeUnwindCont());
+        return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data,
+                                 internal::Rcpp_maybe_throw, token,
+                                 token);
+    }
+
+#else
+
+    inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
+        return Rcpp_eval(expr, env);
+    }
+
+#endif
+
 
 inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
 
@@ -39,8 +101,7 @@ inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
     SET_TAG(CDDR(call), ::Rf_install("error"));
     SET_TAG(CDDR(CDR(call)), ::Rf_install("interrupt"));
 
-    // execute the call
-    Shield<SEXP> res(::Rf_eval(call, R_GlobalEnv));
+    Shield<SEXP> res(internal::Rcpp_eval_impl(call, R_GlobalEnv));
 
     // check for condition results (errors, interrupts)
     if (Rf_inherits(res, "condition")) {
@@ -49,7 +110,7 @@ inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
             
             Shield<SEXP> conditionMessageCall(::Rf_lang2(::Rf_install("conditionMessage"), res));
             
-            Shield<SEXP> conditionMessage(::Rf_eval(conditionMessageCall, R_GlobalEnv));
+            Shield<SEXP> conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall, R_GlobalEnv));
             throw eval_error(CHAR(STRING_ELT(conditionMessage, 0)));
         }
         
diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h
@@ -22,6 +22,9 @@
 #ifndef Rcpp__exceptions__h
 #define Rcpp__exceptions__h
 
+#include <Rversion.h>
+
+
 #define GET_STACKTRACE() stack_trace( __FILE__, __LINE__ )
 
 namespace Rcpp {
@@ -108,6 +111,21 @@ namespace Rcpp {
         throw Rcpp::exception(message.c_str());
     }                                                        // #nocov end
 
+    namespace internal {
+
+        struct LongjumpException {
+            SEXP token;
+            LongjumpException(SEXP token_) : token(token_) { }
+        };
+
+        inline void resumeJump(SEXP token) {
+#if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+            ::R_ContinueUnwind(token);
+#endif
+        }
+
+    } // namespace internal
+
 } // namespace Rcpp
 
 
diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h
@@ -41,6 +41,11 @@
     catch( Rcpp::internal::InterruptedException &__ex__) {                                       \
         rcpp_output_type = 1 ;                                                                   \
     }                                                                                            \
+    catch(Rcpp::internal::LongjumpException& __ex__) {                                           \
+        Rcpp::internal::resumeJump(__ex__.token);                                                \
+        rcpp_output_type = 2 ;                                                                   \
+        rcpp_output_condition = PROTECT(string_to_try_error("Unexpected LongjumpException")) ;   \
+    }                                                                                            \
     catch(Rcpp::exception& __ex__) {                                                             \
        rcpp_output_type = 2 ;                                                                    \
        rcpp_output_condition = PROTECT(rcpp_exception_to_r_condition(__ex__)) ;                  \
@@ -73,6 +78,10 @@
   catch (Rcpp::internal::InterruptedException &__ex__) {                       \
     return Rcpp::internal::interruptedError();                                 \
   }                                                                            \
+  catch (Rcpp::internal::LongjumpException& __ex__) {                          \
+    Rcpp::internal::resumeJump(__ex__.token);                                  \
+    return string_to_try_error("Unexpected LongjumpException") ;               \
+  }                                                                            \
   catch (std::exception &__ex__) {                                             \
     return exception_to_try_error(__ex__);                                     \
   }                                                                            \
diff --git a/inst/include/RcppCommon.h b/inst/include/RcppCommon.h
@@ -74,7 +74,13 @@ namespace Rcpp {
 
 namespace Rcpp {
 
+    SEXP Rcpp_fast_eval(SEXP expr_, SEXP env = R_GlobalEnv);
     SEXP Rcpp_eval(SEXP expr_, SEXP env = R_GlobalEnv);
+
+    namespace internal {
+        SEXP Rcpp_eval_impl(SEXP expr, SEXP env = R_GlobalEnv);
+    }
+
     class Module;
 
     namespace traits {
