rework hasExternalPointer internals (#12408)

* + hasExternalPointer() * fix pairlistHasExternalPointer() and envHasExternalPointer() * simplify rs_hasExternalPtr() * misunderstood the role of nullPtr * handle already evaluated promises * + getWeakRefKey(), getWeakRefValue() * tests for hasExternalPointer() covering most cases * hunt for external pointers in CLOSXP * move frameBindingIsActive() to where used * update promise check so that eval.env() is local env, not global env * add makeExternalPtr(void*, SEXP, SEXP) * use .Call("rs_newTestExternalPointer")
rstudio · Dec 14, 2022 · b735c15 · b735c15 · netique · Dec 14, 2022
1 parent 5189a79
commit b735c15
Show file tree

Hide file tree

Showing 5 changed files with 328 additions and 56 deletions.
diff --git a/src/cpp/r/RSexp.cpp b/src/cpp/r/RSexp.cpp
@@ -689,6 +689,11 @@ bool isPrimitiveEnvironment(SEXP object)
    return TYPEOF(object) == ENVSXP;
 }
 
+bool isUserDefinedDatabase(SEXP object)
+{
+   return OBJECT(object) && Rf_inherits(object, "UserDefinedDatabase");
+}
+
 bool isNumeric(SEXP object)
 {
    return Rf_isNumeric(object);
@@ -788,6 +793,16 @@ SEXP makeWeakRef(SEXP key, SEXP val, R_CFinalizer_t fun, Rboolean onexit)
    return R_MakeWeakRefC(key, val, fun, onexit);
 }
 
+SEXP getWeakRefKey(SEXP ref)
+{
+   return VECTOR_ELT(ref, 0);
+}
+
+SEXP getWeakRefValue(SEXP ref)
+{
+   return VECTOR_ELT(ref, 1);
+}
+
 void registerFinalizer(SEXP s, R_CFinalizer_t fun)
 {
    R_RegisterCFinalizer(s, fun);
@@ -802,6 +817,11 @@ SEXP makeExternalPtr(void* ptr, R_CFinalizer_t fun, Protect* pProtect)
    return s;
 }
 
+SEXP makeExternalPtr(void* ptr, SEXP prot, SEXP tag) 
+{
+   return R_MakeExternalPtr(ptr, prot, tag);
+}
+
 void* getExternalPtrAddr(SEXP extptr)
 {
    return R_ExternalPtrAddr(extptr);

diff --git a/src/cpp/r/include/r/RSexp.hpp b/src/cpp/r/include/r/RSexp.hpp
@@ -104,6 +104,7 @@ bool isNull(SEXP object);
 bool isEnvironment(SEXP object);
 bool isPrimitiveEnvironment(SEXP object);
 bool isNumeric(SEXP object);
+bool isUserDefinedDatabase(SEXP object);
 
 // type coercions
 std::string asString(SEXP object);
@@ -127,8 +128,11 @@ bool isExternalPointer(SEXP object);
 bool isNullExternalPointer(SEXP object);
 
 SEXP makeWeakRef(SEXP key, SEXP val, R_CFinalizer_t fun, Rboolean onexit);
+SEXP getWeakRefKey(SEXP ref);
+SEXP getWeakRefValue(SEXP ref);
 void registerFinalizer(SEXP s, R_CFinalizer_t fun);
 SEXP makeExternalPtr(void* ptr, R_CFinalizer_t fun, Protect* protect);
+SEXP makeExternalPtr(void* ptr, SEXP prot, SEXP tag);
 void* getExternalPtrAddr(SEXP extptr);
 void clearExternalPtr(SEXP extptr);
 

diff --git a/src/cpp/session/modules/SessionEnvironment.R b/src/cpp/session/modules/SessionEnvironment.R
@@ -624,6 +624,11 @@
       val1
 })
 
+.rs.addFunction("hasExternalPointer", function(object, nullPtr = FALSE)
+{
+   .Call("rs_hasExternalPointer", object, nullPtr, PACKAGE = "(embedding)")
+})
+
 .rs.addFunction("describeObject", function(env, objName, computeSize = TRUE)
 {
    obj <- get(objName, env)
@@ -647,7 +652,7 @@
    # opt-in to checking for null pointers if required.
    checkNullPtr <- .rs.readUiPref("check_null_external_pointers")
    hasNullPtr <- if (identical(checkNullPtr, TRUE))
-      .Call("rs_hasExternalPointer", obj, TRUE, PACKAGE = "(embedding)")
+      .rs.hasExternalPointer(obj, TRUE)
    else
       FALSE
 

diff --git a/src/cpp/session/modules/environment/SessionEnvironment.cpp b/src/cpp/session/modules/environment/SessionEnvironment.cpp
@@ -34,6 +34,7 @@
 #include <session/SessionSourceDatabase.hpp>
 #include <session/SessionPersistentState.hpp>
 #include <session/prefs/UserPrefs.hpp>
+#include <r/RSxpInfo.hpp>
 
 #include "EnvironmentUtils.hpp"
 
@@ -119,95 +120,211 @@ bool handleRBrowseEnv(const core::FilePath& filePath)
    }
 }
 
-bool hasExternalPtrImpl(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
+bool hasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited);
+
+bool pairlistHasExternalPointer(SEXP list, bool nullPtr, std::set<SEXP>& visited)
+{
+   while(list != R_NilValue)
+   {
+      if (hasExternalPointer(CAR(list), nullPtr, visited))
+         return true;
+
+      list = CDR(list);
+   }
+
+   return false;
+}
+
+bool attributesHasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
 {
-   // if we've already visited this SEXP, bail
-   if (visited.count(obj))
+   return pairlistHasExternalPointer(ATTRIB(obj), nullPtr, visited);
+}
+
+bool listHasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
+{
+   R_xlen_t n = XLENGTH(obj);
+   for (R_xlen_t i = 0; i < n; i++)
+   {
+      if (hasExternalPointer(VECTOR_ELT(obj, i), nullPtr, visited))
+         return true;
+   }
+   return false;
+}
+
+namespace {
+bool frameBindingIsActive(SEXP binding) 
+{
+   static unsigned int ACTIVE_BINDING_MASK = (1<<15);
+   return reinterpret_cast<r::sxpinfo*>(binding)->gp & ACTIVE_BINDING_MASK;
+}
+}
+
+bool frameHasExternalPointer(SEXP frame, bool nullPtr, std::set<SEXP>& visited)
+{
+   while(frame != R_NilValue)
+   {
+      if (!frameBindingIsActive(frame) && hasExternalPointer(CAR(frame), nullPtr, visited))
+         return true;
+
+      frame = CDR(frame);
+   }
+
+   return false;
+}
+
+bool envHasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
+{
+   SEXP hash = HASHTAB(obj);
+   if (hash == R_NilValue)
+      return frameHasExternalPointer(FRAME(obj), nullPtr, visited);
+
+   R_xlen_t n = XLENGTH(hash);
+   for (R_xlen_t i = 0; i < n; i++)
+   {
+      if (frameHasExternalPointer(VECTOR_ELT(hash, i), nullPtr, visited))
+         return true;
+   }
+   return false;
+}
+
+bool weakrefHasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
+{
+   SEXP key = r::sexp::getWeakRefKey(obj);
+   if (key != R_NilValue)
+   {
+      if (hasExternalPointer(key, nullPtr, visited))
+         return true;
+
+      // only consider the value if the key is not NULL
+      if (hasExternalPointer(r::sexp::getWeakRefValue(obj), nullPtr, visited))
+         return true;
+   }
+
+   return false;
+}
+
+bool hasExternalPointer(SEXP obj, bool nullPtr, std::set<SEXP>& visited)
+{
+   if (obj == R_NilValue || visited.count(obj))
       return false;
 
    // mark SEXP as visited
    visited.insert(obj);
 
-   // list the contents of this environment
-   std::vector<r::sexp::Variable> vars;
-   r::sexp::Protect rProtect;
-   if (TYPEOF(obj) == S4SXP)
+   // check if this is an external pointer
+   if (r::sexp::isExternalPointer(obj)) 
    {
-      // for S4 objects, list the attributes (which correspond to slots)
-      r::sexp::listNamedAttributes(obj, &rProtect, &vars);
+      // NOTE: this includes UserDefinedDatabase, aka 
+      //       external pointers to R_ObjectTable
+
+      // when nullPtr is true, only return true for null pointer xp
+      // otherwise only return true for non null pointer xp
+      if (nullPtr == (r::sexp::getExternalPtrAddr(obj) == nullptr))
+         return true;
+
+      if (hasExternalPointer(EXTPTR_PROT(obj), nullPtr, visited))
+         return true;
+
+      if (hasExternalPointer(EXTPTR_TAG(obj), nullPtr, visited))
+         return true;
    }
-   else
+
+   switch(TYPEOF(obj))
    {
-      // not S4, coerce to environment
-      SEXP envir = R_NilValue;
-      if (TYPEOF(obj) == ENVSXP)
+      case ENVSXP: 
       {
-         // we were given a primitive environment (ENVSXP)
-         envir = obj;
+         if (envHasExternalPointer(obj, nullPtr, visited))
+            return true;
+         break;
       }
-      else
+      case VECSXP:
+      case EXPRSXP:
       {
-         // convert the passed environment into a primitive environment; this is required so that
-         // e.g. reference objects that subclass 'environment' can be introspected below
-         Error error = r::sexp::asPrimitiveEnvironment(obj, &envir, &rProtect);
-         if (error)
+         if (listHasExternalPointer(obj, nullPtr, visited))
+            return true;
+         break;
+      }
+
+      case LISTSXP:
+      case LANGSXP:
+      {
+         if (pairlistHasExternalPointer(obj, nullPtr, visited))
+            return true;
+         break;
+      }
+
+      case WEAKREFSXP:
+      {
+         if (weakrefHasExternalPointer(obj, nullPtr, visited))
+            return true;
+
+         break;
+      }
+      case PROMSXP: 
+      {
+         SEXP value = PRVALUE(obj);
+         if (value != R_UnboundValue)
+         {
+            if (hasExternalPointer(value, nullPtr, visited))
+               return true;
+         }
+         else 
          {
-            // can't search in here
+            if (hasExternalPointer(PRCODE(obj), nullPtr, visited))
+               return true;
+
+            if (hasExternalPointer(PRENV(obj), nullPtr, visited))
+               return true;
+
             return false;
          }
+         break;
       }
+      case CLOSXP:
+      {
+         if (hasExternalPointer(FORMALS(obj), nullPtr, visited))
+            return true;
+
+         if (hasExternalPointer(BODY(obj), nullPtr, visited))
+            return true;
 
-      r::sexp::listEnvironment(envir,
-                               true,  // include all values
-                               false, // don't include last dot
-                               &vars);
+         if (hasExternalPointer(CLOENV(obj), nullPtr, visited))
+            return true;
+      }
+      default:
+         break;
    }
 
-   // check for external pointers
-   for (std::vector<r::sexp::Variable>::iterator it = vars.begin(); it != vars.end(); it++)
+   // check attributes, this includes slots for S4 objects
+   if (attributesHasExternalPointer(obj, nullPtr, visited))
+      return true;
+
+   // altrep objects might be implemented with external pointers
+   if (isAltrep(obj))
    {
-      if (r::sexp::isExternalPointer(it->second) &&
-          r::sexp::isNullExternalPointer(it->second) == nullPtr)
-      {
+      if (hasExternalPointer(CAR(obj), nullPtr, visited))
          return true;
-      }
 
-      if (r::sexp::isPrimitiveEnvironment(it->second) || TYPEOF(it->second) == S4SXP)
-      {
-         // if this object is itself an environment, check it recursively for external pointers.
-         // (we do this only if there's sufficient recursion depth remaining)
-         if (hasExternalPtrImpl(it->second, nullPtr, visited))
-            return true;
-      }
-   }
+      if (hasExternalPointer(CDR(obj), nullPtr, visited))
+         return true;
+   } 
 
    return false;
 }
 
-
 bool hasExternalPtr(SEXP obj,      // environment to search for external pointers
                     bool nullPtr)  // whether to look for NULL pointers
 {
    std::set<SEXP> visited;
-   return hasExternalPtrImpl(obj, nullPtr, visited);
+   return hasExternalPointer(obj, nullPtr, visited);
 }
 
 SEXP rs_hasExternalPointer(SEXP objSEXP, SEXP nullSEXP)
 {
-   bool nullPtr = r::sexp::asLogical(nullSEXP);
    r::sexp::Protect protect;
-   bool hasPtr = false;
-   if (r::sexp::isExternalPointer(objSEXP))
-   {
-      // object is an external pointer itself
-      hasPtr = r::sexp::isNullExternalPointer(objSEXP) == nullPtr;
-   }
-   else if (r::sexp::isPrimitiveEnvironment(objSEXP) || TYPEOF(objSEXP) == S4SXP)
-   {
-      // object is an environment; check it for external pointers
-      hasPtr = hasExternalPtr(objSEXP, nullPtr);
-   }
-   return r::sexp::create(hasPtr, &protect);
+
+   bool nullPtr = r::sexp::asLogical(nullSEXP);
+   return r::sexp::create(hasExternalPtr(objSEXP, nullPtr), &protect);
 }
 
 // Does an object contain an ALTREP anywhere? ALTREP (alternative representation) objects often
@@ -225,6 +342,12 @@ SEXP rs_isAltrep(SEXP obj)
    return r::sexp::create(isAltrep(obj), &protect);
 }
 
+SEXP rs_newTestExternalPointer(SEXP nullSEXP)
+{
+   bool nullPtr = r::sexp::asLogical(nullSEXP);
+   return r::sexp::makeExternalPtr(nullPtr ? nullptr : R_EmptyEnv, R_NilValue, R_NilValue);
+}
+
 // Construct a simulated source reference from a context containing a
 // function being debugged, and either the context containing the current
 // invocation or a string containing the last debug output from R.
@@ -1279,6 +1402,7 @@ Error initialize()
    RS_REGISTER_CALL_METHOD(rs_hasAltrep);
    RS_REGISTER_CALL_METHOD(rs_isAltrep);
    RS_REGISTER_CALL_METHOD(rs_dumpContexts);
+   RS_REGISTER_CALL_METHOD(rs_newTestExternalPointer);
 
    // subscribe to events
    using boost::bind;