second pass at 'precious_{preserve,remove}'

RcppCore · Jan 17, 2021 · eb6b219 · eb6b219
1 parent f4342ae
commit eb6b219
Show file tree

Hide file tree

Showing 9 changed files with 281 additions and 91 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: Rcpp
 Title: Seamless R and C++ Integration
-Version: 1.0.6
-Date: 2021-01-14
+Version: 1.0.6.1
+Date: 2021-01-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/String.h b/inst/include/Rcpp/String.h
diff --git a/inst/include/Rcpp/config.h b/inst/include/Rcpp/config.h
@@ -30,7 +30,7 @@
 #define RCPP_VERSION_STRING     "1.0.6"
 
 // the current source snapshot
-#define RCPP_DEV_VERSION        RcppDevVersion(1,0,6,0)
-#define RCPP_DEV_VERSION_STRING "1.0.6.0"
+#define RCPP_DEV_VERSION        RcppDevVersion(1,0,6,1)
+#define RCPP_DEV_VERSION_STRING "1.0.6.1"
 
 #endif
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();
+    SEXP Rcpp_precious_preserve(SEXP object);
+    void Rcpp_precious_remove(SEXP token);
 }
 
 SEXP          rcpp_get_stack_trace();
@@ -127,6 +132,27 @@ namespace Rcpp {
         return fun(x);
     }
 
+    inline attribute_hidden void Rcpp_precious_init() {
+        typedef void (*Fun)(void);
+        static Fun fun = GET_CALLABLE("Rcpp_precious_init");
+        fun();
+    }
+    inline attribute_hidden void Rcpp_precious_teardown() {
+        typedef void (*Fun)(void);
+        static Fun fun = GET_CALLABLE("Rcpp_precious_teardown");
+        fun();
+    }
+    inline attribute_hidden SEXP Rcpp_precious_preserve(SEXP object) {
+        typedef SEXP (*Fun)(SEXP);
+        static Fun fun = GET_CALLABLE("Rcpp_precious_preserve");
+        return fun(object);
+    }
+    inline attribute_hidden void Rcpp_precious_remove(SEXP token) {
+        typedef void (*Fun)(SEXP);
+        static Fun fun = GET_CALLABLE("Rcpp_precious_remove");
+        fun(token);
+    }
+
 }
 
 // The 'attribute_hidden' used here is a simple precessor defined from

diff --git a/inst/include/Rcpp/storage/PreserveStorage.h b/inst/include/Rcpp/storage/PreserveStorage.h
@@ -7,15 +7,20 @@ namespace Rcpp{
     class PreserveStorage {
     public:
 
-        PreserveStorage() : data(R_NilValue){}
+        PreserveStorage() : data(R_NilValue), token(R_NilValue){}
 
         ~PreserveStorage(){
-            Rcpp_ReleaseObject(data) ;
+            Rcpp_ReleaseObject(token) ;
             data = R_NilValue;
+            token = R_NilValue;
         }
 
         inline void set__(SEXP x){
-            data = Rcpp_ReplaceObject(data, x) ;
+            if (data != x) {
+                data = x;
+                Rcpp_ReleaseObject(token);
+                token = Rcpp_PreserveObject(data);
+            }
 
             // calls the update method of CLASS
             // this is where to react to changes in the underlying SEXP
@@ -28,7 +33,9 @@ namespace Rcpp{
 
         inline SEXP invalidate__(){
             SEXP out = data ;
+            Rcpp_ReleaseObject(token);
             data = R_NilValue ;
+            token = R_NilValue ;
             return out ;
         }
 
@@ -48,6 +55,7 @@ namespace Rcpp{
 
     private:
         SEXP data ;
+        SEXP token ;
     } ;
 
 }

diff --git a/inst/include/Rcpp/traits/named_object.h b/inst/include/Rcpp/traits/named_object.h
@@ -41,19 +41,22 @@ template <typename T> class named_object {
 template <> class named_object<SEXP> {
 public:                                              // #nocov start
     named_object( const std::string& name_, const SEXP& o_):
-        name(name_), object(o_) {
-        R_PreserveObject(object);
+        name(name_), object(o_), token(R_NilValue) {
+        token = Rcpp_precious_preserve(object);
     }
 
     named_object( const named_object<SEXP>& other ) :
-        name(other.name), object(other.object) {
-        R_PreserveObject(object);
+        name(other.name), object(other.object), token(other.token) {
+        token = Rcpp_precious_preserve(object);
     }
     ~named_object() {
-        R_ReleaseObject(object);
+        Rcpp_precious_remove(token);
+
     }                          	                     // #nocov end
     const std::string& name;
     SEXP object;
+private:
+    SEXP 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);
 
+    SEXP Rcpp_precious_preserve(SEXP object);
+    void Rcpp_precious_remove(SEXP token);
+
     namespace internal {
         SEXP Rcpp_eval_impl(SEXP expr, SEXP env);
     }
@@ -87,28 +90,12 @@ namespace Rcpp {
         template <typename T> class named_object;
     }
 
-    inline SEXP Rcpp_PreserveObject(SEXP x) {
-        if (x != R_NilValue) {
-            R_PreserveObject(x);
-        }
-        return x;
-    }
-
-    inline void Rcpp_ReleaseObject(SEXP x) {
-        if (x != R_NilValue) {
-            R_ReleaseObject(x);
-        }
+    inline SEXP Rcpp_PreserveObject(SEXP object) {
+        return Rcpp_precious_preserve(object);
     }
 
-    inline SEXP Rcpp_ReplaceObject(SEXP x, SEXP y) {
-
-        // if we are setting to the same SEXP as we already have, do nothing
-        if (x != y) {
-            Rcpp_ReleaseObject(x);
-            Rcpp_PreserveObject(y);
-        }
-
-        return y;
+    inline void Rcpp_ReleaseObject(SEXP token) {
+        Rcpp_precious_remove(token);
     }
 
 }

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,46 @@ 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]]
+SEXP Rcpp_precious_preserve(SEXP object) {
+    if (object == R_NilValue) {
+        return R_NilValue;
+    }
+    PROTECT(object);
+    SEXP cell = PROTECT(CONS(Rcpp_precious, CDR(Rcpp_precious)));
+    SET_TAG(cell, object);
+    SETCDR(Rcpp_precious, cell);
+    if (CDR(cell) != R_NilValue) {
+        SETCAR(CDR(cell), cell);
+    }
+    UNPROTECT(2);
+    return cell;
+}
+// [[Rcpp::register]]
+void Rcpp_precious_remove(SEXP token) {
+    if (token == R_NilValue) {
+        return;
+    }
+    SEXP before = CAR(token);
+    SEXP after = CDR(token);
+    SETCDR(before, after);
+    if (after != R_NilValue) {
+        SETCAR(after, before);
+    }
+}
+}
+
 // 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
 }