diff --git a/ChangeLog b/ChangeLog index 1037e503e..2149c690b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,71 @@ + +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. + + * 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. + 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. + + 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 + 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. + + * 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/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 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..b2d6a932c 100644 --- a/inst/include/Rcpp/api/meat/Rcpp_eval.h +++ b/inst/include/Rcpp/api/meat/Rcpp_eval.h @@ -21,14 +21,12 @@ #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 +#include #endif + namespace Rcpp { namespace internal { @@ -39,18 +37,17 @@ namespace internal { SEXP env; EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { } }; + struct EvalUnwindData { + std::jmp_buf jmpbuf; + }; - inline void Rcpp_maybe_throw(void* data, Rboolean jump) { + // 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) { - 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); + EvalUnwindData* data = static_cast(unwind_data); + longjmp(data->jmpbuf, 1); } } @@ -80,9 +77,21 @@ 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(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 is on the stack. + ::R_PreserveObject(token); + + throw internal::LongjumpException(token); + } + return ::R_UnwindProtect(internal::Rcpp_protected_eval, &data, - internal::Rcpp_maybe_throw, token, + internal::Rcpp_maybe_throw, &unwind_data, token); } @@ -112,11 +121,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 +130,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..8dff5f63a 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -111,23 +111,51 @@ namespace Rcpp { throw Rcpp::exception(message.c_str()); } // #nocov end -#if defined(RCPP_USE_UNWIND_PROTECT) 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)) +#if (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 -#endif } // namespace Rcpp diff --git a/inst/include/Rcpp/macros/macros.h b/inst/include/Rcpp/macros/macros.h index 3b07052fc..a2c0c6d7b 100644 --- a/inst/include/Rcpp/macros/macros.h +++ b/inst/include/Rcpp/macros/macros.h @@ -36,16 +36,14 @@ #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 ; \ } \ 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 ; \ @@ -66,64 +64,27 @@ SEXP stop_sym = Rf_install( "stop" ) ; \ 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 ) ; \ + if (rcpp_output_type == 3) { \ + Rcpp::internal::resumeJump(rcpp_output_condition); \ } #endif -#endif #ifndef END_RCPP #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 -// 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__) { \ return Rcpp::internal::interruptedError(); \ } \ catch (Rcpp::internal::LongjumpException& __ex__) { \ - Rcpp::internal::resumeJump(__ex__.token); \ - return string_to_try_error("Unexpected LongjumpException") ; \ - } \ - catch (std::exception &__ex__) { \ - return exception_to_try_error(__ex__); \ - } \ - catch (...) { \ - 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(); \ + return Rcpp::internal::longjumpSentinel(__ex__.token); \ } \ catch (std::exception &__ex__) { \ return exception_to_try_error(__ex__); \ @@ -133,7 +94,6 @@ } \ 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.interface.R b/inst/unitTests/runit.interface.R new file mode 100644 index 000000000..df543a43b --- /dev/null +++ b/inst/unitTests/runit.interface.R @@ -0,0 +1,100 @@ +#!/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) { + + 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" + + tempdir <- tempfile() + dir.create(tempdir) + old_wd <- setwd(tempdir) + on.exit({ + setwd(old_wd) + unlink(tempdir, recursive = TRUE) + }) + + lib_path <- file.path(tempdir, "templib") + dir.create(lib_path) + + old_lib_paths <- .libPaths() + 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` + 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)) + + 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(">> 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/runit.stack.R b/inst/unitTests/runit.stack.R index 3e72689b7..7e803643a 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) { @@ -34,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) } @@ -43,11 +43,13 @@ 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() { + if (.Platform$OS.type == "windows") { + return(NULL) + } unwound <- FALSE expr <- quote({ repeat testSendInterrupt() @@ -106,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 + } + } 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/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 new file mode 100644 index 000000000..d21ea0a95 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceExporter/src/exporter.cpp @@ -0,0 +1,17 @@ +#include "config.h" + +#include +#include "unwound.h" + +// [[Rcpp::interfaces(r, cpp)]] + +//' @export +// [[Rcpp::export]] +SEXP test_cpp_interface(SEXP x, bool fast = false) { + unwound_t stack_obj("cpp_interface_upstream"); + if (fast) { + return Rcpp::Rcpp_fast_eval(x, R_GlobalEnv); + } else { + return Rcpp::Rcpp_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/config.h b/inst/unitTests/testRcppInterfaceUser/src/config.h new file mode 100644 index 000000000..e69de29bb 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..3dc4a617f --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/src/user.cpp @@ -0,0 +1,16 @@ +#include "config.h" + +#include +#include + +#include "unwound.h" + + +//' @export +// [[Rcpp::export]] +SEXP use_cpp_interface(SEXP x, bool fast = false) { + unwound_t stack_obj("cpp_interface_downstream"); + 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 new file mode 100644 index 000000000..effb2e482 --- /dev/null +++ b/inst/unitTests/testRcppInterfaceUser/tests/tests.R @@ -0,0 +1,51 @@ + +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), + 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") +) + + +reset() + +# This tests longjumps not caught by Rcpp_eval() +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") + ) +} diff --git a/src/attributes.cpp b/src/attributes.cpp index 42f20c49a..2efbcc19e 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,11 @@ 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 + << " }" << std::endl << " Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, \"try-error\");" << std::endl << " if (rcpp_isError_gen) {" << std::endl