From c7ac808fa46444596dd9cdf47b03a86347155d23 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Wed, 30 May 2018 12:08:14 +0200 Subject: [PATCH 01/13] Revert "shielding #789 behind a new #define to effectively disable it now" This reverts commit 81c8339884b3703b52dbd16489d8f7d56a9e511c. --- ChangeLog | 32 ++++++++++++++++++ inst/include/Rcpp/Environment.h | 24 +++----------- inst/include/Rcpp/Language.h | 10 +----- inst/include/Rcpp/api/meat/Rcpp_eval.h | 20 +++-------- inst/include/Rcpp/exceptions.h | 2 -- inst/include/Rcpp/macros/macros.h | 46 +------------------------- inst/include/RcppCommon.h | 12 +------ inst/unitTests/runit.stack.R | 6 ---- 8 files changed, 43 insertions(+), 109 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1037e503e..55b9cdc9a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,35 @@ + +2018-05-31 Lionel Henry + + * inst/include/Rcpp/api/meat/Rcpp_eval.h: Unguard Rcpp_fast_eval(). + + Unlike Rcpp_eval(), Rcpp_fast_eval() 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 under the hood in order to + gain safety. It is fully backward-compatibile and still catches errors + and interrupts to rethrow them as typed C++ exceptions. If you don't + need to catch those, consider using Rcpp_fast_eval() instead to avoid + the catching 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 Rcpp_fast_eval() behaves a bit differently to Rcpp_eval(). The + former has the semantics of the C function Rf_eval() whereas the latter + behaves like the R function base::eval(). This has subtle implications + for control flow. For instance evaluating a return() expression within a + frame environment returns from that frame rather than from the + Rcpp_eval() call. + 2018-05-09 Dirk Eddelbuettel * DESCRIPTION: Release 0.12.17 diff --git a/inst/include/Rcpp/Environment.h b/inst/include/Rcpp/Environment.h index f231649a3..b7ebbb56c 100644 --- a/inst/include/Rcpp/Environment.h +++ b/inst/include/Rcpp/Environment.h @@ -109,11 +109,7 @@ namespace Rcpp{ /* We need to evaluate if it is a promise */ if( TYPEOF(res) == PROMSXP){ -#if defined(RCPP_USE_UNWIND_PROTECT) - res = internal::Rcpp_eval_impl(res, env); -#else - res = Rf_eval(res, env); -#endif + res = internal::Rcpp_eval_impl( res, env ) ; } return res ; } @@ -133,11 +129,7 @@ namespace Rcpp{ /* We need to evaluate if it is a promise */ if( TYPEOF(res) == PROMSXP){ -#if defined(RCPP_USE_UNWIND_PROTECT) - res = internal::Rcpp_eval_impl(res, env); -#else - res = Rf_eval(res, env); -#endif + res = internal::Rcpp_eval_impl( res, env ) ; } return res ; } @@ -159,11 +151,7 @@ namespace Rcpp{ /* We need to evaluate if it is a promise */ if( TYPEOF(res) == PROMSXP){ -#if defined(RCPP_USE_UNWIND_PROTECT) - res = internal::Rcpp_eval_impl(res, env); -#else - res = Rf_eval(res, env); -#endif + res = internal::Rcpp_eval_impl( res, env ) ; } return res ; } @@ -186,11 +174,7 @@ namespace Rcpp{ /* We need to evaluate if it is a promise */ if( TYPEOF(res) == PROMSXP){ -#if defined(RCPP_USE_UNWIND_PROTECT) - res = internal::Rcpp_eval_impl(res, env); -#else - res = Rf_eval(res, env); -#endif + res = internal::Rcpp_eval_impl( res, env ) ; } return res ; } diff --git a/inst/include/Rcpp/Language.h b/inst/include/Rcpp/Language.h index fddb4d326..34be7eaa7 100644 --- a/inst/include/Rcpp/Language.h +++ b/inst/include/Rcpp/Language.h @@ -145,18 +145,10 @@ namespace Rcpp{ } SEXP fast_eval() const { -#if defined(RCPP_USE_UNWIND_PROTECT) - return internal::Rcpp_eval_impl( Storage::get__(), R_GlobalEnv); -#else - return Rf_eval(Storage::get__(), R_GlobalEnv); -#endif + return internal::Rcpp_eval_impl( Storage::get__(), R_GlobalEnv) ; } SEXP fast_eval(SEXP env ) const { -#if defined(RCPP_USE_UNWIND_PROTECT) return internal::Rcpp_eval_impl( Storage::get__(), env) ; -#else - return Rf_eval(Storage::get__(), env); -#endif } void update( SEXP x){ diff --git a/inst/include/Rcpp/api/meat/Rcpp_eval.h b/inst/include/Rcpp/api/meat/Rcpp_eval.h index 68c3ba9f5..2ec54a51b 100644 --- a/inst/include/Rcpp/api/meat/Rcpp_eval.h +++ b/inst/include/Rcpp/api/meat/Rcpp_eval.h @@ -21,14 +21,11 @@ #include #include -// outer definition from RcppCommon.h -#if defined(RCPP_USE_UNWIND_PROTECT) - #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) - // file-local and only used here - #define RCPP_USE_PROTECT_UNWIND - #endif +#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 { @@ -112,11 +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")); -#if defined(RCPP_USE_UNWIND_PROTECT) - Shield res(::Rf_eval(call, R_GlobalEnv)) // execute the call -#else Shield res(internal::Rcpp_eval_impl(call, R_GlobalEnv)); -#endif // check for condition results (errors, interrupts) if (Rf_inherits(res, "condition")) { @@ -125,12 +118,7 @@ inline SEXP Rcpp_eval(SEXP expr, SEXP env) { Shield conditionMessageCall(::Rf_lang2(::Rf_install("conditionMessage"), res)); -#if defined(RCPP_USE_UNWIND_PROTECT) - Shield conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall, - R_GlobalEnv)); -#else - Shield conditionMessage(::Rf_eval(conditionMessageCall, R_GlobalEnv)); -#endif + Shield conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall, R_GlobalEnv)); throw eval_error(CHAR(STRING_ELT(conditionMessage, 0))); } diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h index ba623f4bb..a01297f9a 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -111,7 +111,6 @@ namespace Rcpp { throw Rcpp::exception(message.c_str()); } // #nocov end -#if defined(RCPP_USE_UNWIND_PROTECT) namespace internal { struct LongjumpException { @@ -127,7 +126,6 @@ namespace Rcpp { } } // namespace internal -#endif } // namespace Rcpp diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h index 3b07052fc..44a4d9d6f 100644 --- a/inst/include/Rcpp/macros/macros.h +++ b/inst/include/Rcpp/macros/macros.h @@ -36,8 +36,7 @@ #endif #ifndef VOID_END_RCPP -// longer form with Rcpp::internal::LongjumpException first, alternate below #else -#if defined(RCPP_USE_UNWIND_PROTECT) +#define VOID_END_RCPP \ } \ catch( Rcpp::internal::InterruptedException &__ex__) { \ rcpp_output_type = 1 ; \ @@ -67,33 +66,6 @@ SEXP expr = PROTECT( Rf_lang2( stop_sym , rcpp_output_condition ) ) ; \ Rf_eval( expr, R_GlobalEnv ) ; \ } -#else -#define VOID_END_RCPP \ - } \ - catch( Rcpp::internal::InterruptedException &__ex__) { \ - rcpp_output_type = 1 ; \ - } \ - catch(Rcpp::exception& __ex__) { \ - rcpp_output_type = 2 ; \ - rcpp_output_condition = PROTECT(rcpp_exception_to_r_condition(__ex__)) ; \ - } \ - catch( std::exception& __ex__ ){ \ - rcpp_output_type = 2 ; \ - rcpp_output_condition = PROTECT(exception_to_r_condition(__ex__)) ; \ - } \ - catch( ... ){ \ - rcpp_output_type = 2 ; \ - rcpp_output_condition = PROTECT(string_to_try_error("c++ exception (unknown reason)")) ; \ - } \ - if( rcpp_output_type == 1 ){ \ - Rf_onintr() ; \ - } \ - if( rcpp_output_type == 2 ){ \ - SEXP stop_sym = Rf_install( "stop" ) ; \ - SEXP expr = PROTECT( Rf_lang2( stop_sym , rcpp_output_condition ) ) ; \ - Rf_eval( expr, R_GlobalEnv ) ; \ - } -#endif #endif #ifndef END_RCPP @@ -101,8 +73,6 @@ #endif #ifndef END_RCPP_RETURN_ERROR -// longer form with Rcpp::internal::LongjumpException first, alternate below #else -#if defined(RCPP_USE_UNWIND_PROTECT) #define END_RCPP_RETURN_ERROR \ } \ catch (Rcpp::internal::InterruptedException &__ex__) { \ @@ -119,20 +89,6 @@ return string_to_try_error("c++ exception (unknown reason)"); \ } \ return R_NilValue; -#else -#define END_RCPP_RETURN_ERROR \ - } \ - catch (Rcpp::internal::InterruptedException &__ex__) { \ - return Rcpp::internal::interruptedError(); \ - } \ - catch (std::exception &__ex__) { \ - return exception_to_try_error(__ex__); \ - } \ - catch (...) { \ - return string_to_try_error("c++ exception (unknown reason)"); \ - } \ - return R_NilValue; -#endif #endif #define Rcpp_error(MESSAGE) throw Rcpp::exception(MESSAGE, __FILE__, __LINE__) diff --git a/inst/include/RcppCommon.h b/inst/include/RcppCommon.h index 48fd55c74..fac9fbf36 100644 --- a/inst/include/RcppCommon.h +++ b/inst/include/RcppCommon.h @@ -26,15 +26,6 @@ // #define RCPP_DEBUG_LEVEL 1 // #define RCPP_DEBUG_MODULE_LEVEL 1 -// PR #798 by Lionel seems to have created some side-effects possibly related to -// UnwinProtect is currently implement in R-devel. This #define needs to be set to -// enable it, in most cases you want to be disabled. -// #define RCPP_USE_UNWIND_PROTECT 1 -// so here _explicitly_ disable it for now -#ifdef RCPP_USE_UNWIND_PROTECT - #undef RCPP_USE_UNWIND_PROTECT -#endif - #include /** @@ -83,10 +74,9 @@ namespace Rcpp { namespace Rcpp { + SEXP Rcpp_fast_eval(SEXP expr_, SEXP env = R_GlobalEnv); SEXP Rcpp_eval(SEXP expr_, SEXP env = R_GlobalEnv); - // from PR#789 - SEXP Rcpp_fast_eval(SEXP expr_, SEXP env = R_GlobalEnv); namespace internal { SEXP Rcpp_eval_impl(SEXP expr, SEXP env = R_GlobalEnv); } diff --git a/inst/unitTests/runit.stack.R b/inst/unitTests/runit.stack.R index 3e72689b7..f363d350e 100644 --- a/inst/unitTests/runit.stack.R +++ b/inst/unitTests/runit.stack.R @@ -18,12 +18,6 @@ # along with Rcpp. If not, see . .runThisTest <- Sys.getenv("RunAllRcppTests") == "yes" -.onLinux <- .Platform$OS.type == "unix" && unname(Sys.info()["sysname"]) == "Linux" - -## As of release 0.12.15, the stack unwinding is experimental and not used -## See the #define in RcppCommon.h to change it - -.runThisTest <- FALSE if (.runThisTest) { From f32e0e56027dc8c46a3592a9f49af0e9c3c83629 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Wed, 30 May 2018 12:14:31 +0200 Subject: [PATCH 02/13] Don't check interrupts on Windows --- inst/unitTests/runit.stack.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/inst/unitTests/runit.stack.R b/inst/unitTests/runit.stack.R index f363d350e..3d8045fe9 100644 --- a/inst/unitTests/runit.stack.R +++ b/inst/unitTests/runit.stack.R @@ -42,6 +42,9 @@ if (.runThisTest) { } test.stackUnwindsOnInterrupts <- function() { + if (.Platform$OS.type == "windows") { + return(NULL) + } unwound <- FALSE expr <- quote({ repeat testSendInterrupt() From f226bb73e81c308f95b7308e2ff57d187898524b Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Wed, 30 May 2018 18:06:09 +0200 Subject: [PATCH 03/13] Jump back to C++ context with a longjmp before unwinding --- inst/include/Rcpp/api/meat/Rcpp_eval.h | 32 ++++++++++++++++++-------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/inst/include/Rcpp/api/meat/Rcpp_eval.h b/inst/include/Rcpp/api/meat/Rcpp_eval.h index 2ec54a51b..8ae74d96d 100644 --- a/inst/include/Rcpp/api/meat/Rcpp_eval.h +++ b/inst/include/Rcpp/api/meat/Rcpp_eval.h @@ -23,6 +23,7 @@ #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) #define RCPP_USE_PROTECT_UNWIND +#include #endif @@ -31,23 +32,25 @@ namespace internal { #ifdef RCPP_USE_PROTECT_UNWIND + // Store the jump buffer as a static variable in function scope + // because inline variables are a C++17 extension. + inline std::jmp_buf* get_jmpbuf_ptr() { + static std::jmp_buf jmpbuf; + return &jmpbuf; + } + struct EvalData { SEXP expr; SEXP env; EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { } }; + // 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* data, Rboolean jump) { if (jump) { - SEXP token = static_cast(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 is on the stack. - ::R_PreserveObject(token); - - throw LongjumpException(token); + longjmp(*internal::get_jmpbuf_ptr(), 1); } } @@ -78,6 +81,17 @@ namespace internal { inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) { internal::EvalData data(expr, env); Shield token(::R_MakeUnwindCont()); + + if (setjmp(*internal::get_jmpbuf_ptr())) { + // 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 is on the stack. + ::R_PreserveObject(token); + + throw internal::LongjumpException(token); + } + return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data, internal::Rcpp_maybe_throw, token, token); From d8999d8f2c880a8628ece197b4a5c1e873eca10e Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Wed, 30 May 2018 21:46:40 +0200 Subject: [PATCH 04/13] Leave catching context before resuming jump So the exception object can be destructed properly --- ChangeLog | 3 +++ inst/include/Rcpp/macros/macros.h | 20 +++++++++++++++----- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 55b9cdc9a..76bf116d8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -30,6 +30,9 @@ frame environment returns from that frame rather than from the Rcpp_eval() call. + * inst/include/Rcpp/macros/macros.h: Leave the try/catch scope before + resuming jump to ensure proper destruction of the exception reference. + 2018-05-09 Dirk Eddelbuettel * DESCRIPTION: Release 0.12.17 diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h index 44a4d9d6f..f13d33ffd 100644 --- a/inst/include/Rcpp/macros/macros.h +++ b/inst/include/Rcpp/macros/macros.h @@ -42,9 +42,8 @@ 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")) ; \ + rcpp_output_type = 3 ; \ + rcpp_output_condition = __ex__.token; \ } \ catch(Rcpp::exception& __ex__) { \ rcpp_output_type = 2 ; \ @@ -65,6 +64,10 @@ SEXP stop_sym = Rf_install( "stop" ) ; \ SEXP expr = PROTECT( Rf_lang2( stop_sym , rcpp_output_condition ) ) ; \ Rf_eval( expr, R_GlobalEnv ) ; \ + } \ + if (rcpp_output_type == 3) { \ + Rcpp::internal::resumeJump(rcpp_output_condition); \ + Rf_error("Internal error: Rcpp longjump failed to resume"); \ } #endif @@ -72,6 +75,9 @@ #define END_RCPP VOID_END_RCPP return R_NilValue; #endif + +// There is no return in case of a longjump exception + #ifndef END_RCPP_RETURN_ERROR #define END_RCPP_RETURN_ERROR \ } \ @@ -79,8 +85,8 @@ return Rcpp::internal::interruptedError(); \ } \ catch (Rcpp::internal::LongjumpException& __ex__) { \ - Rcpp::internal::resumeJump(__ex__.token); \ - return string_to_try_error("Unexpected LongjumpException") ; \ + rcpp_output_type = 3 ; \ + rcpp_output_condition = __ex__.token; \ } \ catch (std::exception &__ex__) { \ return exception_to_try_error(__ex__); \ @@ -88,6 +94,10 @@ catch (...) { \ return string_to_try_error("c++ exception (unknown reason)"); \ } \ + if (rcpp_output_type == 3) { \ + Rcpp::internal::resumeJump(rcpp_output_condition); \ + Rf_error("Internal error: Rcpp longjump failed to resume"); \ + } \ return R_NilValue; #endif From d44e42e1f999280ab65f1d53db11703a5d21f635 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Thu, 31 May 2018 12:45:18 +0200 Subject: [PATCH 05/13] Handle longjumps in cpp interfaces --- ChangeLog | 10 ++++++++++ inst/include/Rcpp/exceptions.h | 31 ++++++++++++++++++++++++++++++- inst/include/Rcpp/macros/macros.h | 7 +------ src/attributes.cpp | 10 ++++++++++ 4 files changed, 51 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 76bf116d8..66965b9d2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -33,6 +33,16 @@ * inst/include/Rcpp/macros/macros.h: Leave the try/catch scope before resuming jump to ensure proper destruction of the exception reference. + * inst/include/Rcpp/exceptions.h: Functions to create and check a + longjump sentinel. This sentinel is used as return value in contexts + where it is not safe to resume a jump (i.e. in the glue code of cpp + interfaces). + + * inst/include/Rcpp/macros/macros.h: Return a longjump sentinel in + END_RCPP_RETURN_ERROR. + + * src/attributes.cpp: Detect longjump sentinels and resume jump. + 2018-05-09 Dirk Eddelbuettel * DESCRIPTION: Release 0.12.17 diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h index a01297f9a..906cd87f5 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -113,12 +113,41 @@ namespace Rcpp { namespace internal { + inline SEXP longjumpSentinel(SEXP token) { + SEXP sentinel = PROTECT(Rf_allocVector(VECSXP, 1)); + SET_VECTOR_ELT(sentinel, 0, token); + + SEXP sentinelClass = PROTECT(Rf_mkString("Rcpp:longjumpSentinel")); + Rf_setAttrib(sentinel, R_ClassSymbol, sentinelClass) ; + + UNPROTECT(2); + return sentinel; + } + + inline bool isLongjumpSentinel(SEXP x) { + return + Rf_inherits(x, "Rcpp:longjumpSentinel") && + TYPEOF(x) == VECSXP && + Rf_length(x) == 1; + } + + inline SEXP getLongjumpToken(SEXP sentinel) { + return VECTOR_ELT(sentinel, 0); + } + struct LongjumpException { SEXP token; - LongjumpException(SEXP token_) : token(token_) { } + LongjumpException(SEXP token_) : token(token_) { + if (isLongjumpSentinel(token)) { + token = getLongjumpToken(token); + } + } }; inline void resumeJump(SEXP token) { + if (isLongjumpSentinel(token)) { + token = getLongjumpToken(token); + } ::R_ReleaseObject(token); #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) ::R_ContinueUnwind(token); diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h index f13d33ffd..5887d642f 100644 --- a/inst/include/Rcpp/macros/macros.h +++ b/inst/include/Rcpp/macros/macros.h @@ -85,8 +85,7 @@ return Rcpp::internal::interruptedError(); \ } \ catch (Rcpp::internal::LongjumpException& __ex__) { \ - rcpp_output_type = 3 ; \ - rcpp_output_condition = __ex__.token; \ + return Rcpp::internal::longjumpSentinel(__ex__.token); \ } \ catch (std::exception &__ex__) { \ return exception_to_try_error(__ex__); \ @@ -94,10 +93,6 @@ catch (...) { \ return string_to_try_error("c++ exception (unknown reason)"); \ } \ - if (rcpp_output_type == 3) { \ - Rcpp::internal::resumeJump(rcpp_output_condition); \ - Rf_error("Internal error: Rcpp longjump failed to resume"); \ - } \ return R_NilValue; #endif diff --git a/src/attributes.cpp b/src/attributes.cpp index 42f20c49a..5a525da3e 100644 --- a/src/attributes.cpp +++ b/src/attributes.cpp @@ -2190,6 +2190,10 @@ namespace attributes { << std::endl << " throw Rcpp::internal::InterruptedException();" << std::endl; + ostr() << " if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen))" + << std::endl + << " throw Rcpp::internal::LongjumpException(rcpp_result_gen);" + << std::endl; ostr() << " if (rcpp_result_gen.inherits(\"try-error\"))" << std::endl << " throw Rcpp::exception(Rcpp::as(" @@ -2774,6 +2778,12 @@ namespace attributes { << " UNPROTECT(1);" << std::endl << " Rf_onintr();" << std::endl << " }" << std::endl + << " bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen);" << std::endl + << " if (rcpp_isLongjump_gen) {" << std::endl + // No need to unprotect before jump + << " Rcpp::internal::resumeJump(rcpp_result_gen);" << std::endl + << " Rf_error(\"Internal error: Rcpp longjump failed to resume\");" << std::endl + << " }" << std::endl << " Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, \"try-error\");" << std::endl << " if (rcpp_isError_gen) {" << std::endl From 91fef0a43abd82120537a226774602a248d88d8b Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Thu, 31 May 2018 15:57:41 +0200 Subject: [PATCH 06/13] Move longjump error to resumeJump() --- inst/include/Rcpp/exceptions.h | 1 + inst/include/Rcpp/macros/macros.h | 1 - src/attributes.cpp | 1 - 3 files changed, 1 insertion(+), 2 deletions(-) diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h index 906cd87f5..ac8dc8b5e 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -152,6 +152,7 @@ namespace Rcpp { #if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) ::R_ContinueUnwind(token); #endif + Rf_error("Internal error: Rcpp longjump failed to resume"); } } // namespace internal diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h index 5887d642f..a2c0c6d7b 100644 --- a/inst/include/Rcpp/macros/macros.h +++ b/inst/include/Rcpp/macros/macros.h @@ -67,7 +67,6 @@ } \ if (rcpp_output_type == 3) { \ Rcpp::internal::resumeJump(rcpp_output_condition); \ - Rf_error("Internal error: Rcpp longjump failed to resume"); \ } #endif diff --git a/src/attributes.cpp b/src/attributes.cpp index 5a525da3e..2efbcc19e 100644 --- a/src/attributes.cpp +++ b/src/attributes.cpp @@ -2782,7 +2782,6 @@ namespace attributes { << " if (rcpp_isLongjump_gen) {" << std::endl // No need to unprotect before jump << " Rcpp::internal::resumeJump(rcpp_result_gen);" << std::endl - << " Rf_error(\"Internal error: Rcpp longjump failed to resume\");" << std::endl << " }" << std::endl << " Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, \"try-error\");" << std::endl From ecb5f3086f3dbefa8c05c7d930262f5b428636ab Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Thu, 31 May 2018 15:59:54 +0200 Subject: [PATCH 07/13] Always resume jump even if `RCPP_PROTECTED_EVAL` is not set A LongjumpException might be sent by another package called via cpp interface --- inst/include/Rcpp/exceptions.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h index ac8dc8b5e..8dff5f63a 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -149,7 +149,7 @@ namespace Rcpp { token = getLongjumpToken(token); } ::R_ReleaseObject(token); -#if (defined(RCPP_PROTECTED_EVAL) && defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) +#if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) ::R_ContinueUnwind(token); #endif Rf_error("Internal error: Rcpp longjump failed to resume"); From 1ee996c67772c271bcaa5225400de093c45247b5 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Thu, 31 May 2018 17:40:55 +0200 Subject: [PATCH 08/13] Rewrite changelog notes about protected evaluation --- ChangeLog | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/ChangeLog b/ChangeLog index 66965b9d2..7f9399805 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,27 +1,30 @@ 2018-05-31 Lionel Henry - * inst/include/Rcpp/api/meat/Rcpp_eval.h: Unguard Rcpp_fast_eval(). - - Unlike Rcpp_eval(), Rcpp_fast_eval() 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 under the hood in order to - gain safety. It is fully backward-compatibile and still catches errors - and interrupts to rethrow them as typed C++ exceptions. If you don't - need to catch those, consider using Rcpp_fast_eval() instead to avoid - the catching 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. + * inst/include/Rcpp/api/meat/Rcpp_eval.h: Fix protected evaluation. + + Setting `RCPP_PROTECTED_EVAL` before including Rcpp.h enables a new R + 3.5 API for safe evaluation of R code. R longjumps are now correctly + intercepted and rethrown. Thanks to this the C++ stack is now safely + unwound when a longjump is detected while calling into R code. This + includes the following cases: thrown errors, caught condition of any + class, long return, restart invokation, debugger exit. Note that this is + still experimental! + + When `RCPP_PROTECTED_EVAL` is enabled, Rcpp_eval() uses the + protect-unwind API under the hood in order to gain safety. It is fully + backward-compatibile and still catches errors and interrupts to rethrow + them as typed C++ exceptions. If you don't need to catch those, consider + using Rcpp_fast_eval() instead to avoid the catching overhead. + + Rcpp_fast_eval() is a wrapper around Rf_eval(). Unlike Rcpp_eval(), it + does not evaluate R code within tryCatch() and thus avoids the overhead + of wrapping and evaluating the expression in a tryCatch() call. When + Rcpp is compiled with a lower version than R 3.5, Rcpp_fast_eval() falls + back to Rf_eval() without any protection from long jumps, even when + `RCPP_PROTECTED_EVAL` is set. Either add R 3.5 to your `Depends` or make + sure the legacy Rcpp_eval() function is called instead of Rcpp_fast_eval() + when your package is compiled with an older version of R. Note that Rcpp_fast_eval() behaves a bit differently to Rcpp_eval(). The former has the semantics of the C function Rf_eval() whereas the latter From b6a790a0224b41f783834e550d77b64db9ec1ac5 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Fri, 1 Jun 2018 19:07:41 +0200 Subject: [PATCH 09/13] Add unit tests for jumping across cpp interfaces --- ChangeLog | 9 ++ inst/unitTests/runit.interface.R | 87 +++++++++++++++++++ .../testRcppInterfaceExporter/DESCRIPTION | 12 +++ .../testRcppInterfaceExporter/NAMESPACE | 7 ++ .../testRcppInterfaceExporter/R/exporter.R | 18 ++++ .../src/exporter.cpp | 13 +++ .../testRcppInterfaceExporter/src/unwound.h | 27 ++++++ .../testRcppInterfaceUser/DESCRIPTION | 13 +++ .../unitTests/testRcppInterfaceUser/NAMESPACE | 7 ++ inst/unitTests/testRcppInterfaceUser/R/user.R | 18 ++++ .../testRcppInterfaceUser/src/unwound.h | 27 ++++++ .../testRcppInterfaceUser/src/user.cpp | 16 ++++ .../testRcppInterfaceUser/tests/tests.R | 32 +++++++ 13 files changed, 286 insertions(+) create mode 100644 inst/unitTests/runit.interface.R create mode 100644 inst/unitTests/testRcppInterfaceExporter/DESCRIPTION create mode 100644 inst/unitTests/testRcppInterfaceExporter/NAMESPACE create mode 100644 inst/unitTests/testRcppInterfaceExporter/R/exporter.R create mode 100644 inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp create mode 100644 inst/unitTests/testRcppInterfaceExporter/src/unwound.h create mode 100644 inst/unitTests/testRcppInterfaceUser/DESCRIPTION create mode 100644 inst/unitTests/testRcppInterfaceUser/NAMESPACE create mode 100644 inst/unitTests/testRcppInterfaceUser/R/user.R create mode 100644 inst/unitTests/testRcppInterfaceUser/src/unwound.h create mode 100644 inst/unitTests/testRcppInterfaceUser/src/user.cpp create mode 100644 inst/unitTests/testRcppInterfaceUser/tests/tests.R diff --git a/ChangeLog b/ChangeLog index 7f9399805..1e7c53b92 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,13 @@ +2018-06-01 Lionel Henry + + * inst/unitTests/runit.interface.R: New tests for interfaces and unwind. + These tests build two packages, and that exports a function via + Rcpp::interfaces(cpp) and the other that calls it. The attributes are + regenerated and the packages rebuilt each time the tests are run. The + tests check in particular that the C++ stack is properly unwound when a + long jump occurs. + 2018-05-31 Lionel Henry * inst/include/Rcpp/api/meat/Rcpp_eval.h: Fix protected evaluation. diff --git a/inst/unitTests/runit.interface.R b/inst/unitTests/runit.interface.R new file mode 100644 index 000000000..b0d0eada7 --- /dev/null +++ b/inst/unitTests/runit.interface.R @@ -0,0 +1,87 @@ +#!/usr/bin/env r +# -*- mode: R; tab-width: 4; -*- +# +# 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 . +.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes" + +if (.runThisTest) { + + test.interface.unwind <- function() { + exporter_name <- "testRcppInterfaceExporter" + user_name <- "testRcppInterfaceUser" + + tempdir <- tempfile() + dir.create(tempdir) + old_wd <- setwd(tempdir) + on.exit({ + setwd(old_wd) + unlink(tempdir, recursive = TRUE) + }) + + file.copy(system.file("unitTests", exporter_name, package = "Rcpp"), + tempdir, + recursive = TRUE) + file.copy(system.file("unitTests", user_name, package = "Rcpp"), + tempdir, + recursive = TRUE) + + exporter_path <- file.path(tempdir, exporter_name) + user_path <- file.path(tempdir, user_name) + + Rcpp::compileAttributes(exporter_path) + Rcpp::compileAttributes(user_path) + + lib_path <- file.path(tempdir, "templib") + dir.create(lib_path) + + install <- function(path, lib_path) { + install.packages( + path, + lib_path, + repos = NULL, + type = "source", + INSTALL_opts = "--install-tests" + ) + } + install(exporter_path, lib_path) + install(user_path, lib_path) + + old_lib_paths <- .libPaths() + on.exit(.libPaths(old_lib_paths)) + .libPaths(lib_path) + + # Without this testInstalledPackage() won't find installed + # packages even though we've passed `lib.loc` + old_libs_envvar <- Sys.getenv("R_LIBS") + on.exit(Sys.setenv(R_LIBS = old_libs_envvar), add = TRUE) + + sys_sep <- if (.Platform$OS.type == "windows") ";" else ":" + Sys.setenv(R_LIBS = paste(c(lib_path, old_lib_paths), collapse = sys_sep)) + + result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test") + + # Be verbose if tests were not successful + if (result) { + log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail") + cat(">> tests.Rout.fail", readLines(log), sep = "\n", file = stderr()) + } + + checkEquals(result, 0L) + } + +} diff --git a/inst/unitTests/testRcppInterfaceExporter/DESCRIPTION b/inst/unitTests/testRcppInterfaceExporter/DESCRIPTION new file mode 100644 index 000000000..46a4a8713 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/DESCRIPTION @@ -0,0 +1,12 @@ +Package: testRcppInterfaceExporter +Title: Exports c++ function via the cpp interface +Version: 0.1.0 +Authors@R: 'Lionel Henry [aut, cre]' +Description: The API package. +Depends: + R (>= 3.1.0) +Imports: + Rcpp +LinkingTo: + Rcpp +License: GPL-3 diff --git a/inst/unitTests/testRcppInterfaceExporter/NAMESPACE b/inst/unitTests/testRcppInterfaceExporter/NAMESPACE new file mode 100644 index 000000000..e0f2a5277 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/NAMESPACE @@ -0,0 +1,7 @@ +# Generated by roxygen2: do not edit by hand + +export(peek_flag) +export(reset_flags) +export(test_cpp_interface) +importFrom(Rcpp,sourceCpp) +useDynLib(testRcppInterfaceExporter, .registration = TRUE) diff --git a/inst/unitTests/testRcppInterfaceExporter/R/exporter.R b/inst/unitTests/testRcppInterfaceExporter/R/exporter.R new file mode 100644 index 000000000..0bc1e7f7d --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/R/exporter.R @@ -0,0 +1,18 @@ +#' @useDynLib testRcppInterfaceExporter, .registration = TRUE +#' @importFrom Rcpp sourceCpp +NULL + +flags <- new.env(parent = emptyenv()) + +#' @export +reset_flags <- function() { + flags$cpp_interface_upstream <- FALSE +} +.onLoad <- function(lib, pkg) { + reset_flags() +} + +#' @export +peek_flag <- function(name) { + flags[[name]] +} diff --git a/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp new file mode 100644 index 000000000..4462a3358 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp @@ -0,0 +1,13 @@ +#define RCPP_PROTECTED_EVAL + +#include +#include "unwound.h" + +// [[Rcpp::interfaces(r, cpp)]] + +//' @export +// [[Rcpp::export]] +SEXP test_cpp_interface(SEXP x) { + unwound_t stack_obj("cpp_interface_upstream"); + return Rcpp::Rcpp_fast_eval(x, R_GlobalEnv); +} diff --git a/inst/unitTests/testRcppInterfaceExporter/src/unwound.h b/inst/unitTests/testRcppInterfaceExporter/src/unwound.h new file mode 100644 index 000000000..c0b35c821 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/src/unwound.h @@ -0,0 +1,27 @@ +#ifndef UNWOUND_H +#define UNWOUND_H + + +#include + +#define PKG_NAME "testRcppInterfaceExporter" + +struct unwound_t { + unwound_t(std::string flag_) { + flag = flag_; + Rcpp::Rcout << "Initialising " << flag << std::endl; + Rcpp::Environment ns = Rcpp::Environment::namespace_env(PKG_NAME); + flags_env = ns["flags"]; + flags_env[flag] = false; + } + ~unwound_t() { + Rcpp::Rcout << "Unwinding " << flag << std::endl; + flags_env[flag] = true; + } + + std::string flag; + Rcpp::Environment flags_env; +}; + + +#endif diff --git a/inst/unitTests/testRcppInterfaceUser/DESCRIPTION b/inst/unitTests/testRcppInterfaceUser/DESCRIPTION new file mode 100644 index 000000000..1b9f90cc2 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/DESCRIPTION @@ -0,0 +1,13 @@ +Package: testRcppInterfaceUser +Title: Calls exported c++ function of testRcppInterfaceExporter +Version: 0.1.0 +Authors@R: 'Lionel Henry [aut, cre]' +Description: The client package. +Depends: + R (>= 3.1.0) +Imports: + Rcpp +LinkingTo: + testRcppInterfaceExporter, + Rcpp +License: GPL-3 diff --git a/inst/unitTests/testRcppInterfaceUser/NAMESPACE b/inst/unitTests/testRcppInterfaceUser/NAMESPACE new file mode 100644 index 000000000..b0d51ec76 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/NAMESPACE @@ -0,0 +1,7 @@ +# Generated by roxygen2: do not edit by hand + +export(peek_flag) +export(reset_flags) +export(use_cpp_interface) +importFrom(Rcpp,sourceCpp) +useDynLib(testRcppInterfaceUser, .registration = TRUE) diff --git a/inst/unitTests/testRcppInterfaceUser/R/user.R b/inst/unitTests/testRcppInterfaceUser/R/user.R new file mode 100644 index 000000000..d30dd930c --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/R/user.R @@ -0,0 +1,18 @@ +#' @useDynLib testRcppInterfaceUser, .registration = TRUE +#' @importFrom Rcpp sourceCpp +NULL + +flags <- new.env(parent = emptyenv()) + +#' @export +reset_flags <- function() { + flags$cpp_interface_downstream <- FALSE +} +.onLoad <- function(lib, pkg) { + reset_flags() +} + +#' @export +peek_flag <- function(name) { + flags[[name]] +} diff --git a/inst/unitTests/testRcppInterfaceUser/src/unwound.h b/inst/unitTests/testRcppInterfaceUser/src/unwound.h new file mode 100644 index 000000000..a953aca5c --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/src/unwound.h @@ -0,0 +1,27 @@ +#ifndef UNWOUND_H +#define UNWOUND_H + + +#include + +#define PKG_NAME "testRcppInterfaceUser" + +struct unwound_t { + unwound_t(std::string flag_) { + flag = flag_; + Rcpp::Rcout << "Initialising " << flag << std::endl; + Rcpp::Environment ns = Rcpp::Environment::namespace_env(PKG_NAME); + flags_env = ns["flags"]; + flags_env[flag] = false; + } + ~unwound_t() { + Rcpp::Rcout << "Unwinding " << flag << std::endl; + flags_env[flag] = true; + } + + std::string flag; + Rcpp::Environment flags_env; +}; + + +#endif diff --git a/inst/unitTests/testRcppInterfaceUser/src/user.cpp b/inst/unitTests/testRcppInterfaceUser/src/user.cpp new file mode 100644 index 000000000..ac80893d9 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/src/user.cpp @@ -0,0 +1,16 @@ +#define RCPP_PROTECTED_EVAL + +#include +#include + +#include "unwound.h" + + +//' @export +// [[Rcpp::export]] +SEXP use_cpp_interface(SEXP x) { + unwound_t stack_obj("cpp_interface_downstream"); + Rcpp::RObject out = testRcppInterfaceExporter::test_cpp_interface(x); + Rcpp::Rcout << "Wrapping up" << std::endl; + return out; +} diff --git a/inst/unitTests/testRcppInterfaceUser/tests/tests.R b/inst/unitTests/testRcppInterfaceUser/tests/tests.R new file mode 100644 index 000000000..3fb310a67 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/tests/tests.R @@ -0,0 +1,32 @@ + +x <- tryCatch( + error = identity, + testRcppInterfaceUser::use_cpp_interface(quote(stop("jump!"))) +) + +stopifnot(grepl("jump!", x$message)) + +if (getRversion() >= "3.5.0") { + stopifnot( + testRcppInterfaceUser::peek_flag("cpp_interface_downstream"), + testRcppInterfaceExporter::peek_flag("cpp_interface_upstream") + ) +} + + +testRcppInterfaceUser::reset_flags() +testRcppInterfaceExporter::reset_flags() + +x <- withRestarts( + here = identity, + testRcppInterfaceUser::use_cpp_interface(quote(invokeRestart("here", "value"))) +) + +stopifnot(identical(x, "value")) + +if (getRversion() >= "3.5.0") { + stopifnot( + testRcppInterfaceUser::peek_flag("cpp_interface_downstream"), + testRcppInterfaceExporter::peek_flag("cpp_interface_upstream") + ) +} From b4cc4ef9ccd5ab8b86f7d56bd31ef6c061fd82d4 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Fri, 1 Jun 2018 22:13:09 +0200 Subject: [PATCH 10/13] Bump to 0.12.17.1 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d5f0bea67..88e247940 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: Rcpp Title: Seamless R and C++ Integration -Version: 0.12.17 +Version: 0.12.17.1 Date: 2018-05-09 Author: Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou, Nathan Russell, Douglas Bates and John Chambers From 088c5c6c0c608d683b8e7ee3b19f58756cf9adae Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Sat, 2 Jun 2018 12:55:58 +0200 Subject: [PATCH 11/13] Add test for client packages compiled without protected evaluation --- ChangeLog | 8 +++ inst/unitTests/runit.interface.R | 69 +++++++++++-------- .../testRcppInterfaceExporter/src/config.h | 0 .../src/exporter.cpp | 2 +- .../testRcppInterfaceUser/src/config.h | 0 .../testRcppInterfaceUser/src/user.cpp | 2 +- .../testRcppInterfaceUser/tests/tests.R | 2 + 7 files changed, 53 insertions(+), 30 deletions(-) create mode 100644 inst/unitTests/testRcppInterfaceExporter/src/config.h create mode 100644 inst/unitTests/testRcppInterfaceUser/src/config.h diff --git a/ChangeLog b/ChangeLog index 1e7c53b92..09df13adc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,12 @@ +2018-06-02 Lionel Henry + + * inst/unitTests/runit.interface.R: New test for the case where + the client package was compiled without protected evaluation + enabled. On R 3.5, longjump exceptions thrown from imported + functions are still caught and dealt with properly by the client + package. + 2018-06-01 Lionel Henry * inst/unitTests/runit.interface.R: New tests for interfaces and unwind. diff --git a/inst/unitTests/runit.interface.R b/inst/unitTests/runit.interface.R index b0d0eada7..df543a43b 100644 --- a/inst/unitTests/runit.interface.R +++ b/inst/unitTests/runit.interface.R @@ -21,6 +21,25 @@ if (.runThisTest) { + build_package <- function(name, lib_path, tempdir = getwd(), + config = character()) { + file.copy(system.file("unitTests", name, package = "Rcpp"), + getwd(), + recursive = TRUE) + + src_path <- file.path(tempdir, name) + Rcpp::compileAttributes(src_path) + writeLines(config, file.path(src_path, "src", "config.h")) + + install.packages( + src_path, + lib_path, + repos = NULL, + type = "source", + INSTALL_opts = "--install-tests" + ) + } + test.interface.unwind <- function() { exporter_name <- "testRcppInterfaceExporter" user_name <- "testRcppInterfaceUser" @@ -33,37 +52,12 @@ if (.runThisTest) { unlink(tempdir, recursive = TRUE) }) - file.copy(system.file("unitTests", exporter_name, package = "Rcpp"), - tempdir, - recursive = TRUE) - file.copy(system.file("unitTests", user_name, package = "Rcpp"), - tempdir, - recursive = TRUE) - - exporter_path <- file.path(tempdir, exporter_name) - user_path <- file.path(tempdir, user_name) - - Rcpp::compileAttributes(exporter_path) - Rcpp::compileAttributes(user_path) - lib_path <- file.path(tempdir, "templib") dir.create(lib_path) - install <- function(path, lib_path) { - install.packages( - path, - lib_path, - repos = NULL, - type = "source", - INSTALL_opts = "--install-tests" - ) - } - install(exporter_path, lib_path) - install(user_path, lib_path) - old_lib_paths <- .libPaths() - on.exit(.libPaths(old_lib_paths)) - .libPaths(lib_path) + on.exit(.libPaths(old_lib_paths), add = TRUE) + .libPaths(c(lib_path, old_lib_paths)) # Without this testInstalledPackage() won't find installed # packages even though we've passed `lib.loc` @@ -73,12 +67,31 @@ if (.runThisTest) { sys_sep <- if (.Platform$OS.type == "windows") ";" else ":" Sys.setenv(R_LIBS = paste(c(lib_path, old_lib_paths), collapse = sys_sep)) + cfg <- "#define RCPP_PROTECTED_EVAL" + build_package(exporter_name, lib_path, config = cfg) + build_package(user_name, lib_path, config = cfg) + result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test") # Be verbose if tests were not successful if (result) { log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail") - cat(">> tests.Rout.fail", readLines(log), sep = "\n", file = stderr()) + cat(">> PROTECTED tests.Rout.fail", readLines(log), sep = "\n", file = stderr()) + } + + checkEquals(result, 0L) + + + # Now test client package without protected evaluation + unlink(user_name, recursive = TRUE) + unlink(paste0(user_name, "-tests"), recursive = TRUE) + build_package(user_name, lib_path, config = character()) + + result <- tools::testInstalledPackage(user_name, lib.loc = lib_path, types = "test") + + if (result) { + log <- file.path(paste0(user_name, "-tests"), "tests.Rout.fail") + cat(">> UNPROTECTED tests.Rout.fail", readLines(log), sep = "\n", file = stderr()) } checkEquals(result, 0L) diff --git a/inst/unitTests/testRcppInterfaceExporter/src/config.h b/inst/unitTests/testRcppInterfaceExporter/src/config.h new file mode 100644 index 000000000..e69de29bb diff --git a/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp index 4462a3358..2fce792b0 100644 --- a/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp +++ b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp @@ -1,4 +1,4 @@ -#define RCPP_PROTECTED_EVAL +#include "config.h" #include #include "unwound.h" diff --git a/inst/unitTests/testRcppInterfaceUser/src/config.h b/inst/unitTests/testRcppInterfaceUser/src/config.h new file mode 100644 index 000000000..e69de29bb diff --git a/inst/unitTests/testRcppInterfaceUser/src/user.cpp b/inst/unitTests/testRcppInterfaceUser/src/user.cpp index ac80893d9..e556df772 100644 --- a/inst/unitTests/testRcppInterfaceUser/src/user.cpp +++ b/inst/unitTests/testRcppInterfaceUser/src/user.cpp @@ -1,4 +1,4 @@ -#define RCPP_PROTECTED_EVAL +#include "config.h" #include #include diff --git a/inst/unitTests/testRcppInterfaceUser/tests/tests.R b/inst/unitTests/testRcppInterfaceUser/tests/tests.R index 3fb310a67..79febf74d 100644 --- a/inst/unitTests/testRcppInterfaceUser/tests/tests.R +++ b/inst/unitTests/testRcppInterfaceUser/tests/tests.R @@ -1,4 +1,5 @@ +# This tests errors converted to exceptions by Rcpp_eval() x <- tryCatch( error = identity, testRcppInterfaceUser::use_cpp_interface(quote(stop("jump!"))) @@ -17,6 +18,7 @@ if (getRversion() >= "3.5.0") { testRcppInterfaceUser::reset_flags() testRcppInterfaceExporter::reset_flags() +# This tests longjumps not caught by Rcpp_eval() x <- withRestarts( here = identity, testRcppInterfaceUser::use_cpp_interface(quote(invokeRestart("here", "value"))) From dd3dcb2357adad3373531edd0d64bb4db9a84ca6 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Sat, 2 Jun 2018 13:23:16 +0200 Subject: [PATCH 12/13] Test both Rcpp_eval() and Rcpp_fast_eval() --- ChangeLog | 3 ++ .../src/exporter.cpp | 8 +++-- .../testRcppInterfaceUser/src/user.cpp | 4 +-- .../testRcppInterfaceUser/tests/tests.R | 35 ++++++++++++++----- 4 files changed, 37 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index 09df13adc..2149c690b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -7,6 +7,9 @@ functions are still caught and dealt with properly by the client package. + * inst/unitTests/runit.interface.R: Test both Rcpp_eval() and + Rcpp_fast_eval(). + 2018-06-01 Lionel Henry * inst/unitTests/runit.interface.R: New tests for interfaces and unwind. diff --git a/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp index 2fce792b0..d21ea0a95 100644 --- a/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp +++ b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp @@ -7,7 +7,11 @@ //' @export // [[Rcpp::export]] -SEXP test_cpp_interface(SEXP x) { +SEXP test_cpp_interface(SEXP x, bool fast = false) { unwound_t stack_obj("cpp_interface_upstream"); - return Rcpp::Rcpp_fast_eval(x, R_GlobalEnv); + if (fast) { + return Rcpp::Rcpp_fast_eval(x, R_GlobalEnv); + } else { + return Rcpp::Rcpp_eval(x, R_GlobalEnv); + } } diff --git a/inst/unitTests/testRcppInterfaceUser/src/user.cpp b/inst/unitTests/testRcppInterfaceUser/src/user.cpp index e556df772..3dc4a617f 100644 --- a/inst/unitTests/testRcppInterfaceUser/src/user.cpp +++ b/inst/unitTests/testRcppInterfaceUser/src/user.cpp @@ -8,9 +8,9 @@ //' @export // [[Rcpp::export]] -SEXP use_cpp_interface(SEXP x) { +SEXP use_cpp_interface(SEXP x, bool fast = false) { unwound_t stack_obj("cpp_interface_downstream"); - Rcpp::RObject out = testRcppInterfaceExporter::test_cpp_interface(x); + Rcpp::RObject out = testRcppInterfaceExporter::test_cpp_interface(x, fast); Rcpp::Rcout << "Wrapping up" << std::endl; return out; } diff --git a/inst/unitTests/testRcppInterfaceUser/tests/tests.R b/inst/unitTests/testRcppInterfaceUser/tests/tests.R index 79febf74d..effb2e482 100644 --- a/inst/unitTests/testRcppInterfaceUser/tests/tests.R +++ b/inst/unitTests/testRcppInterfaceUser/tests/tests.R @@ -1,22 +1,39 @@ +reset <- function() { + testRcppInterfaceUser::reset_flags() + testRcppInterfaceExporter::reset_flags() +} + + # This tests errors converted to exceptions by Rcpp_eval() x <- tryCatch( error = identity, testRcppInterfaceUser::use_cpp_interface(quote(stop("jump!"))) ) -stopifnot(grepl("jump!", x$message)) +stopifnot( + grepl("jump!", x$message), + testRcppInterfaceUser::peek_flag("cpp_interface_downstream"), + testRcppInterfaceExporter::peek_flag("cpp_interface_upstream") +) -if (getRversion() >= "3.5.0") { - stopifnot( - testRcppInterfaceUser::peek_flag("cpp_interface_downstream"), - testRcppInterfaceExporter::peek_flag("cpp_interface_upstream") - ) -} + +reset() + +# This tests errors converted to resumable longjumps by Rcpp_fast_eval() +x <- tryCatch( + error = identity, + testRcppInterfaceUser::use_cpp_interface(quote(stop("jump!")), fast = TRUE) +) + +stopifnot( + grepl("jump!", x$message), + testRcppInterfaceUser::peek_flag("cpp_interface_downstream"), + testRcppInterfaceExporter::peek_flag("cpp_interface_upstream") +) -testRcppInterfaceUser::reset_flags() -testRcppInterfaceExporter::reset_flags() +reset() # This tests longjumps not caught by Rcpp_eval() x <- withRestarts( From a8c54633748ba946980608b918f3a5812edd4307 Mon Sep 17 00:00:00 2001 From: Lionel Henry Date: Tue, 5 Jun 2018 11:46:34 +0200 Subject: [PATCH 13/13] Use stack-local jump buffer to handle nested protected evaluations --- inst/include/Rcpp/api/meat/Rcpp_eval.h | 20 ++++++------ inst/unitTests/runit.stack.R | 43 ++++++++++++++++++++++++-- 2 files changed, 50 insertions(+), 13 deletions(-) diff --git a/inst/include/Rcpp/api/meat/Rcpp_eval.h b/inst/include/Rcpp/api/meat/Rcpp_eval.h index 8ae74d96d..b2d6a932c 100644 --- a/inst/include/Rcpp/api/meat/Rcpp_eval.h +++ b/inst/include/Rcpp/api/meat/Rcpp_eval.h @@ -32,25 +32,22 @@ namespace internal { #ifdef RCPP_USE_PROTECT_UNWIND - // Store the jump buffer as a static variable in function scope - // because inline variables are a C++17 extension. - inline std::jmp_buf* get_jmpbuf_ptr() { - static std::jmp_buf jmpbuf; - return &jmpbuf; - } - 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* data, Rboolean jump) { + inline void Rcpp_maybe_throw(void* unwind_data, Rboolean jump) { if (jump) { - longjmp(*internal::get_jmpbuf_ptr(), 1); + EvalUnwindData* data = static_cast(unwind_data); + longjmp(data->jmpbuf, 1); } } @@ -80,9 +77,10 @@ namespace internal { inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) { internal::EvalData data(expr, env); + internal::EvalUnwindData unwind_data; Shield token(::R_MakeUnwindCont()); - if (setjmp(*internal::get_jmpbuf_ptr())) { + 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 @@ -93,7 +91,7 @@ namespace internal { } return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data, - internal::Rcpp_maybe_throw, token, + internal::Rcpp_maybe_throw, &unwind_data, token); } diff --git a/inst/unitTests/runit.stack.R b/inst/unitTests/runit.stack.R index 3d8045fe9..7e803643a 100644 --- a/inst/unitTests/runit.stack.R +++ b/inst/unitTests/runit.stack.R @@ -28,6 +28,12 @@ if (.runThisTest) { # leaks on longjumps hasUnwind <- getRversion() >= "3.5.0" checkUnwound <- if (hasUnwind) checkTrue else function(x) checkTrue(!x) + checkErrorMessage <- function(x, msg) { + if (!hasUnwind) { + msg <- paste0("Evaluation error: ", msg, ".") + } + checkIdentical(x$message, msg) + } EvalUnwind <- function(expr, indicator) { testFastEval(expr, parent.frame(), indicator) } @@ -37,8 +43,7 @@ if (.runThisTest) { unwound <- FALSE out <- tryCatch(EvalUnwind(quote(stop("err")), unwound), error = identity) checkTrue(unwound) - msg <- if (hasUnwind) "err" else "Evaluation error: err." - checkIdentical(out$message, msg) + checkErrorMessage(out, "err") } test.stackUnwindsOnInterrupts <- function() { @@ -103,4 +108,38 @@ if (.runThisTest) { checkIdentical(out, "abort") } } + + # Longjump from the inner protected eval + test.stackUnwindsOnNestedEvalsInner <- function() { + unwound1 <- FALSE + unwound2 <- FALSE + innerUnwindExpr <- quote(EvalUnwind(quote(invokeRestart("here", "jump")), unwound2)) + out <- withRestarts( + here = identity, + EvalUnwind(innerUnwindExpr, unwound1) + ) + + checkIdentical(out, "jump") + checkUnwound(unwound1) + checkUnwound(unwound2) + } + + # Longjump from the outer protected eval + test.stackUnwindsOnNestedEvalsOuter <- function() { + unwound1 <- FALSE + unwound2 <- FALSE + innerUnwindExpr <- quote({ + EvalUnwind(NULL, unwound2) + invokeRestart("here", "jump") + }) + out <- withRestarts( + here = identity, + EvalUnwind(innerUnwindExpr, unwound1) + ) + + checkIdentical(out, "jump") + checkUnwound(unwound1) + checkTrue(unwound2) # Always unwound + } + }