Merge pull request #1697 from rstudio/feature/external-ptr-suspend

Don't suspend sessions with external pointers (fixes #1696)

src/cpp/r/RSexp.cpp

@@ -327,6 +327,36 @@ void listEnvironment(SEXP env,
    }
 }
 
+
+void listNamedAttributes(SEXP obj, Protect *pProtect, std::vector<Variable>* pVariables)
+{
+   // reset passed vars
+   pVariables->clear();
+
+   // extract the attributes and ensure we got a pairlist
+   SEXP attrs = ATTRIB(obj);
+   if (TYPEOF(attrs) != LISTSXP)
+      return;
+
+   // extract the names from the pairlist
+   std::vector<std::string> names;
+   r::sexp::getNames(attrs, &names);
+
+   // loop over the attributes and fill in the variable vector
+   SEXP attr = R_NilValue; 
+   SEXP nextAttr = R_NilValue;
+   size_t i = 0;
+   for (nextAttr = attrs; nextAttr != R_NilValue; attr = CAR(nextAttr), nextAttr = CDR(nextAttr)) 
+   {
+      pProtect->add(attr);
+      pVariables->push_back(std::make_pair(names.at(i), attr));
+
+      // sanity: break if we run out of names
+      if (++i >= names.size()) 
+         break;
+   }
+}
+
 namespace {
 
 Error asPrimitiveEnvironment(SEXP envirSEXP,

src/cpp/r/include/r/RSexp.hpp

@@ -110,6 +110,7 @@ bool fillSetString(SEXP object, std::set<std::string>* pSet);
 SEXP getAttrib(SEXP object, SEXP attrib);
 SEXP getAttrib(SEXP object, const std::string& attrib);
 SEXP setAttrib(SEXP object, const std::string& attrib, SEXP val);
+void listNamedAttributes(SEXP obj, Protect *pProtect, std::vector<Variable>* pVariables);
 
 // weak/external pointers and finalizers
 bool isExternalPointer(SEXP object);

src/cpp/session/SessionConsoleInput.cpp

@@ -24,6 +24,7 @@
 #include "modules/SessionConsole.hpp"
 
 #include "modules/connections/SessionConnections.hpp"
+#include "modules/environment/SessionEnvironment.hpp"
 #include "modules/overlay/SessionOverlay.hpp"
 
 #include <session/SessionModuleContext.hpp>
@@ -89,6 +90,7 @@ bool canSuspend(const std::string& prompt)
    return !main_process::haveActiveChildren() && 
           modules::connections::isSuspendable() &&
           modules::overlay::isSuspendable() &&
+          modules::environment::isSuspendable() &&
           rstudio::r::session::isSuspendable(prompt);
 }
 

src/cpp/session/modules/SessionEnvironment.R

@@ -432,7 +432,7 @@
    obj <- get(objName, env)
    # objects containing null external pointers can crash when
    # evaluated--display generically (see case 4092)
-   hasNullPtr <- .rs.hasNullExternalPointer(obj)
+   hasNullPtr <- .Call("rs_hasExternalPointer", obj, TRUE, PACKAGE = "(embedding)")
    if (hasNullPtr) 
    {
       val <- "<Object with null pointer>"
@@ -643,32 +643,4 @@
    .rs.valueContents(get(objName, env));
 })
 
-# attempt to determine whether the given object contains a null external
-# pointer
-.rs.addFunction("hasNullExternalPointer", function(obj)
-{
-   if (isS4(obj)) 
-   {
-      # this is an S4 object; recursively check its slots for null pointers
-      any(sapply(slotNames(obj), function(name) {
-         hasNullPtr <- FALSE
-         # it's possible to cheat the S4 object system and destroy the contents
-         # of a slot via attr<- assignments; in this case slotNames will
-         # contain slots that don't exist, and trying to access those slots 
-         # throws an error.
-         tryCatch({
-           hasNullPtr <- .rs.hasNullExternalPointer(slot(obj, name))
-           }, 
-           error = function(err) {})
-         hasNullPtr
-      }))
-   } 
-   else
-   {
-      # check if object itself is a null external pointer
-      .rs.isNullExternalPointer(obj)
-   }
-})
-
-
 

src/cpp/session/modules/environment/SessionEnvironment.cpp

@@ -112,6 +112,66 @@ bool handleRBrowseEnv(const core::FilePath& filePath)
    }
 }
 
+bool hasExternalPtr(SEXP obj,      // environment to search for external pointers
+                    bool nullPtr,  // whether to look for NULL pointers 
+                    int level = 5) // maximum recursion depth (envs can have self-ref loops)
+{
+   // list the contents of this environment
+   std::vector<r::sexp::Variable> vars;
+   r::sexp::Protect rProtect;
+   if (r::sexp::isPrimitiveEnvironment(obj))
+   {
+      // for simple environments, list the objects in the environment
+      r::sexp::listEnvironment(obj, 
+                               true,  // include all values
+                               false, // don't include last dot
+                               &rProtect, &vars);
+   }
+   else if (TYPEOF(obj) == S4SXP)
+   {
+      // for S4 objects, list the attributes (which correspond to slots)
+      r::sexp::listNamedAttributes(obj, &rProtect, &vars);
+   }
+
+   // check for external pointers
+   for (std::vector<r::sexp::Variable>::iterator it = vars.begin(); it != vars.end(); it++)
+   {
+      if (r::sexp::isExternalPointer(it->second) && 
+          r::sexp::isNullExternalPointer(it->second) == nullPtr)
+      {
+         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 (level > 0 && hasExternalPtr(it->second, nullPtr, level - 1))
+            return true;
+      }
+   }
+
+   return false;
+}
+
+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);
+}
+
 // 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 ouput from R.
@@ -944,6 +1004,12 @@ SEXP rs_isBrowserActive()
    return r::sexp::create(s_browserActive, &protect);
 }
 
+bool isSuspendable()
+{
+   // suppress suspension if any object has a live external pointer; these can't be restored
+   return !hasExternalPtr(R_GlobalEnv, false);
+}
+
 Error initialize()
 {
    // store on the heap so that the destructor is never called (so we
@@ -975,6 +1041,8 @@ Error initialize()
    methodDef.numArgs = 3;
    r::routines::addCallMethod(methodDef);
 
+   RS_REGISTER_CALL_METHOD(rs_hasExternalPointer, 2);
+
    // subscribe to events
    using boost::bind;
    using namespace session::module_context;

src/cpp/session/modules/environment/SessionEnvironment.hpp

@@ -33,6 +33,8 @@ core::json::Value environmentStateAsJson();
 
 bool monitoring();
 
+bool isSuspendable();
+
 core::Error initialize();
 
 } // namespace environment