Merge pull request #1133 from Enchufa2/feature/rcpp_precious_2

second pass at 'precious_{preserve,remove}' (addresses #382, #1081)

ChangeLog

@@ -1,10 +1,37 @@
+2021-01-17  Iñaki Ucar  <iucar@fedoraproject.org>
+
+	* inst/include/Rcpp/String.h: Use Rcpp_{Preserve,Release}Object
+	throughout which connects to Rcpp_precious_* routines
+	* inst/include/Rcpp/exceptions.h: Use Rcpp_ReleaseObject
+	* inst/include/Rcpp/routines.h: Several corrections and refinements
+	* inst/include/Rcpp/storage/PreserveStorage.h: Ditto
+	* inst/include/Rcpp/traits/named_object.h: Ditto
+	* inst/include/Rcpp/unwuindProtect.h: Ditto
+	* inst/include/RcppCommon.h: Ditto
+	* src/barrier.cpp: Ditto
+
 2021-01-17  Dirk Eddelbuettel  <edd@debian.org>
 
         * DESCRIPTION (Version, Date): Roll minor version
         * inst/include/Rcpp/config.h: Idem
 
+	[ these were originally committed 17 May 2020 and have been rebased ]
+	* src/barrier.cpp: Implement Rcpp_precious_{init,teardown,preserve,remove}
+	* src/rcpp_init.c: Register cpp_precious_{init,teardown,preserve,remove}
+	and call from R_{init,unload}_Rcpp
+	* inst/include/Rcpp/routines.h: Declare Rcpp_precious_{init,teardown,
+	preserve,remove}
+	* inst/include/Rcpp/exceptions.h: Use Rcpp_precious_remove
+	* inst/include/Rcpp/traits/named_object.h: Use
+	Rcpp_precious_{preserve,remove}
+	* inst/include/Rcpp/unwuindProtect.h: Use Rcpp_precious_preserve
+	* inst/include/RcppCommon.h: Use Rcpp_precious_{preserve,remove}
+
 2021-01-16  Dirk Eddelbuettel  <edd@debian.org>
 
+        * DESCRIPTION (Version, Date): Roll minor version
+        * inst/include/Rcpp/config.h: Idem
+
 	* tests/tinytest.R: Test for CODECOV when deciding to run extensive
 	tests or just a subset, and set CI=true to enable run full set
 

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Rcpp
 Title: Seamless R and C++ Integration
-Version: 1.0.6.1
+Version: 1.0.6.2
 Date: 2021-01-17
 Author: Dirk Eddelbuettel, Romain Francois, JJ Allaire, Kevin Ushey, Qiang Kou,
  Nathan Russell, Douglas Bates and John Chambers

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,1)
-#define RCPP_DEV_VERSION_STRING "1.0.6.1"
+#define RCPP_DEV_VERSION        RcppDevVersion(1,0,6,2)
+#define RCPP_DEV_VERSION_STRING "1.0.6.2"
 
 #endif

inst/include/Rcpp/exceptions.h

@@ -2,6 +2,7 @@
 // exceptions.h: Rcpp R/C++ interface class library -- exceptions
 //
 // Copyright (C) 2010 - 2020  Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2021 - 2020  Dirk Eddelbuettel, Romain Francois and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //

inst/include/Rcpp/routines.h

@@ -1,7 +1,9 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
+
+// routines.h: Rcpp R/C++ interface class library -- callable function setup
 //
-// Copyright (C) 2013  Romain Francois
-// Copyright (C) 2015  Dirk Eddelbuettel
+// Copyright (C) 2013 - 2014 Romain Francois
+// Copyright (C) 2015 - 2020 Romain Francois and Dirk Eddelbuettel
+// Copyright (C) 2021        Romain Francois, Dirk Eddelbuettel and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //
@@ -38,6 +40,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 +134,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

inst/include/Rcpp/storage/PreserveStorage.h

@@ -1,3 +1,24 @@
+
+// PreserveStorage.h: Rcpp R/C++ interface class library -- helper class
+//
+// Copyright (C) 2013 - 2020  Romain Francois
+// Copyright (C) 2021         Romain Francois and Iñaki Ucar
+//
+// 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 <http://www.gnu.org/licenses/>.
+
 #ifndef Rcpp_PreserveStorage_h
 #define Rcpp_PreserveStorage_h
 
@@ -7,15 +28,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 +54,9 @@ namespace Rcpp{
 
         inline SEXP invalidate__(){
             SEXP out = data ;
+            Rcpp_ReleaseObject(token);
             data = R_NilValue ;
+            token = R_NilValue ;
             return out ;
         }
 
@@ -48,6 +76,7 @@ namespace Rcpp{
 
     private:
         SEXP data ;
+        SEXP token ;
     } ;
 
 }

inst/include/Rcpp/traits/named_object.h

@@ -1,9 +1,8 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
-/* :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1: */
-//
+
 // named_object.h: Rcpp R/C++ interface class library -- named SEXP
 //
-// Copyright (C) 2010 - 2017  Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2010 - 2020  Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2021         Dirk Eddelbuettel, Romain Francois and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //
@@ -41,19 +40,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;
 };
 
 

inst/include/Rcpp/unwindProtect.h

@@ -1,6 +1,8 @@
+
 // unwind.h: Rcpp R/C++ interface class library -- Unwind Protect
 //
-// Copyright (C) 2018 RStudio
+// Copyright (C) 2018 - 2020  RStudio
+// Copyright (C) 2021         RStudio, Dirk Eddelbuettel and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //

inst/include/RcppCommon.h

@@ -1,9 +1,10 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
+
 //
 // RcppCommon.h: Rcpp R/C++ interface class library -- common include and defines statements
 //
 // Copyright (C) 2008 - 2009  Dirk Eddelbuettel
-// Copyright (C) 2009 - 2017  Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2009 - 2020  Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2021         Dirk Eddelbuettel, Romain Francois and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //
@@ -77,6 +78,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 +91,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);
     }
 
 }

src/barrier.cpp

@@ -1,8 +1,8 @@
-// -*- 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
+// Copyright (C) 2021         Dirk Eddelbuettel, Romain Francois and Iñaki Ucar
 //
 // This file is part of Rcpp.
 //
@@ -88,6 +88,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) {

src/rcpp_init.cpp

@@ -1,8 +1,7 @@
-// -*- 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 +120,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
 }