diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h index 91e1f4b62..4fbbb2e23 100644 --- a/inst/include/Rcpp/exceptions.h +++ b/inst/include/Rcpp/exceptions.h @@ -148,7 +148,8 @@ inline void resumeJump(SEXP token) { if (isLongjumpSentinel(token)) { token = getLongjumpToken(token); } - ::R_ReleaseObject(token); + //::R_ReleaseObject(token); + Rcpp_precious_remove(token); #if (defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)) ::R_ContinueUnwind(token); #endif // #nocov end diff --git a/inst/include/Rcpp/routines.h b/inst/include/Rcpp/routines.h index 437e42aee..142998d79 100644 --- a/inst/include/Rcpp/routines.h +++ b/inst/include/Rcpp/routines.h @@ -38,6 +38,11 @@ namespace Rcpp{ } double mktime00(struct tm &); struct tm * gmtime_(const time_t * const); + + void Rcpp_precious_init(); + void Rcpp_precious_teardown(); + void Rcpp_precious_preserve(SEXP object); + void Rcpp_precious_remove(SEXP object); } SEXP rcpp_get_stack_trace(); @@ -127,6 +132,27 @@ namespace Rcpp { return fun(x); } + inline attribute_hidden void Rcpp_precious_init() { + typedef int (*Fun)(void); + static Fun fun = GET_CALLABLE("Rcpp_precious_init"); + fun(); + } + inline attribute_hidden void Rcpp_precious_teardown() { + typedef int (*Fun)(void); + static Fun fun = GET_CALLABLE("Rcpp_precious_teardown"); + fun(); + } + inline attribute_hidden void Rcpp_precious_preserve(SEXP object) { + typedef const char* (*Fun)(SEXP); + static Fun fun = GET_CALLABLE("Rcpp_precious_preserve"); + fun(object); + } + inline attribute_hidden void Rcpp_precious_remove(SEXP object) { + typedef const char* (*Fun)(SEXP); + static Fun fun = GET_CALLABLE("Rcpp_precious_remove"); + fun(object); + } + } // The 'attribute_hidden' used here is a simple precessor defined from diff --git a/inst/include/Rcpp/traits/named_object.h b/inst/include/Rcpp/traits/named_object.h index 761ac24de..ea541007b 100644 --- a/inst/include/Rcpp/traits/named_object.h +++ b/inst/include/Rcpp/traits/named_object.h @@ -42,15 +42,19 @@ template <> class named_object { public: // #nocov start named_object( const std::string& name_, const SEXP& o_): name(name_), object(o_) { - R_PreserveObject(object); + //R_PreserveObject(object); + Rcpp_precious_preserve(object); } named_object( const named_object& other ) : name(other.name), object(other.object) { - R_PreserveObject(object); + //R_PreserveObject(object); + Rcpp_precious_preserve(object); } ~named_object() { - R_ReleaseObject(object); + //R_ReleaseObject(object); + Rcpp_precious_remove(object); + } // #nocov end const std::string& name; SEXP object; diff --git a/inst/include/Rcpp/unwindProtect.h b/inst/include/Rcpp/unwindProtect.h index 7944aab81..52fccc6ff 100644 --- a/inst/include/Rcpp/unwindProtect.h +++ b/inst/include/Rcpp/unwindProtect.h @@ -64,7 +64,8 @@ inline SEXP unwindProtect(SEXP (*callback)(void* data), void* data) { // 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); + //::R_PreserveObject(token); + Rcpp::Rcpp_precious_preserve(token); throw LongjumpException(token); } diff --git a/inst/include/RcppCommon.h b/inst/include/RcppCommon.h index 41ecce70d..58d9ed9ac 100644 --- a/inst/include/RcppCommon.h +++ b/inst/include/RcppCommon.h @@ -77,6 +77,9 @@ namespace Rcpp { SEXP Rcpp_fast_eval(SEXP expr_, SEXP env); SEXP Rcpp_eval(SEXP expr_, SEXP env = R_GlobalEnv); + void Rcpp_precious_preserve(SEXP object); + void Rcpp_precious_remove(SEXP object); + namespace internal { SEXP Rcpp_eval_impl(SEXP expr, SEXP env); } @@ -87,17 +90,24 @@ namespace Rcpp { template class named_object; } - inline SEXP Rcpp_PreserveObject(SEXP x) { - if (x != R_NilValue) { - R_PreserveObject(x); - } - return x; + // inline SEXP Rcpp_PreserveObject(SEXP x) { + // if (x != R_NilValue) { + // R_PreserveObject(x); + // } + // return x; + // } + inline SEXP Rcpp_PreserveObject(SEXP object) { + Rcpp_precious_preserve(object); + return object; } - inline void Rcpp_ReleaseObject(SEXP x) { - if (x != R_NilValue) { - R_ReleaseObject(x); - } + // inline void Rcpp_ReleaseObject(SEXP x) { + // if (x != R_NilValue) { + // R_ReleaseObject(x); + // } + // } + inline void Rcpp_ReleaseObject(SEXP object) { + Rcpp_precious_remove(object); } inline SEXP Rcpp_ReplaceObject(SEXP x, SEXP y) { diff --git a/src/barrier.cpp b/src/barrier.cpp index 86b05e97e..796ae0705 100644 --- a/src/barrier.cpp +++ b/src/barrier.cpp @@ -1,8 +1,6 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 4 -*- -// // barrier.cpp: Rcpp R/C++ interface class library -- write barrier // -// Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois +// Copyright (C) 2010 - 2020 Dirk Eddelbuettel and Romain Francois // // This file is part of Rcpp. // @@ -88,6 +86,42 @@ static SEXP Rcpp_cache = R_NilValue; #define RCPP_HASH_CACHE_INITIAL_SIZE 1024 #endif +namespace Rcpp { +static SEXP Rcpp_precious = R_NilValue; +// [[Rcpp::register]] +void Rcpp_precious_init() { + Rcpp_precious = CONS(R_NilValue,R_NilValue);// set up + R_PreserveObject(Rcpp_precious); // and protect +} +// [[Rcpp::register]] +void Rcpp_precious_teardown() { + R_ReleaseObject(Rcpp_precious); // release resource +} +// [[Rcpp::register]] +void Rcpp_precious_preserve(SEXP object) { + SETCDR(Rcpp_precious, CONS(object, CDR(Rcpp_precious))); +} +SEXP DeleteFromList(SEXP object, SEXP list) { + if (CAR(list) == object) + return CDR(list); + else { + SEXP last = list; + for (SEXP head = CDR(list); head != R_NilValue; head = CDR(head)) { + if (CAR(head) == object) { + SETCDR(last, CDR(head)); + return list; + } + else last = head; + } + return list; + } +} +// [[Rcpp::register]] +void Rcpp_precious_remove(SEXP object) { + SETCDR(Rcpp_precious, DeleteFromList(object, CDR(Rcpp_precious))); +} +} + // only used for debugging SEXP get_rcpp_cache() { if (! Rcpp_cache_know) { diff --git a/src/rcpp_init.cpp b/src/rcpp_init.cpp index 4a6e00ccc..b8be84bf8 100644 --- a/src/rcpp_init.cpp +++ b/src/rcpp_init.cpp @@ -1,8 +1,6 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- -// // Rcpp_init.cpp : Rcpp R/C++ interface class library -- Initialize and register // -// Copyright (C) 2010 - 2017 John Chambers, Dirk Eddelbuettel and Romain Francois +// Copyright (C) 2010 - 2020 John Chambers, Dirk Eddelbuettel and Romain Francois // // This file is part of Rcpp. // @@ -121,22 +119,27 @@ void registerFunctions(){ RCPP_REGISTER(error_occured) RCPP_REGISTER(rcpp_get_current_error) // RCPP_REGISTER(print) + RCPP_REGISTER(Rcpp_precious_init) + RCPP_REGISTER(Rcpp_precious_teardown) + RCPP_REGISTER(Rcpp_precious_preserve) + RCPP_REGISTER(Rcpp_precious_remove) #undef RCPP_REGISTER } - -extern "C" void R_unload_Rcpp(DllInfo *) { // #nocov start - // Release resources -} // #nocov end +extern "C" void R_unload_Rcpp(DllInfo *) { // #nocov start + Rcpp::Rcpp_precious_teardown(); // release resource +} // #nocov end extern "C" void R_init_Rcpp(DllInfo* dllinfo) { setCurrentScope(0); - registerFunctions(); // call wrapper to register export symbols + registerFunctions(); // call wrapper to register export symbols + + R_useDynamicSymbols(dllinfo, FALSE); // set up symbol symbol lookup (cf R 3.4.0) - R_useDynamicSymbols(dllinfo, FALSE); // set up symbol symbol lookup (cf R 3.4.0) + init_Rcpp_cache(); // init the cache - init_Rcpp_cache(); // init the cache + Rcpp::Rcpp_precious_init(); - init_Rcpp_routines(dllinfo); // init routines + init_Rcpp_routines(dllinfo); // init routines }