Extract Rcpp::unwindProtect() from Rcpp::Rcpp_fast_eval()

ChangeLog

@@ -1,3 +1,22 @@
+
+2018-06-21  Lionel Henry  <lionel@rstudio.com>
+
+        * inst/include/Rcpp/api/meat/unwind.h: Extract unwind protection from
+        Rcpp::Rcpp_fast_eval() into Rcpp::unwindProtect(). Use this function
+        whenever you need to call a C function that might longjump, for instance
+        a function from R's C API. Rcpp::unwindProtect() will protect your C++
+        stack and throw a Rcpp::internal::LongJump exception to ensure all
+        destructors are called. The R longjump is then resumed once it is safe
+        to do so. This function powers Rcpp_fast_eval().
+
+        You can use Rcpp::unwindProtect() in two ways. First with a C-like
+        callback interface that takes a `SEXP (*)(void* data)` function pointer
+        and a `void*` data argument that is passed to the function. Second, if
+        you have C++11 enabled, Rcpp::unwindProtect() implements an
+        `std::function<SEXP(void)>` overload. You can pass any function object
+        or lambda function with the right signature.
+        * inst/include/Rcpp/api/meat/Rcpp_eval.h: Idem
+
 2018-06-15  Dirk Eddelbuettel  <edd@debian.org>
 
         * DESCRIPTION (Version, Date): Roll minor version

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

@@ -23,83 +23,56 @@
 
 #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0))
 #define RCPP_USE_PROTECT_UNWIND
-#include <csetjmp>
+#include <Rcpp/api/meat/unwind.h>
 #endif
 
 
-namespace Rcpp {
-namespace internal {
+namespace Rcpp { namespace internal {
 
 #ifdef RCPP_USE_PROTECT_UNWIND
 
-    struct EvalData {
-        SEXP expr;
-        SEXP env;
-        EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { }
-    };
-    struct EvalUnwindData {
-        std::jmp_buf jmpbuf;
-    };
-
-    // 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) {
-            EvalUnwindData* data = static_cast<EvalUnwindData*>(unwind_data);
-            longjmp(data->jmpbuf, 1);
-        }
-    }
+struct EvalData {
+    SEXP expr;
+    SEXP env;
+    EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { }
+};
 
-    inline SEXP Rcpp_protected_eval(void* eval_data) {
-        EvalData* data = static_cast<EvalData*>(eval_data);
-        return ::Rf_eval(data->expr, data->env);
-    }
+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);
-    }
+// 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);
-    }
+// 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
+}} // namespace Rcpp::internal
 
 
-#ifdef RCPP_USE_PROTECT_UNWIND
-
-    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);
+namespace Rcpp {
 
-            throw internal::LongjumpException(token);
-        }
+#ifdef RCPP_USE_PROTECT_UNWIND
 
-        return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data,
-                                 internal::Rcpp_maybe_throw, &unwind_data,
-                                 token);
-    }
+inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
+    internal::EvalData data(expr, env);
+    return unwindProtect(&internal::Rcpp_protected_eval, &data);
+}
 
 #else
 
-    inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
-        return Rcpp_eval(expr, env);
-    }
+inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
+    return Rcpp_eval(expr, env);
+}
 
 #endif
 

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

@@ -0,0 +1,85 @@
+// unwind.h: Rcpp R/C++ interface class library -- Unwind Protect
+//
+// Copyright (C) 2018 RStudio
+//
+// This file is part of Rcpp.
+//
+// Rcpp is free software: you can redistribute it and/or modify it
+// under the terms of the GNU General Public License as published by
+// the Free Software Foundation, either version 2 of the License, or
+// (at your option) any later version.
+//
+// Rcpp is distributed in the hope that it will be useful, but
+// WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+// GNU General Public License for more details.
+//
+// You should have received a copy of the GNU General Public License
+// along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+#ifndef RCPP_API_MEAT_UNWIND_H
+#define RCPP_API_MEAT_UNWIND_H
+
+#include <csetjmp>
+
+#ifdef RCPP_USING_CXX11
+#include <functional>
+#endif
+
+
+namespace Rcpp { namespace internal {
+
+struct UnwindData {
+    std::jmp_buf jmpbuf;
+};
+
+// 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 maybeJump(void* unwind_data, Rboolean jump) {
+    if (jump) {
+        UnwindData* data = static_cast<UnwindData*>(unwind_data);
+        longjmp(data->jmpbuf, 1);
+    }
+}
+
+#ifdef RCPP_USING_CXX11
+inline SEXP unwindProtectUnwrap(void* data) {
+    std::function<SEXP(void)>* callback = (std::function<SEXP(void)>*) data;
+    return (*callback)();
+}
+#endif
+
+}} // namespace Rcpp::internal
+
+
+namespace Rcpp {
+
+inline SEXP unwindProtect(SEXP (*callback)(void* data), void* data) {
+    internal::UnwindData 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(callback, data,
+                             internal::maybeJump, &unwind_data,
+                             token);
+}
+
+#ifdef RCPP_USING_CXX11
+inline SEXP unwindProtect(std::function<SEXP(void)> callback) {
+    return unwindProtect(&internal::unwindProtectUnwrap, &callback);
+}
+#endif
+
+} // namespace Rcpp
+
+#endif

inst/unitTests/cpp/stack.cpp

@@ -51,3 +51,60 @@ SEXP testSendInterrupt() {
     Rf_onintr();
     return R_NilValue;
 }
+
+SEXP maybeThrow(void* data) {
+    bool* fail = (bool*) data;
+    if (*fail)
+        Rf_error("throw!");
+    else
+        return NumericVector::create(42);
+}
+
+// [[Rcpp::export]]
+SEXP testUnwindProtect(LogicalVector indicator, bool fail) {
+    unwindIndicator my_data(indicator);
+    SEXP out = R_NilValue;
+
+#if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)
+    out = Rcpp::unwindProtect(&maybeThrow, &fail);
+#endif
+    return out;
+}
+
+
+// [[Rcpp::plugins("cpp11")]]
+
+// [[Rcpp::export]]
+SEXP testUnwindProtectLambda(LogicalVector indicator, bool fail) {
+    unwindIndicator my_data(indicator);
+    SEXP out = R_NilValue;
+
+#if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)
+    out = Rcpp::unwindProtect([&] () { return maybeThrow(&fail); });
+#endif
+
+    return out;
+}
+
+struct FunctionObj {
+    FunctionObj(int data_, bool fail_) : data(data_), fail(fail_) { }
+    SEXP operator() () {
+        NumericVector x = maybeThrow(&fail);
+        x[0] = x[0] * data;
+        return x;
+    }
+    int data;
+    bool fail;
+};
+
+// [[Rcpp::export]]
+SEXP testUnwindProtectFunctionObject(LogicalVector indicator, bool fail) {
+    unwindIndicator my_data(indicator);
+    SEXP out = R_NilValue;
+
+#if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)
+    out = Rcpp::unwindProtect(FunctionObj(10, fail));
+#endif
+
+    return out;
+}

inst/unitTests/runit.stack.R

@@ -142,4 +142,31 @@ if (.runThisTest) {
         checkTrue(unwound2) # Always unwound
     }
 
+    test.unwindProtect <- function() {
+        if (hasUnwind) {
+            unwound <- FALSE
+            checkException(testUnwindProtect(unwound, fail = TRUE))
+            checkTrue(unwound)
+
+            unwound <- FALSE
+            checkException(testUnwindProtectLambda(unwound, fail = TRUE))
+            checkTrue(unwound)
+
+            unwound <- FALSE
+            checkException(testUnwindProtectFunctionObject(unwound, fail = TRUE))
+            checkTrue(unwound)
+
+            unwound <- FALSE
+            checkEquals(testUnwindProtect(unwound, fail = FALSE), 42)
+            checkTrue(unwound)
+
+            unwound <- FALSE
+            checkEquals(testUnwindProtectLambda(unwound, fail = FALSE), 42)
+            checkTrue(unwound)
+
+            unwound <- FALSE
+            checkEquals(testUnwindProtectFunctionObject(unwound, fail = FALSE), 420)
+            checkTrue(unwound)
+        }
+    }
 }