More performance improvements:

Add internal getSysCalls() - create sysCalls() once per R session.
Add with_assert() and option to prune it

Author: HenrikBengtsson

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: future
-Version: 1.34.0-9135
+Version: 1.34.0-9136
 Title: Unified Parallel and Distributed Processing in R for Everyone
 Imports:
     digest,

R/backend_api-evalFuture.R

@@ -32,6 +32,43 @@ attachPackages <- function(packages) {
 } ## attachPackages()
 
 
+tmpl_expr_local <- bquote_compile(base::local({
+  .(expr)
+}))
+
+
+getSysCalls <- local({
+  sysCalls_local <- NULL
+  sysCalls_no_local <- NULL
+  
+  function(local = TRUE) {
+    if (local) {
+      if (is.null(sysCalls_local)) {
+        ## WORKAROUND: This makes assumption about withCallingHandlers()
+        ## and local(). In case this changes, provide internal options to
+        ## adjust this. /HB 2018-12-28
+        skip <- getOption("future.makeExpression.skip.local", c(12L, 3L))
+        sysCalls_local <<- function(calls = sys.calls(), from = 1L) {
+          calls[seq.int(from = from + skip[1L], to = length(calls) - skip[2L])]
+        }
+      }
+      sysCalls_local
+    } else {
+      if (is.null(sysCalls_no_local)) {
+        ## WORKAROUND: This makes assumption about withCallingHandlers()
+        ## In case this changes, provide internal options to adjust this.
+        ## /HB 2018-12-28
+        skip <<- getOption("future.makeExpression.skip", c(6L, 3L))
+        sysCalls_no_local <<- function(calls = sys.calls(), from = 1L) {
+          calls[seq.int(from = from + skip[1L], to = length(calls) - skip[2L])]
+        }
+      }
+      sysCalls_no_local
+    }
+  }
+})
+
+
 evalFuture <- function(
     data = list(
       core = list(
@@ -74,39 +111,40 @@ evalFuture <- function(
   immediateConditionClasses <- capture$immediateConditionClasses
   immediateConditionHandlers <- capture$immediateConditionHandlers
 
-  if (!is.null(immediateConditionHandlers)) {
-    stop_if_not(is.list(immediateConditionHandlers))
-    if (length(immediateConditionHandlers) > 0) {
-      stop_if_not(    
-        !is.null(names(immediateConditionHandlers)),
-        all(vapply(immediateConditionHandlers, FUN = is.function, FUN.VALUE = FALSE))
-      )
-    }
-  }
-
   backendPackages <- context$backendPackages
   strategiesR <- context$strategiesR
   threads <- context$threads
   forwardOptions <- context$forwardOptions
   if (is.null(threads)) threads <- NA_integer_
-  if (length(forwardOptions) > 0) {
-    stop_if_not(!is.null(names(forwardOptions)))
-  }
   ## This will eventually always be TRUE
   local <- context$local
   if (is.null(local)) local <- TRUE
 
-  stop_if_not(
-    length(local) == 1L && is.logical(local) && !is.na(local),
-    length(stdout) == 1L && is.logical(stdout),
-    length(split) == 1L && is.logical(split) && !is.na(split),
-    is.null(conditionClasses) || (is.character(conditionClasses) && !anyNA(conditionClasses) && all(nzchar(conditionClasses))),
-    is.character(immediateConditionClasses) && !anyNA(immediateConditionClasses) && all(nzchar(immediateConditionClasses)),
-    is.null(seed) || is_lecyer_cmrg_seed(seed) || (is.logical(seed) && !is.na(seed) || !seed),
-    is.character(backendPackages) && !anyNA(backendPackages) && all(nzchar(backendPackages)),
-    length(threads) == 1L && is.integer(threads) && (is.na(threads) || threads >= 1L),
-    length(cleanup) == 1L && is.logical(cleanup) && !is.na(cleanup)
-  )
+  with_assert({
+    if (!is.null(immediateConditionHandlers)) {
+      stop_if_not(is.list(immediateConditionHandlers))
+      if (length(immediateConditionHandlers) > 0) {
+        stop_if_not(    
+          !is.null(names(immediateConditionHandlers)),
+          all(vapply(immediateConditionHandlers, FUN = is.function, FUN.VALUE = FALSE))
+        )
+      }
+    }
+
+    stop_if_not(
+      length(forwardOptions) == 0L || !is.null(names(forwardOptions)),
+      length(local) == 1L && is.logical(local) && !is.na(local),
+      length(stdout) == 1L && is.logical(stdout),
+      length(split) == 1L && is.logical(split) && !is.na(split),
+      is.null(conditionClasses) || (is.character(conditionClasses) && !anyNA(conditionClasses) && all(nzchar(conditionClasses))),
+      is.character(immediateConditionClasses) && !anyNA(immediateConditionClasses) && all(nzchar(immediateConditionClasses)),
+      is.null(seed) || is_lecyer_cmrg_seed(seed) || (is.logical(seed) && !is.na(seed) || !seed),
+      is.character(backendPackages) && !anyNA(backendPackages) && all(nzchar(backendPackages)),
+      length(threads) == 1L && is.integer(threads) && (is.na(threads) || threads >= 1L),
+      length(cleanup) == 1L && is.logical(cleanup) && !is.na(cleanup)
+    )
+  })
+
 
   ## Is it possible to force single-threaded processing?
   if (!is.na(threads)) {
@@ -127,22 +165,23 @@ evalFuture <- function(
     }
   }
 
-
-  if (is.function(strategiesR)) {
-    if (!inherits(strategiesR, "future")) {
-      stop(FutureEvalError(sprintf("Argument 'strategiesR' is a function, but does not inherit 'future': %s", commaq(class(strategiesR)))))
-    }
-  } else if (is.list(strategiesR)) {
-    for (kk in seq_along(strategiesR)) {
-      strategy <- strategiesR[[kk]]
-      if (!inherits(strategy, "future")) {
-        stop(FutureEvalError(sprintf("Element #%d of list 'strategiesR' is a function, but does not inherit 'future': %s", kk, commaq(class(strategy)))))
+  with_assert({
+    if (is.function(strategiesR)) {
+      if (!inherits(strategiesR, "future")) {
+        stop(FutureEvalError(sprintf("Argument 'strategiesR' is a function, but does not inherit 'future': %s", commaq(class(strategiesR)))))
       }
+    } else if (is.list(strategiesR)) {
+      for (kk in seq_along(strategiesR)) {
+        strategy <- strategiesR[[kk]]
+        if (!inherits(strategy, "future")) {
+          stop(FutureEvalError(sprintf("Element #%d of list 'strategiesR' is a function, but does not inherit 'future': %s", kk, commaq(class(strategy)))))
+        }
+      }
+    } else if (is.character(strategiesR)) {
+    } else {
+      stop(FutureEvalError(sprintf("Unknown value of argument 'strategiesR': %s", commaq(class(strategiesR)))))
     }
-  } else if (is.character(strategiesR)) {
-  } else {
-    stop(FutureEvalError(sprintf("Unknown value of argument 'strategiesR': %s", commaq(class(strategiesR)))))
-  }
+  })
 
 
 
@@ -363,14 +402,6 @@ evalFuture <- function(
   ## -----------------------------------------------------------------
   ## Evaluate expression in a local() environment?
   if (local) {
-    tmpl_expr_local <- bquote_compile(base::local({
-      "# future:::evalFuture(): set convenient name of local environment"
-      env <- environment()
-      attr(env, "name") <- "future:evalenv"
-      rm(list = "env", inherits = FALSE)
-      
-      .(expr)
-    }))
     expr <- bquote_apply(tmpl_expr_local)
     ## WORKAROUND: This makes assumption about withCallingHandlers()
     ## and local(). In case this changes, provide internal options to
@@ -567,12 +598,7 @@ evalFuture <- function(
         globalenv = if (globalenv) list(added = setdiff(names(.GlobalEnv), ...future.globalenv.names)) else NULL,
         started = ...future.startTime
       )
-    }, condition = base::local({
-      sysCalls <- function(calls = sys.calls(), from = 1L) {
-        calls[seq.int(from = from + skip[1L], to = length(calls) - skip[2L])]
-      }
-      
-      function(cond) {
+    }, condition = function(cond) {
         ## Handle immediately?
         if (length(immediateConditionHandlers) > 0) {
           ## Handle immediateCondition:s?
@@ -615,7 +641,9 @@ evalFuture <- function(
               system     = Sys.info()
             )
           }
-          
+
+          sysCalls <- getSysCalls()
+
           ## Record condition
           ...future.conditions[[length(...future.conditions) + 1L]] <<- list(
             condition = cond,
@@ -649,7 +677,7 @@ evalFuture <- function(
           }
         }
       } ## function(cond)
-    })) ## local() + withCallingHandlers()
+    ) ## withCallingHandlers()
   }, error = function(ex) {
     FutureResult(
       conditions = ...future.conditions,

R/utils-prune_pkg_code.R

@@ -1,3 +1,7 @@
+with_assert <- function(expr, ...) {
+  invisible(expr)
+}
+
 prune_call <- function(expr, name) {
   if (!is.call(expr)) 
     return(expr)
@@ -10,8 +14,10 @@ prune_call <- function(expr, name) {
   NULL
 }
 
-prune_stop_if_not <- function(expr) {
-  prune_call(expr, name = "stop_if_not")
+prune_fcns <- function(expr) {
+  expr <- prune_call(expr, name = "stop_if_not")
+  expr <- prune_call(expr, name = "with_assert")
+  expr
 }
 
 #' @importFrom globals walkAST
@@ -21,7 +27,7 @@ prune_pkg_code <- function(env = topenv(parent.frame())) {
     if (exists(name, mode = "function", envir = env, inherits = FALSE)) {
       fcn <- get(name, mode = "function", envir = env, inherits = FALSE)
       body0 <- body(fcn)
-      body <- walkAST(body0, call = prune_stop_if_not)
+      body <- walkAST(body0, call = prune_fcns)
       if (!identical(body, body0)) {
         body(fcn) <- body
         assign(name, fcn, envir = env, inherits = FALSE)

R/utils_api-plan.R

@@ -284,12 +284,17 @@ plan <- local({
     if (init) plan_init()
 
     ## Sanity checks
-    nbrOfWorkers <- nbrOfWorkers()
-    if (isTRUE(getOption("future.debug"))) {
-      mdebugf(sprintf("plan(): nbrOfWorkers() = %.0f", nbrOfWorkers))
-    }
-    stop_if_not(is.numeric(nbrOfWorkers), length(nbrOfWorkers) == 1L, 
-                !is.na(nbrOfWorkers), nbrOfWorkers >= 1L)
+    stop_if_not(
+      nbrOfWorkers <- local({
+        nbrOfWorkers <- nbrOfWorkers()
+        if (isTRUE(getOption("future.debug"))) {
+          mdebugf(sprintf("plan(): nbrOfWorkers() = %.0f", nbrOfWorkers))
+        }
+        nbrOfWorkers
+      }),
+      is.numeric(nbrOfWorkers), length(nbrOfWorkers) == 1L, 
+      !is.na(nbrOfWorkers), nbrOfWorkers >= 1L
+    )
 
     invisible(oldStack)
   } ## plan_set()