Make it possible to debug evalFuture(), by capturing the debug conditions to the FutureResult object

Author: HenrikBengtsson

R/Future-class.R

@@ -657,13 +657,30 @@ getExpression <- function(future, ...) UseMethod("getExpression")
 
 #' @export
 getExpression.Future <- local({
-  tmpl_expr_evaluate2 <- bquote_compile({
+  tmpl_expr_evaluate <- bquote_compile({
     "# future:::getExpression.Future(): evaluate the future via evalFuture()"
     future:::evalFuture(core = .(core), capture = .(capture), context = .(context), split = .(split), immediateConditionClasses = .(immediateConditionClasses), forwardOptions = .(forwardOptions), local = .(local), cleanup = .(cleanup))
   })
 
+  tmpl_expr_evaluate_with_debug <- bquote_compile({
+    local({
+      conditions <- list()
+      ...future.result <- withCallingHandlers({
+        "# future:::getExpression.Future(): evaluate the future via evalFuture()"
+        future:::evalFuture(core = .(core), capture = .(capture), context = .(context), split = .(split), immediateConditionClasses = .(immediateConditionClasses), forwardOptions = .(forwardOptions), local = .(local), cleanup = .(cleanup))
+      }, condition = function(cond) {
+        conditions <<- c(conditions, list(cond))
+      })
+      ...future.result$evalFuture <- list(
+        conditions = conditions
+      )
+      ...future.result
+    })
+  })
+
   function(future, expr = future$expr, immediateConditions = FALSE, threads = NA_integer_, ..., cleanup = TRUE) {
     debug <- getOption("future.debug", FALSE)
+    
     ##  mdebug("getExpression() ...")
     args <- list(...)
 
@@ -783,9 +800,12 @@ getExpression.Future <- local({
       forwardOptions$mc.cores <- mc.cores
     }
 
-    expr <- bquote_apply(tmpl_expr_evaluate2)
-    
-    if (getOption("future.debug", FALSE)) mprint(expr)
+    if (debug) {
+      expr <- bquote_apply(tmpl_expr_evaluate_with_debug)
+      mprint(expr)
+    } else {
+      expr <- bquote_apply(tmpl_expr_evaluate)
+    }
 
     ##  mdebug("getExpression() ... DONE")
 

R/expressions.R

@@ -24,7 +24,23 @@ evalFuture <- function(
     forwardOptions = NULL,
     local = FALSE,
     envir = parent.frame(),
-    cleanup = TRUE) {
+    cleanup = TRUE,
+    debug = FALSE) {
+
+  debug <- getOption("future.debug", TRUE)
+  if (debug) {
+    mdebugf("future:::evalFuture() ...")
+
+    mdebugf("Core:")
+    mstr(core)
+
+    mdebugf("Capture:")
+    mstr(capture)
+
+    mdebugf("Context:")
+    mstr(context)
+  }
+
   expr <- core$expr
   globals <- core$globals
   packages <- core$packages
@@ -420,6 +436,12 @@ evalFuture <- function(
 
   ## Use the next-level-down ("popped") future strategy
   future::plan(strategiesR, .cleanup = FALSE, .init = FALSE)
+  if (debug) {
+    mdebugf("Setting future::plan() ...")
+    mstr(strategiesR)
+    mprint(future::plan("list"))
+    mdebugf("Setting future::plan() ... DONE")
+  }
 
   if (!is.na(...future.ncores)) {
     ## (b) Identify default number of cores - acknowledging plan settings
@@ -439,6 +461,9 @@ evalFuture <- function(
   if (is.numeric(seed)) {
     genv <- globalenv()
     genv$.Random.seed <- seed
+    if (debug) {
+      mdebugf("Setting .Random.seed")
+    }
   }
 
   globalenv <- (getOption("future.globalenv.onMisuse", "ignore") != "ignore")
@@ -450,6 +475,8 @@ evalFuture <- function(
   ## Attach globals to the global environment
   ## Undo changes on exit
   if (length(globals) > 0) {
+    if (debug) mdebugf("Attaching globals ...")
+    
     ## Preserve globals in all environments until the global environment
     names <- names(globals)
     envs <- list()
@@ -480,6 +507,7 @@ evalFuture <- function(
     }
 
     on.exit({
+      if (debug) mdebugf("Restoring objects overwritten by globals ...")
       ## Remove globals from the global environment
       rm(list = names(globals), envir = genv, inherits = FALSE)
       ## Restore objects in all modified environments
@@ -491,9 +519,13 @@ evalFuture <- function(
           assign(name, value = value, envir = env, inherits = FALSE)
         }
       } ## for (ee ...)
+      if (debug) mdebugf("Restoring objects overwritten by globals ... DONE")
     }, add = TRUE)
 
+    if (debug) mdebugf("- globals: [n=%d] %s", length(globals), commaq(names(globals)))
     assign_globals(globalenv(), globals = globals)
+    
+    if (debug) mdebugf("Attaching globals ... DONE")
   }
 
   conditionClassesExclude <- attr(conditionClasses, "exclude", exact = TRUE)
@@ -503,6 +535,10 @@ evalFuture <- function(
   ...future.frame <- sys.nframe()
   ...future.conditions <- list()
 
+  if (debug) {
+    mdebugf("Evaluating future ...")
+  }
+  
   ## NOTE: We don't want to use local(body) w/ on.exit() because
   ## evaluation in a local is optional, cf. argument 'local'.
   ## If this was mandatory, we could.  Instead we use
@@ -579,19 +615,28 @@ evalFuture <- function(
       } ## function(cond)
     })) ## local() + withCallingHandlers()
   }, error = function(ex) {
+    if (debug) {
+      mdebugf(" - Caught run-time error")
+    }
     FutureResult(
       conditions = ...future.conditions,
       rng = !identical(globalenv()$.Random.seed, ...future.rng),
       globalenv = if (globalenv) list(added = setdiff(names(.GlobalEnv), ...future.globalenv.names)) else NULL,
       started = ...future.startTime
     )
   }) ## tryCatch()
-  
+
+  if (debug) {
+    mdebugf("Evaluating future ... DONE")
+  }
 
   ## -----------------------------------------------------------------
   ## Get captured standard output?
   ## -----------------------------------------------------------------
   if (!is.na(stdout)) {
+    if (debug) {
+      mdebugf("Gathering captured standard output")
+    }
     sink(type = "output", split = split)
     if (stdout) {
       ...future.result$stdout <- rawToChar(
@@ -604,5 +649,12 @@ evalFuture <- function(
     ...future.stdout <- NULL
   }
 
+  if (debug) {
+    mdebugf("Results:")
+    mprint(...future.result)
+    mdebugf("Evaluating future ... DONE")
+    on.exit(mdebugf("future:::evalFuture() ... DONE"))
+  }
+  
   ...future.result
 } ## evalFuture()