second pass at 'precious_{preserve,remove}'

Enchufa2 · eddelbuettel · commit 21ddbb9aca10 · 2021-01-18T11:13:49.000-06:00
diff --git a/inst/include/Rcpp/String.h b/inst/include/Rcpp/String.h
diff --git a/inst/include/Rcpp/exceptions.h b/inst/include/Rcpp/exceptions.h
@@ -148,8 +148,7 @@ inline void resumeJump(SEXP token) {
     if (isLongjumpSentinel(token)) {
         token = getLongjumpToken(token);
     }
-    //::R_ReleaseObject(token);
-    Rcpp_precious_remove(token);
+    ::R_ReleaseObject(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
@@ -41,8 +41,8 @@ namespace Rcpp{
 
     void Rcpp_precious_init();
     void Rcpp_precious_teardown();
-    void Rcpp_precious_preserve(SEXP object);
-    void Rcpp_precious_remove(SEXP object);
+    SEXP Rcpp_precious_preserve(SEXP object);
+    void Rcpp_precious_remove(SEXP token);
 }
 
 SEXP          rcpp_get_stack_trace();
@@ -133,24 +133,24 @@ namespace Rcpp {
     }
 
     inline attribute_hidden void Rcpp_precious_init() {
-        typedef int (*Fun)(void);
+        typedef void (*Fun)(void);
         static Fun fun = GET_CALLABLE("Rcpp_precious_init");
         fun();
     }
     inline attribute_hidden void Rcpp_precious_teardown() {
-        typedef int (*Fun)(void);
+        typedef void (*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);
+    inline attribute_hidden SEXP Rcpp_precious_preserve(SEXP object) {
+        typedef SEXP (*Fun)(SEXP);
         static Fun fun = GET_CALLABLE("Rcpp_precious_preserve");
-        fun(object);
+        return fun(object);
     }
-    inline attribute_hidden void Rcpp_precious_remove(SEXP object) {
-        typedef const char* (*Fun)(SEXP);
+    inline attribute_hidden void Rcpp_precious_remove(SEXP token) {
+        typedef void (*Fun)(SEXP);
         static Fun fun = GET_CALLABLE("Rcpp_precious_remove");
-        fun(object);
+        fun(token);
     }
 
 }
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,23 +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);
-        Rcpp_precious_preserve(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);
-        Rcpp_precious_preserve(object);
+        name(other.name), object(other.object), token(other.token) {
+        token = Rcpp_precious_preserve(object);
     }
     ~named_object() {
-        //R_ReleaseObject(object);
-        Rcpp_precious_remove(object);
+        Rcpp_precious_remove(token);
 
     }                          	                     // #nocov end
     const std::string& name;
     SEXP object;
+private:
+    SEXP token;
 };
 
 
diff --git a/inst/include/Rcpp/unwindProtect.h b/inst/include/Rcpp/unwindProtect.h
@@ -64,8 +64,7 @@ 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);
-        Rcpp::Rcpp_precious_preserve(token);
+        ::R_PreserveObject(token);
 
         throw LongjumpException(token);
     }
diff --git a/inst/include/RcppCommon.h b/inst/include/RcppCommon.h
@@ -77,8 +77,8 @@ 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);
+    SEXP Rcpp_precious_preserve(SEXP object);
+    void Rcpp_precious_remove(SEXP token);
 
     namespace internal {
         SEXP Rcpp_eval_impl(SEXP expr, SEXP env);
@@ -90,35 +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 SEXP Rcpp_PreserveObject(SEXP object) {
-        Rcpp_precious_preserve(object);
-        return object;
+        return Rcpp_precious_preserve(object);
     }
 
-    // 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) {
-
-        // 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
@@ -90,35 +90,39 @@ 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_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;
+    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 object) {
-    SETCDR(Rcpp_precious, DeleteFromList(object, CDR(Rcpp_precious)));
+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);
+    }
 }
 }
 

Original file line number	Diff line number	Diff line change
`@@ -41,8 +41,8 @@ namespace Rcpp{`
`41`	`41`
`42`	`42`	`void Rcpp_precious_init();`
`43`	`43`	`void Rcpp_precious_teardown();`
`44`		`- void Rcpp_precious_preserve(SEXP object);`
`45`		`- void Rcpp_precious_remove(SEXP object);`
	`44`	`+ SEXP Rcpp_precious_preserve(SEXP object);`
	`45`	`+ void Rcpp_precious_remove(SEXP token);`
`46`	`46`	`}`
`47`	`47`
`48`	`48`	`SEXP rcpp_get_stack_trace();`
`@@ -133,24 +133,24 @@ namespace Rcpp {`
`133`	`133`	`}`
`134`	`134`
`135`	`135`	`inline attribute_hidden void Rcpp_precious_init() {`
`136`		`- typedef int (*Fun)(void);`
	`136`	`+ typedef void (*Fun)(void);`
`137`	`137`	`static Fun fun = GET_CALLABLE("Rcpp_precious_init");`
`138`	`138`	`fun();`
`139`	`139`	`}`
`140`	`140`	`inline attribute_hidden void Rcpp_precious_teardown() {`
`141`		`- typedef int (*Fun)(void);`
	`141`	`+ typedef void (*Fun)(void);`
`142`	`142`	`static Fun fun = GET_CALLABLE("Rcpp_precious_teardown");`
`143`	`143`	`fun();`
`144`	`144`	`}`
`145`		`- inline attribute_hidden void Rcpp_precious_preserve(SEXP object) {`
`146`		`- typedef const char* (*Fun)(SEXP);`
	`145`	`+ inline attribute_hidden SEXP Rcpp_precious_preserve(SEXP object) {`
	`146`	`+ typedef SEXP (*Fun)(SEXP);`
`147`	`147`	`static Fun fun = GET_CALLABLE("Rcpp_precious_preserve");`
`148`		`- fun(object);`
	`148`	`+ return fun(object);`
`149`	`149`	`}`
`150`		`- inline attribute_hidden void Rcpp_precious_remove(SEXP object) {`
`151`		`- typedef const char* (*Fun)(SEXP);`
	`150`	`+ inline attribute_hidden void Rcpp_precious_remove(SEXP token) {`
	`151`	`+ typedef void (*Fun)(SEXP);`
`152`	`152`	`static Fun fun = GET_CALLABLE("Rcpp_precious_remove");`
`153`		`- fun(object);`
	`153`	`+ fun(token);`
`154`	`154`	`}`
`155`	`155`
`156`	`156`	`}`
Original file line number	Diff line number	Diff line change
`@@ -64,8 +64,7 @@ inline SEXP unwindProtect(SEXP (callback)(void data), void* data) {`
`64`	`64`	`// in C++ destructors. Can't use PROTECT() for this because`
`65`	`65`	`// UNPROTECT() might be called in a destructor, for instance if a`
`66`	`66`	`// Shield<SEXP> is on the stack.`
`67`		`- //::R_PreserveObject(token);`
`68`		`- Rcpp::Rcpp_precious_preserve(token);`
	`67`	`+ ::R_PreserveObject(token);`
`69`	`68`
`70`	`69`	`throw LongjumpException(token);`
`71`	`70`	`}`