Support more efficient nesting of unwind_protect

inst/include/cpp11/protect.hpp

@@ -26,6 +26,48 @@ class unwind_exception : public std::exception {
   unwind_exception(SEXP token_) : token(token_) {}
 };
 
+namespace detail {
+// We deliberately avoid using safe[] in the below code, as this code runs
+// when the shared library is loaded and will not be wrapped by
+// `CPP11_UNWIND`, so if an error occurs we will not catch the C++ exception
+// that safe emits.
+inline void set_option(SEXP name, SEXP value) {
+  static SEXP opt = SYMVALUE(Rf_install(".Options"));
+  SEXP t = opt;
+  while (CDR(t) != R_NilValue) {
+    if (TAG(CDR(t)) == name) {
+      opt = CDR(t);
+      SET_TAG(opt, name);
+      SETCAR(opt, value);
+      return;
+    }
+    t = CDR(t);
+  }
+  SETCDR(t, Rf_allocList(1));
+  opt = CDR(t);
+  SET_TAG(opt, name);
+  SETCAR(opt, value);
+}
+
+inline Rboolean& get_should_unwind_protect() {
+  SEXP should_unwind_protect_sym = Rf_install("cpp11_should_unwind_protect");
+  SEXP should_unwind_protect_sexp = Rf_GetOption1(should_unwind_protect_sym);
+  if (should_unwind_protect_sexp == R_NilValue) {
+    should_unwind_protect_sexp = Rf_allocVector(LGLSXP, 1);
+    detail::set_option(should_unwind_protect_sym, should_unwind_protect_sexp);
+  }
+
+  Rboolean* should_unwind_protect =
+      reinterpret_cast<Rboolean*>(LOGICAL(should_unwind_protect_sexp));
+  should_unwind_protect[0] = TRUE;
+
+  return should_unwind_protect[0];
+}
+
+static Rboolean& should_unwind_protect = get_should_unwind_protect();
+
+}  // namespace detail
+
 #ifdef HAS_UNWIND_PROTECT
 
 /// Unwind Protection from C longjmp's, like those used in R error handling
@@ -34,6 +76,12 @@ class unwind_exception : public std::exception {
 template <typename Fun, typename = typename std::enable_if<std::is_same<
                             decltype(std::declval<Fun&&>()()), SEXP>::value>::type>
 SEXP unwind_protect(Fun&& code) {
+  if (detail::should_unwind_protect == FALSE) {
+    return std::forward<Fun>(code)();
+  }
+
+  detail::should_unwind_protect = FALSE;
+
   static SEXP token = [] {
     SEXP res = R_MakeUnwindCont();
     R_PreserveObject(res);
@@ -42,6 +90,7 @@ SEXP unwind_protect(Fun&& code) {
 
   std::jmp_buf jmpbuf;
   if (setjmp(jmpbuf)) {
+    detail::should_unwind_protect = TRUE;
     throw unwind_exception(token);
   }
 
@@ -53,8 +102,8 @@ SEXP unwind_protect(Fun&& code) {
       &code,
       [](void* jmpbuf, Rboolean jump) {
         if (jump == TRUE) {
-          // We need to first jump back into the C++ stacks because you can't safely throw
-          // exceptions from C stack frames.
+          // We need to first jump back into the C++ stacks because you can't safely
+          // throw exceptions from C stack frames.
           longjmp(*static_cast<std::jmp_buf*>(jmpbuf), 1);
         }
       },
@@ -66,6 +115,8 @@ SEXP unwind_protect(Fun&& code) {
   // unset it here before returning the value ourselves.
   SETCAR(token, R_NilValue);
 
+  detail::should_unwind_protect = TRUE;
+
   return res;
 }
 
@@ -296,28 +347,6 @@ static struct {
   }
 
  private:
-  // We deliberately avoid using safe[] in the below code, as this code runs
-  // when the shared library is loaded and will not be wrapped by
-  // `CPP11_UNWIND`, so if an error occurs we will not catch the C++ exception
-  // that safe emits.
-  static void set_option(SEXP name, SEXP value) {
-    static SEXP opt = SYMVALUE(Rf_install(".Options"));
-    SEXP t = opt;
-    while (CDR(t) != R_NilValue) {
-      if (TAG(CDR(t)) == name) {
-        opt = CDR(t);
-        SET_TAG(opt, name);
-        SETCAR(opt, value);
-        return;
-      }
-      t = CDR(t);
-    }
-    SETCDR(t, Rf_allocList(1));
-    opt = CDR(t);
-    SET_TAG(opt, name);
-    SETCAR(opt, value);
-  }
-
   // The list_ singleton is stored in a XPtr within an R global option.
   //
   // It is not constructed as a static variable directly since many
@@ -348,7 +377,7 @@ static struct {
     static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr");
 
     SEXP xptr = PROTECT(R_MakeExternalPtr(value, R_NilValue, R_NilValue));
-    set_option(preserve_xptr_sym, xptr);
+    detail::set_option(preserve_xptr_sym, xptr);
     UNPROTECT(1);
   }