From 40ec0a7c491a82d5366c5a2aa8f7bbc02e404cf1 Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Mon, 19 Jul 2021 12:08:15 -0400 Subject: [PATCH 1/6] Support more efficient nesting of unwind_protect The internal protection can be skipped if we are already in an unwind_protect call. Fixes #141 --- inst/include/cpp11/protect.hpp | 342 ++++++++++++++++++--------------- 1 file changed, 184 insertions(+), 158 deletions(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 96345ead..9b1d1507 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -26,6 +26,179 @@ class unwind_exception : public std::exception { unwind_exception(SEXP token_) : token(token_) {} }; +/// A doubly-linked list of preserved objects, allowing O(1) insertion/release of +/// objects compared to O(N preserved) with R_PreserveObject. +static struct { + SEXP insert(SEXP obj) { + if (obj == R_NilValue) { + return R_NilValue; + } + +#ifdef CPP11_USE_PRESERVE_OBJECT + PROTECT(obj); + R_PreserveObject(obj); + UNPROTECT(1); + return obj; +#endif + + PROTECT(obj); + + if (TYPEOF(list_) != LISTSXP) { + list_ = get_preserve_list(); + } + + // Add a new cell that points to the previous end. + SEXP cell = PROTECT(Rf_cons(list_, CDR(list_))); + + SET_TAG(cell, obj); + + SETCDR(list_, cell); + + if (CDR(cell) != R_NilValue) { + SETCAR(CDR(cell), cell); + } + + UNPROTECT(2); + + return cell; + } + + void print() { + for (SEXP head = list_; head != R_NilValue; head = CDR(head)) { + REprintf("%x CAR: %x CDR: %x TAG: %x\n", head, CAR(head), CDR(head), TAG(head)); + } + REprintf("---\n"); + } + + // This is currently unused, but client packages could use it to free leaked resources + // in older R versions if needed + void release_all() { +#if !defined(CPP11_USE_PRESERVE_OBJECT) + SEXP first = CDR(list_); + if (first != R_NilValue) { + SETCAR(first, R_NilValue); + SETCDR(list_, R_NilValue); + } +#endif + } + + void release(SEXP token) { + if (token == R_NilValue) { + return; + } + +#ifdef CPP11_USE_PRESERVE_OBJECT + R_ReleaseObject(token); + return; +#endif + + SEXP before = CAR(token); + + SEXP after = CDR(token); + + if (before == R_NilValue && after == R_NilValue) { + Rf_error("should never happen"); + } + + SETCDR(before, after); + + if (after != R_NilValue) { + SETCAR(after, before); + } + } + + 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 + // translation units may be compiled, resulting in unrelated instances of each + // static variable. + // + // We cannot store it in the cpp11 namespace, as cpp11 likely will not be loaded by + // packages. + // We cannot store it in R's global environment, as that is against CRAN + // policies. + // We instead store it as an XPtr in the global options, which avoids issues + // both copying and serializing. + static SEXP get_preserve_xptr_addr() { + static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr"); + SEXP preserve_xptr = Rf_GetOption1(preserve_xptr_sym); + + if (TYPEOF(preserve_xptr) != EXTPTRSXP) { + return R_NilValue; + } + auto addr = R_ExternalPtrAddr(preserve_xptr); + if (addr == nullptr) { + return R_NilValue; + } + return static_cast(addr); + } + + static void set_preserve_xptr(SEXP value) { + 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); + UNPROTECT(1); + } + + static SEXP get_preserve_list() { + static SEXP preserve_list = R_NilValue; + + if (TYPEOF(preserve_list) != LISTSXP) { + preserve_list = get_preserve_xptr_addr(); + if (TYPEOF(preserve_list) != LISTSXP) { + preserve_list = Rf_cons(R_NilValue, R_NilValue); + R_PreserveObject(preserve_list); + set_preserve_xptr(preserve_list); + } + } + + return preserve_list; + } + + static int* get_should_unwind_protect() { + static int* should_unwind_protect = nullptr; + + if (should_unwind_protect == nullptr) { + SEXP should_unwind_protect_sexp = Rf_allocVector(LGLSXP, 1); + R_PreserveObject(should_unwind_protect_sexp); + should_unwind_protect = LOGICAL(should_unwind_protect_sexp); + should_unwind_protect[0] = TRUE; + } + + return &should_unwind_protect[0]; + } + + SEXP list_ = get_preserve_list(); + + public: + int* should_unwind_protect_ = get_should_unwind_protect(); +} // namespace cpp11 +preserved; + #ifdef HAS_UNWIND_PROTECT /// Unwind Protection from C longjmp's, like those used in R error handling @@ -34,6 +207,12 @@ class unwind_exception : public std::exception { template ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { + if (*preserved.should_unwind_protect_ == FALSE) { + return std::forward(code)(); + } + + *preserved.should_unwind_protect_ = FALSE; + static SEXP token = [] { SEXP res = R_MakeUnwindCont(); R_PreserveObject(res); @@ -42,6 +221,7 @@ SEXP unwind_protect(Fun&& code) { std::jmp_buf jmpbuf; if (setjmp(jmpbuf)) { + *preserved.should_unwind_protect_ = TRUE; throw unwind_exception(token); } @@ -53,8 +233,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 +246,8 @@ SEXP unwind_protect(Fun&& code) { // unset it here before returning the value ourselves. SETCAR(token, R_NilValue); + *preserved.should_unwind_protect_ = TRUE; + return res; } @@ -214,160 +396,4 @@ void warning(const std::string& fmt, Args... args) { safe[Rf_warningcall](R_NilValue, fmt.c_str(), args...); } -/// A doubly-linked list of preserved objects, allowing O(1) insertion/release of -/// objects compared to O(N preserved) with R_PreserveObject. -static struct { - SEXP insert(SEXP obj) { - if (obj == R_NilValue) { - return R_NilValue; - } - -#ifdef CPP11_USE_PRESERVE_OBJECT - PROTECT(obj); - R_PreserveObject(obj); - UNPROTECT(1); - return obj; -#endif - - PROTECT(obj); - - if (TYPEOF(list_) != LISTSXP) { - list_ = get_preserve_list(); - } - - // Add a new cell that points to the previous end. - SEXP cell = PROTECT(Rf_cons(list_, CDR(list_))); - - SET_TAG(cell, obj); - - SETCDR(list_, cell); - - if (CDR(cell) != R_NilValue) { - SETCAR(CDR(cell), cell); - } - - UNPROTECT(2); - - return cell; - } - - void print() { - for (SEXP head = list_; head != R_NilValue; head = CDR(head)) { - REprintf("%x CAR: %x CDR: %x TAG: %x\n", head, CAR(head), CDR(head), TAG(head)); - } - REprintf("---\n"); - } - - // This is currently unused, but client packages could use it to free leaked resources - // in older R versions if needed - void release_all() { -#if !defined(CPP11_USE_PRESERVE_OBJECT) - SEXP first = CDR(list_); - if (first != R_NilValue) { - SETCAR(first, R_NilValue); - SETCDR(list_, R_NilValue); - } -#endif - } - - void release(SEXP token) { - if (token == R_NilValue) { - return; - } - -#ifdef CPP11_USE_PRESERVE_OBJECT - R_ReleaseObject(token); - return; -#endif - - SEXP before = CAR(token); - - SEXP after = CDR(token); - - if (before == R_NilValue && after == R_NilValue) { - Rf_error("should never happen"); - } - - SETCDR(before, after); - - if (after != R_NilValue) { - SETCAR(after, before); - } - } - - 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 - // translation units may be compiled, resulting in unrelated instances of each - // static variable. - // - // We cannot store it in the cpp11 namespace, as cpp11 likely will not be loaded by - // packages. - // We cannot store it in R's global environment, as that is against CRAN - // policies. - // We instead store it as an XPtr in the global options, which avoids issues - // both copying and serializing. - static SEXP get_preserve_xptr_addr() { - static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr"); - SEXP preserve_xptr = Rf_GetOption1(preserve_xptr_sym); - - if (TYPEOF(preserve_xptr) != EXTPTRSXP) { - return R_NilValue; - } - auto addr = R_ExternalPtrAddr(preserve_xptr); - if (addr == nullptr) { - return R_NilValue; - } - return static_cast(addr); - } - - static void set_preserve_xptr(SEXP value) { - 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); - UNPROTECT(1); - } - - static SEXP get_preserve_list() { - static SEXP preserve_list = R_NilValue; - - if (TYPEOF(preserve_list) != LISTSXP) { - preserve_list = get_preserve_xptr_addr(); - if (TYPEOF(preserve_list) != LISTSXP) { - preserve_list = Rf_cons(R_NilValue, R_NilValue); - R_PreserveObject(preserve_list); - set_preserve_xptr(preserve_list); - } - } - - return preserve_list; - } - - SEXP list_ = get_preserve_list(); -} // namespace cpp11 -preserved; } // namespace cpp11 From 620bd176b1d7ef5451b2c583ae263b5c18b37597 Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Mon, 19 Jul 2021 15:59:13 -0400 Subject: [PATCH 2/6] Lookup the should_protect option from a global option --- inst/include/cpp11/protect.hpp | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 9b1d1507..61ccbe03 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -183,8 +183,12 @@ static struct { static int* should_unwind_protect = nullptr; if (should_unwind_protect == nullptr) { - SEXP should_unwind_protect_sexp = Rf_allocVector(LGLSXP, 1); - R_PreserveObject(should_unwind_protect_sexp); + 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); + set_option(should_unwind_protect_sym, should_unwind_protect_sexp); + } should_unwind_protect = LOGICAL(should_unwind_protect_sexp); should_unwind_protect[0] = TRUE; } @@ -207,6 +211,7 @@ preserved; template ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { + REprintf("%s\n", *preserved.should_unwind_protect_ == TRUE ? "TRUE" : "FALSE"); if (*preserved.should_unwind_protect_ == FALSE) { return std::forward(code)(); } From b50bb37e686f3890f5abeb88321e8854322c823c Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Tue, 20 Jul 2021 08:43:12 -0400 Subject: [PATCH 3/6] Do not put the should_unwind_protect flag in the protected struct --- inst/include/cpp11/protect.hpp | 344 +++++++++++++++++---------------- 1 file changed, 173 insertions(+), 171 deletions(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 61ccbe03..b020578c 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -26,182 +26,49 @@ class unwind_exception : public std::exception { unwind_exception(SEXP token_) : token(token_) {} }; -/// A doubly-linked list of preserved objects, allowing O(1) insertion/release of -/// objects compared to O(N preserved) with R_PreserveObject. -static struct { - SEXP insert(SEXP obj) { - if (obj == R_NilValue) { - return R_NilValue; - } - -#ifdef CPP11_USE_PRESERVE_OBJECT - PROTECT(obj); - R_PreserveObject(obj); - UNPROTECT(1); - return obj; -#endif - - PROTECT(obj); - - if (TYPEOF(list_) != LISTSXP) { - list_ = get_preserve_list(); - } - - // Add a new cell that points to the previous end. - SEXP cell = PROTECT(Rf_cons(list_, CDR(list_))); - - SET_TAG(cell, obj); - - SETCDR(list_, cell); - - if (CDR(cell) != R_NilValue) { - SETCAR(CDR(cell), cell); - } - - UNPROTECT(2); - - return cell; - } - - void print() { - for (SEXP head = list_; head != R_NilValue; head = CDR(head)) { - REprintf("%x CAR: %x CDR: %x TAG: %x\n", head, CAR(head), CDR(head), TAG(head)); - } - REprintf("---\n"); - } - - // This is currently unused, but client packages could use it to free leaked resources - // in older R versions if needed - void release_all() { -#if !defined(CPP11_USE_PRESERVE_OBJECT) - SEXP first = CDR(list_); - if (first != R_NilValue) { - SETCAR(first, R_NilValue); - SETCDR(list_, R_NilValue); - } -#endif - } - - void release(SEXP token) { - if (token == R_NilValue) { +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; } - -#ifdef CPP11_USE_PRESERVE_OBJECT - R_ReleaseObject(token); - return; -#endif - - SEXP before = CAR(token); - - SEXP after = CDR(token); - - if (before == R_NilValue && after == R_NilValue) { - Rf_error("should never happen"); - } - - SETCDR(before, after); - - if (after != R_NilValue) { - SETCAR(after, before); - } - } - - 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 - // translation units may be compiled, resulting in unrelated instances of each - // static variable. - // - // We cannot store it in the cpp11 namespace, as cpp11 likely will not be loaded by - // packages. - // We cannot store it in R's global environment, as that is against CRAN - // policies. - // We instead store it as an XPtr in the global options, which avoids issues - // both copying and serializing. - static SEXP get_preserve_xptr_addr() { - static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr"); - SEXP preserve_xptr = Rf_GetOption1(preserve_xptr_sym); - - if (TYPEOF(preserve_xptr) != EXTPTRSXP) { - return R_NilValue; - } - auto addr = R_ExternalPtrAddr(preserve_xptr); - if (addr == nullptr) { - return R_NilValue; - } - return static_cast(addr); - } - - static void set_preserve_xptr(SEXP value) { - 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); - UNPROTECT(1); + t = CDR(t); } + SETCDR(t, Rf_allocList(1)); + opt = CDR(t); + SET_TAG(opt, name); + SETCAR(opt, value); +} - static SEXP get_preserve_list() { - static SEXP preserve_list = R_NilValue; +static int* get_should_unwind_protect() { + static int* should_unwind_protect = nullptr; - if (TYPEOF(preserve_list) != LISTSXP) { - preserve_list = get_preserve_xptr_addr(); - if (TYPEOF(preserve_list) != LISTSXP) { - preserve_list = Rf_cons(R_NilValue, R_NilValue); - R_PreserveObject(preserve_list); - set_preserve_xptr(preserve_list); - } + if (should_unwind_protect == nullptr) { + 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); } - - return preserve_list; + should_unwind_protect = LOGICAL(should_unwind_protect_sexp); + should_unwind_protect[0] = TRUE; } - static int* get_should_unwind_protect() { - static int* should_unwind_protect = nullptr; - - if (should_unwind_protect == nullptr) { - 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); - set_option(should_unwind_protect_sym, should_unwind_protect_sexp); - } - should_unwind_protect = LOGICAL(should_unwind_protect_sexp); - should_unwind_protect[0] = TRUE; - } - - return &should_unwind_protect[0]; - } + return &should_unwind_protect[0]; +} - SEXP list_ = get_preserve_list(); +static int* should_unwind_protect = get_should_unwind_protect(); - public: - int* should_unwind_protect_ = get_should_unwind_protect(); -} // namespace cpp11 -preserved; +} // namespace detail #ifdef HAS_UNWIND_PROTECT @@ -211,12 +78,12 @@ preserved; template ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { - REprintf("%s\n", *preserved.should_unwind_protect_ == TRUE ? "TRUE" : "FALSE"); - if (*preserved.should_unwind_protect_ == FALSE) { + REprintf("%s\n", *detail::should_unwind_protect == TRUE ? "TRUE" : "FALSE"); + if (*detail::should_unwind_protect == FALSE) { return std::forward(code)(); } - *preserved.should_unwind_protect_ = FALSE; + *detail::should_unwind_protect = FALSE; static SEXP token = [] { SEXP res = R_MakeUnwindCont(); @@ -226,7 +93,7 @@ SEXP unwind_protect(Fun&& code) { std::jmp_buf jmpbuf; if (setjmp(jmpbuf)) { - *preserved.should_unwind_protect_ = TRUE; + *detail::should_unwind_protect = TRUE; throw unwind_exception(token); } @@ -251,7 +118,7 @@ SEXP unwind_protect(Fun&& code) { // unset it here before returning the value ourselves. SETCAR(token, R_NilValue); - *preserved.should_unwind_protect_ = TRUE; + *detail::should_unwind_protect = TRUE; return res; } @@ -401,4 +268,139 @@ void warning(const std::string& fmt, Args... args) { safe[Rf_warningcall](R_NilValue, fmt.c_str(), args...); } +/// A doubly-linked list of preserved objects, allowing O(1) insertion/release of +/// objects compared to O(N preserved) with R_PreserveObject. +static struct { + SEXP insert(SEXP obj) { + if (obj == R_NilValue) { + return R_NilValue; + } + +#ifdef CPP11_USE_PRESERVE_OBJECT + PROTECT(obj); + R_PreserveObject(obj); + UNPROTECT(1); + return obj; +#endif + + PROTECT(obj); + + if (TYPEOF(list_) != LISTSXP) { + list_ = get_preserve_list(); + } + + // Add a new cell that points to the previous end. + SEXP cell = PROTECT(Rf_cons(list_, CDR(list_))); + + SET_TAG(cell, obj); + + SETCDR(list_, cell); + + if (CDR(cell) != R_NilValue) { + SETCAR(CDR(cell), cell); + } + + UNPROTECT(2); + + return cell; + } + + void print() { + for (SEXP head = list_; head != R_NilValue; head = CDR(head)) { + REprintf("%x CAR: %x CDR: %x TAG: %x\n", head, CAR(head), CDR(head), TAG(head)); + } + REprintf("---\n"); + } + + // This is currently unused, but client packages could use it to free leaked resources + // in older R versions if needed + void release_all() { +#if !defined(CPP11_USE_PRESERVE_OBJECT) + SEXP first = CDR(list_); + if (first != R_NilValue) { + SETCAR(first, R_NilValue); + SETCDR(list_, R_NilValue); + } +#endif + } + + void release(SEXP token) { + if (token == R_NilValue) { + return; + } + +#ifdef CPP11_USE_PRESERVE_OBJECT + R_ReleaseObject(token); + return; +#endif + + SEXP before = CAR(token); + + SEXP after = CDR(token); + + if (before == R_NilValue && after == R_NilValue) { + Rf_error("should never happen"); + } + + SETCDR(before, after); + + if (after != R_NilValue) { + SETCAR(after, before); + } + } + + private: + // The list_ singleton is stored in a XPtr within an R global option. + // + // It is not constructed as a static variable directly since many + // translation units may be compiled, resulting in unrelated instances of each + // static variable. + // + // We cannot store it in the cpp11 namespace, as cpp11 likely will not be loaded by + // packages. + // We cannot store it in R's global environment, as that is against CRAN + // policies. + // We instead store it as an XPtr in the global options, which avoids issues + // both copying and serializing. + static SEXP get_preserve_xptr_addr() { + static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr"); + SEXP preserve_xptr = Rf_GetOption1(preserve_xptr_sym); + + if (TYPEOF(preserve_xptr) != EXTPTRSXP) { + return R_NilValue; + } + auto addr = R_ExternalPtrAddr(preserve_xptr); + if (addr == nullptr) { + return R_NilValue; + } + return static_cast(addr); + } + + static void set_preserve_xptr(SEXP value) { + static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr"); + + SEXP xptr = PROTECT(R_MakeExternalPtr(value, R_NilValue, R_NilValue)); + detail::set_option(preserve_xptr_sym, xptr); + UNPROTECT(1); + } + + static SEXP get_preserve_list() { + static SEXP preserve_list = R_NilValue; + + if (TYPEOF(preserve_list) != LISTSXP) { + preserve_list = get_preserve_xptr_addr(); + if (TYPEOF(preserve_list) != LISTSXP) { + preserve_list = Rf_cons(R_NilValue, R_NilValue); + R_PreserveObject(preserve_list); + set_preserve_xptr(preserve_list); + } + } + + return preserve_list; + } + + SEXP list_ = get_preserve_list(); +} // namespace cpp11 +preserved; + } // namespace cpp11 From a451c1a2d68ee1cce041b934c2b10e093b64f6e0 Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Tue, 20 Jul 2021 08:48:36 -0400 Subject: [PATCH 4/6] Remove debugging code --- inst/include/cpp11/protect.hpp | 1 - 1 file changed, 1 deletion(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index b020578c..1e4f603b 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -78,7 +78,6 @@ static int* should_unwind_protect = get_should_unwind_protect(); template ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { - REprintf("%s\n", *detail::should_unwind_protect == TRUE ? "TRUE" : "FALSE"); if (*detail::should_unwind_protect == FALSE) { return std::forward(code)(); } From 9b9be8c488f0d5bf58e8a153256b28aba3f33935 Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Tue, 20 Jul 2021 09:08:07 -0400 Subject: [PATCH 5/6] Use a reference rather than a pointer Cleans up the user code a bit --- inst/include/cpp11/protect.hpp | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 1e4f603b..9e376ed5 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -49,24 +49,22 @@ inline void set_option(SEXP name, SEXP value) { SETCAR(opt, value); } -static int* get_should_unwind_protect() { - static int* should_unwind_protect = nullptr; - - if (should_unwind_protect == nullptr) { - 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); - } - should_unwind_protect = LOGICAL(should_unwind_protect_sexp); - should_unwind_protect[0] = TRUE; +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); } - return &should_unwind_protect[0]; + Rboolean* should_unwind_protect = + reinterpret_cast(LOGICAL(should_unwind_protect_sexp)); + should_unwind_protect[0] = TRUE; + + return should_unwind_protect[0]; } -static int* should_unwind_protect = get_should_unwind_protect(); +static Rboolean& should_unwind_protect = get_should_unwind_protect(); } // namespace detail @@ -78,11 +76,11 @@ static int* should_unwind_protect = get_should_unwind_protect(); template ()()), SEXP>::value>::type> SEXP unwind_protect(Fun&& code) { - if (*detail::should_unwind_protect == FALSE) { + if (detail::should_unwind_protect == FALSE) { return std::forward(code)(); } - *detail::should_unwind_protect = FALSE; + detail::should_unwind_protect = FALSE; static SEXP token = [] { SEXP res = R_MakeUnwindCont(); @@ -92,7 +90,7 @@ SEXP unwind_protect(Fun&& code) { std::jmp_buf jmpbuf; if (setjmp(jmpbuf)) { - *detail::should_unwind_protect = TRUE; + detail::should_unwind_protect = TRUE; throw unwind_exception(token); } @@ -117,7 +115,7 @@ SEXP unwind_protect(Fun&& code) { // unset it here before returning the value ourselves. SETCAR(token, R_NilValue); - *detail::should_unwind_protect = TRUE; + detail::should_unwind_protect = TRUE; return res; } From 5a38c266cabefd7a4a5d8263e848ff680710610a Mon Sep 17 00:00:00 2001 From: Jim Hester Date: Tue, 20 Jul 2021 09:09:34 -0400 Subject: [PATCH 6/6] Whitespace --- inst/include/cpp11/protect.hpp | 1 - 1 file changed, 1 deletion(-) diff --git a/inst/include/cpp11/protect.hpp b/inst/include/cpp11/protect.hpp index 9e376ed5..f68a4a18 100644 --- a/inst/include/cpp11/protect.hpp +++ b/inst/include/cpp11/protect.hpp @@ -399,5 +399,4 @@ static struct { SEXP list_ = get_preserve_list(); } // namespace cpp11 preserved; - } // namespace cpp11