first pass at 'precious_{preserve,remove}'

with thanks to @ltierney for the report in #1081 as well as a suggested alternative this branch reworks his idea somewhat to better fit how Rcpp sets itself up
RcppCore · May 17, 2020 · 5e5de18 · 5e5de18
1 parent 95d0854
commit 5e5de18
Show file tree

Hide file tree

Showing 9 changed files with 111 additions and 32 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: Rcpp
 Title: Seamless R and C++ Integration
-Version: 1.0.4.10
-Date: 2020-04-30
+Version: 1.0.4.11
+Date: 2020-05-17
 Author: Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou,
  Nathan Russell, Douglas Bates and John Chambers
 Maintainer: Dirk Eddelbuettel <edd@debian.org>

diff --git a/inst/include/Rcpp/config.h b/inst/include/Rcpp/config.h
@@ -30,7 +30,7 @@
 #define RCPP_VERSION_STRING     "1.0.4"
 
 // the current source snapshot
-#define RCPP_DEV_VERSION        RcppDevVersion(1,0,4,10)
-#define RCPP_DEV_VERSION_STRING "1.0.4.10"
+#define RCPP_DEV_VERSION        RcppDevVersion(1,0,4,11)
+#define RCPP_DEV_VERSION_STRING "1.0.4.11"
 
 #endif
diff --git 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
@@ -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
@@ -42,15 +42,19 @@ template <> class named_object<SEXP> {
 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<SEXP>& 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
@@ -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<SEXP> 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
@@ -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 <typename T> 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
@@ -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
@@ -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
 }