add infrastrucutre for optional compiled extensions

NAMESPACE

@@ -47,6 +47,7 @@ export(upgrade)
 export(use)
 export(use_python)
 importFrom(tools,file_ext)
+importFrom(tools,md5sum)
 importFrom(tools,pskill)
 importFrom(tools,psnice)
 importFrom(tools,write_PACKAGES)

R/aaa.R

@@ -1,6 +1,7 @@
 
 # global variables
 the <- new.env(parent = emptyenv())
+the$ffi <- new.env(parent = emptyenv())
 the$paths <- new.env(parent = emptyenv())
 
 # detect if we're running on CI

R/dependencies.R

@@ -1082,11 +1082,7 @@ renv_dependencies_discover_r <- function(path  = NULL,
     for (method in methods)
       method(node, envir)
 
-    # update node in parent environment -- this is a hack
-    # that allows our recurse implementation to remain
-    # performant without needing to care about the return
-    # values of these functions in general
-    assign("object", node, envir = parent.frame())
+    # return (potentially transformed) node
     invisible(node)
 
   })
@@ -1889,21 +1885,21 @@ renv_dependencies_eval <- function(expr) {
 
 }
 
-renv_dependencies_recurse <- function(object, callback, ...) {
+renv_dependencies_recurse <- function(object, callback) {
 
   if (is.call(object))
-    callback(object, ...)
+    callback(object)
 
   if (is.recursive(object))
     for (i in seq_along(object))
       if (is.call(object[[i]]))
-        renv_dependencies_recurse_impl(object[[i]], callback, ...)
+        renv_dependencies_recurse_impl(object[[i]], callback)
 
 }
 
-renv_dependencies_recurse_impl <- function(object, callback, ...) {
-  callback(object, ...)
+renv_dependencies_recurse_impl <- function(object, callback) {
+  callback(object)
   for (i in seq_along(object))
     if (is.call(object[[i]]))
-      renv_dependencies_recurse_impl(object[[i]], callback, ...)
+      renv_dependencies_recurse_impl(object[[i]], callback)
 }

R/ext.R

@@ -0,0 +1,106 @@
+
+renv_ext_init <- function() {
+  tryCatch(
+    renv_ext_init_impl(),
+    error = function(cnd) print(cnd)
+  )
+}
+
+renv_ext_init_impl <- function() {
+
+  if (renv_metadata_embedded())
+    return()
+
+  name <- Sys.getenv("R_PACKAGE_NAME", unset = NA)
+  if (!is.na(name))
+    return()
+
+  shlib <- renv_ext_compile()
+  if (file.exists(shlib))
+    renv_ext_load(shlib)
+
+}
+
+renv_ext_compile <- function(force = FALSE) {
+
+  # get paths
+  pkgdir   <- renv_paths_ext("renv")
+  libsdir  <- file.path(pkgdir, "libs")
+  libname  <- if (renv_platform_windows()) "renv.dll" else "renv.so"
+  sopath   <- file.path(libsdir, libname)
+  srcfile  <- system.file("ext/renv.c", package = "renv")
+  tgtfile  <- file.path(libsdir, "renv.c")
+  hashpath <- file.path(libsdir, "md5sum")
+
+  # initialize extension directory
+  ensure_directory(libsdir)
+  renv_scope_wd(libsdir)
+
+  recompile <- force ||
+    !file.exists(sopath) ||
+    !file.exists(hashpath) ||
+    readLines(hashpath) != md5sum(srcfile)
+
+  if (!recompile)
+    return(sopath)
+
+  # copy our DESCRIPTION file over, so we can convince R to load
+  # this DLL as though it were part of our package
+  renv_file_copy(
+    source    = system.file("DESCRIPTION", package = "renv"),
+    target    = file.path(pkgdir, "DESCRIPTION"),
+    overwrite = TRUE
+  )
+
+  # copy the '.c' file over for compilation
+  renv_file_copy(
+    source    = srcfile,
+    target    = tgtfile,
+    overwrite = TRUE
+  )
+
+  # compile it
+  renv_system_exec(
+    command = R(),
+    args    = c("CMD", "SHLIB", "renv.c", "-o", libname)
+  )
+
+  # update the md5sum
+  writeLines(
+    md5sum(srcfile),
+    con = hashpath
+  )
+
+  # return path to 
+  sopath
+
+}
+
+renv_ext_load <- function(shlib) {
+
+  # load the shared library
+  the$dll_info <- library.dynam(
+    chname  = "renv",
+    package = "renv",
+    lib.loc = renv_paths_ext()
+  )
+
+  # install the ffi equivalents
+  envir <- renv_envir_self()
+  enumerate(the$ffi, function(symbol, replacement) {
+    renv_binding_replace(
+      envir       = envir,
+      symbol      = symbol,
+      replacement = replacement
+    )
+  })
+
+}
+
+renv_ext_unload <- function() {
+  if (!is.null(the$dll_info)) {
+    path <- the$dll_info[["path"]]
+    the$dll_info <- NULL
+    library.dynam.unload("renv", libpath = dirname(dirname(path)))
+  }
+}

R/ffi.R

@@ -0,0 +1,27 @@
+
+the$ffi$renv_dependencies_recurse <- function(object, callback) {
+
+  symbol <- as.symbol(names(formals(args(callback)))[[1L]])
+  envir <- new.env(parent = environment(callback))
+  expr <- body(callback)
+
+  .Call(
+    "renv_ffi_recurse",
+    object,
+    symbol,
+    expr,
+    envir,
+    PACKAGE = .packageName
+  )
+
+}
+
+the$ffi$renv_call_expect <- function(node, package, methods) {
+  .Call(
+    "renv_ffi_call_expect",
+    node,
+    as.character(package),
+    as.character(methods),
+    PACKAGE = .packageName
+  )
+}

R/hash.R

@@ -62,7 +62,7 @@ renv_hash_description_impl <- function(path) {
   close(con)
 
   # ready for hasing
-  hash <- unname(tools::md5sum(tempfile))
+  hash <- unname(md5sum(tempfile))
 
   # remove the old file
   unlink(tempfile)

R/imports.R

@@ -1,6 +1,6 @@
 
 #' @importFrom tools
-#'   file_ext pskill psnice write_PACKAGES
+#'   file_ext md5sum pskill psnice write_PACKAGES
 #'
 #' @importFrom utils
 #'   adist available.packages browseURL citation contrib.url download.file

R/paths.R

@@ -126,6 +126,13 @@ renv_paths_cache <- function(..., version = NULL) {
   renv_paths_common("cache", c(version, platform), ...)
 }
 
+renv_paths_ext <- function(...) {
+  platform <- renv_platform_prefix()
+  version <- renv_metadata_version()
+  renv_paths_common("ext", c(version, platform), ...)
+}
+
+
 renv_paths_rtools <- function() {
 
   root <- renv_paths_override("rtools")

R/remotes.R

@@ -914,7 +914,7 @@ renv_remotes_resolve_url <- function(url, quiet = FALSE) {
 
   tempfile <- renv_scope_tempfile("renv-url-")
   writeLines(url, con = tempfile)
-  hash <- tools::md5sum(tempfile)
+  hash <- md5sum(tempfile)
 
   ext <- fileext(url, default = ".tar.gz")
   name <- paste(hash, ext, sep = "")

R/renv-package.R

@@ -7,5 +7,5 @@
 #' Each project using renv will share package installations from a global
 #' cache of packages, helping to avoid wasting disk space on multiple
 #' installations of a package that might otherwise be shared across projects.
-#'
+#' 
 "_PACKAGE"

R/zzz.R

@@ -11,6 +11,12 @@
     # set root directory
     root <- Sys.getenv("RENV_PATHS_ROOT", unset = tempfile("renv-root-"))
     Sys.setenv(RENV_PATHS_ROOT = root)
+
+    # unset on exit
+    reg.finalizer(renv_envir_self(), function(envir) {
+      if (identical(root, Sys.getenv("RENV_PATHS_ROOT", unset = NA)))
+        Sys.unsetenv("RENV_PATHS_ROOT")
+    }, onexit = TRUE)
 
     # set up sandbox -- only done on non-Windows due to strange intermittent
     # test failures that seemed to occur there?
@@ -26,6 +32,7 @@
 
   renv_defer_init()
   renv_metadata_init()
+  renv_ext_init()
   renv_ansify_init()
   renv_platform_init()
   renv_virtualization_init()
@@ -72,6 +79,7 @@
   renv_lock_unload()
   renv_task_unload()
   renv_watchdog_unload()
+  renv_ext_unload()
 
   # do some extra cleanup when running R CMD check
   if (renv_platform_unix() && checking() && !ci())

inst/ext/renv.c

@@ -0,0 +1,124 @@
+
+#include <stdlib.h> // for NULL
+
+#include <R.h>
+#include <Rinternals.h>
+#include <R_ext/Rdynload.h>
+
+// Helpers ----
+
+// check for a call of the form 'package::foo(a, b, c)';
+// if we match, then create a new call of the form 'foo(a, b, c)'
+static SEXP renv_call_expect_package(SEXP node, SEXP package) {
+
+  if (TYPEOF(node) != LANGSXP)
+    return node;
+
+  SEXP call = CAR(node);
+  if (TYPEOF(call) != LANGSXP)
+    return node;
+
+  SEXP symbol = CAR(call);
+  if (TYPEOF(symbol) != SYMSXP)
+    return node;
+
+  const char* value = CHAR(PRINTNAME(symbol));
+  if (strcmp(value, "::") != 0 && strcmp(value, ":::") != 0)
+    return node;
+
+  SEXP name = CADR(call);
+  if (TYPEOF(name) != SYMSXP)
+    return node;
+
+  int matches = strcmp(CHAR(PRINTNAME(name)), CHAR(STRING_ELT(package, 0))) == 0;
+  if (!matches)
+    return node;
+
+  node = Rf_duplicate(node);
+  SETCAR(node, CADDR(call));
+  return node;
+
+}
+
+
+// Methods ----
+
+SEXP renv_ffi_recurse(SEXP object,
+                      SEXP symbol,
+                      SEXP expr,
+                      SEXP envir)
+{
+  switch (TYPEOF(object)) {
+
+  case LISTSXP:
+  case LANGSXP:
+
+    Rf_defineVar(symbol, object, envir);
+    SEXP result = Rf_eval(expr, envir);
+    if (TYPEOF(result) == LANGSXP) {
+      object = result;
+    }
+
+    PROTECT(object);
+    while (object != R_NilValue) {
+      renv_ffi_recurse(CAR(object), symbol, expr, envir);
+      object = CDR(object);
+    }
+    UNPROTECT(1);
+
+    break;
+
+  case VECSXP:
+  case EXPRSXP:
+
+    for (int i = 0, n = Rf_xlength(object); i < n; i++) {
+      renv_ffi_recurse(VECTOR_ELT(object, i), symbol, expr, envir);
+    }
+
+    break;
+
+  }
+
+  return object;
+
+}
+
+SEXP renv_ffi_call_expect(SEXP node, SEXP package, SEXP methods) {
+
+  node = renv_call_expect_package(node, package);
+  PROTECT(node);
+
+  SEXP symbol = CAR(node);
+  if (TYPEOF(symbol) != SYMSXP) {
+    UNPROTECT(1);
+    return R_NilValue;
+  }
+
+  const char* symname = CHAR(PRINTNAME(symbol));
+  for (int i = 0, n = Rf_xlength(methods); i < n; i++) {
+    const char* method = CHAR(STRING_ELT(methods, i));
+    if (strcmp(method, symname) == 0) {
+      UNPROTECT(1);
+      return node;
+    }
+  }
+
+  UNPROTECT(1);
+  return R_NilValue;
+
+}
+
+
+// Init ----
+
+static const R_CallMethodDef callEntries[] = {
+  { "renv_ffi_recurse",     (DL_FUNC) &renv_ffi_recurse, 4 },
+  { "renv_ffi_call_expect", (DL_FUNC) &renv_ffi_call_expect, 3},
+  { NULL, NULL, 0 }
+};
+
+void R_init_renv(DllInfo* dllInfo)
+{
+  R_registerRoutines(dllInfo, NULL, callEntries, NULL, NULL);
+  R_useDynamicSymbols(dllInfo, FALSE);
+}