diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 96345ead..f68a4a18 100644 --- a/inst/include/cpp11/protect.hpp +++ b/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(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 ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { + if (detail::should_unwind_protect == FALSE) { + return std::forward(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(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); }