Use protect-unwind API and add Rcpp_fast_eval()

ChangeLog

@@ -1,3 +1,48 @@
+
+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. You also
+        need to explicitly define `RCPP_PROTECTED_EVAL` before including Rcpp.h.
+        When compiled with old versions of R, Rcpp_fast_eval() always 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.
+
+        * inst/include/Rcpp/Environment.h: Use safe evaluation
+        * inst/include/Rcpp/Language.h: idem
+
 2017-12-05  Kevin Ushey  <kevinushey@gmail.com>
 
         * inst/include/Rcpp/Environment.h: Use public R APIs

inst/NEWS.Rd

@@ -11,6 +11,21 @@
       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 (you also need to explicitly define \code{RCPP_PROTECTED_EVAL}
+      before including \code{Rcpp.h}). Longjumps of all kinds (condition
+      catching, returns, restarts, debugger exit) are appropriately
+      detected and handled, e.g. the C++ stack unwinds correctly.
+      \item 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{

inst/include/Rcpp/Environment.h

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

inst/include/Rcpp/Language.h

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

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

@@ -19,8 +19,78 @@
 #define Rcpp_api_meat_Rcpp_eval_h
 
 #include <Rcpp/Interrupt.h>
+#include <Rversion.h>
+
+#if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+#define RCPP_USE_PROTECT_UNWIND
+#endif
+
 
 namespace Rcpp {
+namespace internal {
+
+#ifdef RCPP_USE_PROTECT_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) {
+            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);
+        }
+    }
+
+    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 RCPP_USE_PROTECT_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 +109,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 +118,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)));
         }
 

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,22 @@ 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) {
+            ::R_ReleaseObject(token);
+#if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
+            ::R_ContinueUnwind(token);
+#endif
+        }
+
+    } // namespace internal
+
 } // namespace Rcpp
 
 

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__);                                     \
   }                                                                            \

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 {

inst/unitTests/cpp/misc.cpp

@@ -19,6 +19,8 @@
 // You should have received a copy of the GNU General Public License
 // along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
+#define RCPP_PROTECTED_EVAL
+
 #include <Rcpp.h>
 using namespace Rcpp;
 using namespace std;
@@ -224,3 +226,31 @@ String testNullableString(Rcpp::Nullable<Rcpp::String> param = R_NilValue) {
   else
     return String("");
 }
+
+// Class that indicates to R caller whether C++ stack was unwound
+struct unwindIndicator {
+    unwindIndicator(LogicalVector indicator_) {
+        // Reset the indicator to FALSE
+        indicator = indicator_;
+        *LOGICAL(indicator) = 0;
+    }
+
+    // Set indicator to TRUE when stack unwinds
+    ~unwindIndicator() {
+        *LOGICAL(indicator) = 1;
+    }
+
+    LogicalVector indicator;
+};
+
+// [[Rcpp::export]]
+SEXP testEvalUnwindImpl(RObject expr, Environment env, LogicalVector indicator) {
+    unwindIndicator my_data(indicator);
+    return Rcpp::Rcpp_fast_eval(expr, env);
+}
+
+// [[Rcpp::export]]
+SEXP testSendInterrupt() {
+  Rf_onintr();
+  return R_NilValue;
+}

inst/unitTests/runit.misc.R

@@ -214,4 +214,55 @@ if (.runThisTest) {
         checkTrue(nchar(Rcpp:::bib()) > 0, msg="bib file")
     }
 
+    test.stackUnwinds <- function() {
+        # On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
+        # leaks on longjumps
+        hasUnwind <- getRversion() >= "3.5.0"
+        checkUnwound <- if (hasUnwind) checkTrue else function(x) checkTrue(!x)
+        testEvalUnwind <- function(expr, indicator) {
+            testEvalUnwindImpl(expr, parent.frame(), indicator)
+        }
+
+        # On errors - Always unwound
+        unwound <- FALSE
+        out <- tryCatch(testEvalUnwind(quote(stop("err")), unwound), error = identity)
+        checkTrue(unwound)
+        msg <- if (hasUnwind) "err" else "Evaluation error: err."
+        checkIdentical(out$message, msg)
+
+        # On interrupts - Always unwound
+        unwound <- FALSE
+        expr <- quote({
+            repeat testSendInterrupt()
+            "returned"
+        })
+        out <- tryCatch(testEvalUnwind(expr, unwound), interrupt = function(c) "onintr")
+        checkTrue(unwound)
+        checkIdentical(out, "onintr")
+
+        # On caught conditions
+        unwound <- FALSE
+        expr <- quote(signalCondition(simpleCondition("cnd")))
+        cnd <- tryCatch(testEvalUnwind(expr, unwound), condition = identity)
+        checkTrue(inherits(cnd, "simpleCondition"))
+        checkUnwound(unwound)
+
+        # On restart jumps
+        unwound <- FALSE
+        expr <- quote(invokeRestart("rst"))
+        out <- withRestarts(testEvalUnwind(expr, unwound), rst = function(...) "restarted")
+        checkIdentical(out, "restarted")
+        checkUnwound(unwound)
+
+        # On returns
+        unwound <- FALSE
+        expr <- quote(signalCondition(simpleCondition(NULL)))
+        out <- callCC(function(k)
+            withCallingHandlers(testEvalUnwind(expr, unwound),
+                simpleCondition = function(e) k("jumped")
+            )
+        )
+        checkIdentical(out, "jumped")
+        checkUnwound(unwound)
+    }
 }