Merge pull request #119 from r-lib/autorun

Author: wch

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: later
 Type: Package
 Title: Utilities for Scheduling Functions to Execute Later with Event Loops
-Version: 1.0.0.9002
+Version: 1.0.0.9004
 Authors@R: c(
     person("Joe", "Cheng", role = c("aut", "cre"), email = "[email protected]"),
     person(family = "RStudio", role = "cph"),
@@ -20,7 +20,7 @@ Imports:
     rlang
 LinkingTo: Rcpp, BH
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.0.2
+RoxygenNote: 7.1.0
 Suggests:
     knitr,
     rmarkdown,

NEWS.md

@@ -1,4 +1,6 @@
-## later 1.0.0.9002
+## later 1.0.0.9004
+
+* Private event loops are now automatically run by their parent. That is, whenever an event loop is run, its children event loops are automatically run. The `create_loop()` function has a new parameter `parent`, which defaults to the current loop. The auto-running behavior can be disabled by using `create_loop(parent=NULL)`. ([#119](https://github.com/r-lib/later/pull/119))
 
 * Fixed [#73](https://github.com/r-lib/later/issues/73), [#109](https://github.com/r-lib/later/issues/109): Previously, later did not build on some platforms, notably ARM, because the `-latomic` linker was needed on those platforms. A configure script now detects when `-latomic` is needed. ([#114](https://github.com/r-lib/later/pull/114))
 

R/RcppExports.R

@@ -9,43 +9,55 @@ log_level <- function(level) {
     .Call('_later_log_level', PACKAGE = 'later', level)
 }
 
-ensureInitialized <- function() {
-    invisible(.Call('_later_ensureInitialized', PACKAGE = 'later'))
+setCurrentRegistryId <- function(id) {
+    invisible(.Call('_later_setCurrentRegistryId', PACKAGE = 'later', id))
+}
+
+getCurrentRegistryId <- function() {
+    .Call('_later_getCurrentRegistryId', PACKAGE = 'later')
+}
+
+deleteCallbackRegistry <- function(loop_id) {
+    .Call('_later_deleteCallbackRegistry', PACKAGE = 'later', loop_id)
+}
+
+notifyRRefDeleted <- function(loop_id) {
+    .Call('_later_notifyRRefDeleted', PACKAGE = 'later', loop_id)
 }
 
-existsCallbackRegistry <- function(loop) {
-    .Call('_later_existsCallbackRegistry', PACKAGE = 'later', loop)
+createCallbackRegistry <- function(id, parent_id) {
+    invisible(.Call('_later_createCallbackRegistry', PACKAGE = 'later', id, parent_id))
 }
 
-createCallbackRegistry <- function(loop) {
-    .Call('_later_createCallbackRegistry', PACKAGE = 'later', loop)
+existsCallbackRegistry <- function(id) {
+    .Call('_later_existsCallbackRegistry', PACKAGE = 'later', id)
 }
 
-deleteCallbackRegistry <- function(loop) {
-    .Call('_later_deleteCallbackRegistry', PACKAGE = 'later', loop)
+list_queue_ <- function(id) {
+    .Call('_later_list_queue_', PACKAGE = 'later', id)
 }
 
-list_queue_ <- function(loop) {
-    .Call('_later_list_queue_', PACKAGE = 'later', loop)
+execCallbacks <- function(timeoutSecs, runAll, loop_id) {
+    .Call('_later_execCallbacks', PACKAGE = 'later', timeoutSecs, runAll, loop_id)
 }
 
-execCallbacks <- function(timeoutSecs, runAll, loop) {
-    .Call('_later_execCallbacks', PACKAGE = 'later', timeoutSecs, runAll, loop)
+idle <- function(loop_id) {
+    .Call('_later_idle', PACKAGE = 'later', loop_id)
 }
 
-idle <- function(loop) {
-    .Call('_later_idle', PACKAGE = 'later', loop)
+ensureInitialized <- function() {
+    invisible(.Call('_later_ensureInitialized', PACKAGE = 'later'))
 }
 
-execLater <- function(callback, delaySecs, loop) {
-    .Call('_later_execLater', PACKAGE = 'later', callback, delaySecs, loop)
+execLater <- function(callback, delaySecs, loop_id) {
+    .Call('_later_execLater', PACKAGE = 'later', callback, delaySecs, loop_id)
 }
 
-cancel <- function(callback_id_s, loop) {
-    .Call('_later_cancel', PACKAGE = 'later', callback_id_s, loop)
+cancel <- function(callback_id_s, loop_id) {
+    .Call('_later_cancel', PACKAGE = 'later', callback_id_s, loop_id)
 }
 
-nextOpSecs <- function(loop) {
-    .Call('_later_nextOpSecs', PACKAGE = 'later', loop)
+nextOpSecs <- function(loop_id) {
+    .Call('_later_nextOpSecs', PACKAGE = 'later', loop_id)
 }
 

R/later.R

@@ -5,11 +5,15 @@
 .onLoad <- function(...) {
   ensureInitialized()
   .globals$next_id <- 0L
-  .globals$global_loop <- create_loop(autorun = FALSE)
-  .globals$current_loop <- .globals$global_loop
+  # Store a ref to the global loop so it doesn't get GC'd.
+  .globals$global_loop <- create_loop(parent = NULL)
 }
 
 .globals <- new.env(parent = emptyenv())
+# A registry of weak refs to loop handle objects. Given an ID number, we can
+# get the corresponding loop handle. We use weak refs because we don't want
+# this registry to keep the loop objects alive.
+.loops <- new.env(parent = emptyenv())
 
 #' Private event loops
 #'
@@ -47,49 +51,88 @@
 #'
 #' @param loop A handle to an event loop.
 #' @param expr An expression to evaluate.
-#' @param autorun Should this event loop automatically be run when its parent
-#'   loop runs? Currently, only FALSE is allowed, but in the future TRUE will
-#'   be implemented and the default. Because in the future the default will
-#'   change, for now any code that calls \code{create_loop} must explicitly
-#'   pass in \code{autorun=FALSE}.
+#' @param autorun This exists only for backward compatibility. If set to
+#'   \code{FALSE}, it is equivalent to using \code{parent=NULL}.
+#' @param parent The parent event loop for the one being created. Whenever the
+#'   parent loop runs, this loop will also automatically run, without having to
+#'   manually call \code{\link{run_now}()} on this loop. If \code{NULL}, then
+#'   this loop will not have a parent event loop that automatically runs it; the
+#'   only way to run this loop will be by calling \code{\link{run_now}()} on this
+#'   loop.
 #' @rdname create_loop
 #'
 #' @export
-create_loop <- function(autorun = NULL) {
-  if (!identical(autorun, FALSE)) {
-    stop("autorun must be set to FALSE (until TRUE is implemented).")
-  }
-
+create_loop <- function(parent = current_loop(), autorun = NULL) {
   id <- .globals$next_id
   .globals$next_id <- id + 1L
-  createCallbackRegistry(id)
+
+  if (!is.null(autorun)) {
+    # This is for backward compatibility, if `create_loop(autorun=FALSE)` is called.
+    parent <- NULL
+  }
+  if (identical(parent, FALSE)) {
+    # This is for backward compatibility, if `create_loop(FALSE)` is called.
+    # (Previously the first and only parameter was `autorun`.)
+    parent <- NULL
+    warning("create_loop(FALSE) is deprecated. Please use create_loop(parent=NULL) from now on.")
+  }
+  if (!is.null(parent) && !inherits(parent, "event_loop")) {
+    stop("`parent` must be NULL or an event_loop object.")
+  }
+
+  if (is.null(parent)) {
+    parent_id <- -1L
+  } else {
+    parent_id <- parent$id
+  }
+  createCallbackRegistry(id, parent_id)
 
   # Create the handle for the loop
   loop <- new.env(parent = emptyenv())
   class(loop) <- "event_loop"
   loop$id <- id
   lockBinding("id", loop)
+
+  # Add a weak reference to the loop object in our registry.
+  .loops[[sprintf("%d", id)]] <- rlang::new_weakref(loop)
+
   if (id != 0L) {
-    # Automatically destroy the loop when the handle is GC'd (unless it's the
-    # global loop.) The global loop handle never gets GC'd under normal
-    # circumstances because .globals$global_loop refers to it. However, if the
-    # package is unloaded it can get GC'd, and we don't want the
-    # destroy_loop() finalizer to give an error message about not being able
-    # to destroy the global loop.
-    reg.finalizer(loop, destroy_loop)
+    # Inform the C++ layer that there are no more R references when the handle
+    # is GC'd (unless it's the global loop.) The global loop handle never gets
+    # GC'd under normal circumstances because .globals$global_loop refers to it.
+    # However, if the package is unloaded it can get GC'd, and we don't want the
+    # destroy_loop() finalizer to give an error message about not being able to
+    # destroy the global loop.
+    reg.finalizer(loop, notify_r_ref_deleted)
   }
 
   loop
 }
 
+notify_r_ref_deleted <- function(loop) {
+  if (identical(loop, global_loop())) {
+    stop("Can't notify that reference to global loop is deleted.")
+  }
+
+  res <- notifyRRefDeleted(loop$id)
+  if (res) {
+    rm(list = sprintf("%d", loop$id), envir = .loops)
+  }
+  invisible(res)
+}
+
 #' @rdname create_loop
 #' @export
 destroy_loop <- function(loop) {
   if (identical(loop, global_loop())) {
     stop("Can't destroy global loop.")
   }
 
-  deleteCallbackRegistry(loop$id)
+  res <- deleteCallbackRegistry(loop$id)
+  if (res) {
+    rm(list = sprintf("%d", loop$id), envir = .loops)
+  }
+  invisible(res)
 }
 
 #' @rdname create_loop
@@ -101,13 +144,24 @@ exists_loop <- function(loop) {
 #' @rdname create_loop
 #' @export
 current_loop <- function() {
-  .globals$current_loop
+  id <- getCurrentRegistryId()
+  loop_weakref <- .loops[[sprintf("%d", id)]]
+  if (is.null(loop_weakref)) {
+    stop("Current loop with id ", id, " not found.")
+  }
+
+  loop <- rlang::wref_key(loop_weakref)
+  if (is.null(loop)) {
+    stop("Current loop with id ", id, " not found.")
+  }
+
+  loop
 }
 
 #' @rdname create_loop
 #' @export
 with_temp_loop <- function(expr) {
-  loop <- create_loop(autorun = FALSE)
+  loop <- create_loop(parent = NULL)
   on.exit(destroy_loop(loop))
 
   with_loop(loop, expr)
@@ -116,10 +170,13 @@ with_temp_loop <- function(expr) {
 #' @rdname create_loop
 #' @export
 with_loop <- function(loop, expr) {
-  if (!identical(loop, current_loop())) {
-    old_loop <- .globals$current_loop
-    on.exit(.globals$current_loop <- old_loop, add = TRUE)
-    .globals$current_loop <- loop
+  if (!exists_loop(loop)) {
+    stop("loop has been destroyed!")
+  }
+  old_loop <- current_loop()
+  if (!identical(loop, old_loop)) {
+    on.exit(setCurrentRegistryId(old_loop$id), add = TRUE)
+    setCurrentRegistryId(loop$id)
   }
 
   force(expr)
@@ -134,7 +191,11 @@ global_loop <- function() {
 
 #' @export
 format.event_loop <- function(x, ...) {
-  paste0("<event loop>\n  id: ", x$id)
+  str <- paste0("<event loop> ID: ", x$id)
+  if (!exists_loop(x)) {
+    str <- paste(str, "(destroyed)")
+  }
+  str
 }
 
 #' @export
@@ -191,15 +252,17 @@ later <- function(func, delay = 0, loop = current_loop()) {
   f <- rlang::as_function(func)
   id <- execLater(f, delay, loop$id)
 
-  invisible(create_canceller(id, loop))
+  invisible(create_canceller(id, loop$id))
 }
 
 # Returns a function that will cancel a callback with the given ID. If the
 # callback has already been executed or canceled, then the function has no
 # effect.
-create_canceller <- function(id, loop) {
+create_canceller <- function(id, loop_id) {
+  force(id)
+  force(loop_id)
   function() {
-    invisible(cancel(id, loop$id))
+    invisible(cancel(id, loop_id))
   }
 }
 
@@ -236,9 +299,7 @@ run_now <- function(timeoutSecs = 0L, all = TRUE, loop = current_loop()) {
   if (!is.numeric(timeoutSecs))
     stop("timeoutSecs must be numeric")
 
-  with_loop(loop,
-    invisible(execCallbacks(timeoutSecs, all, loop$id))
-  )
+  invisible(execCallbacks(timeoutSecs, all, loop$id))
 }
 
 #' Check if later loop is empty

inst/include/later.h

@@ -29,10 +29,10 @@ namespace later {
 // int (*dll_api_version)() = (int (*)()) R_GetCCallable("later", "apiVersion");
 // if (LATER_H_API_VERSION != (*dll_api_version)()) { ... }
 #define LATER_H_API_VERSION 2
-
 #define GLOBAL_LOOP 0
 
-inline void later(void (*func)(void*), void* data, double secs, int loop) {
+
+inline void later(void (*func)(void*), void* data, double secs, int loop_id) {
   // This function works by retrieving the later::execLaterNative2 function
   // pointer using R_GetCCallable the first time it's called (per compilation
   // unit, since it's inline). execLaterNative2 is designed to be safe to call
@@ -69,41 +69,11 @@ inline void later(void (*func)(void*), void* data, double secs, int loop) {
     return;
   }
 
-  eln(func, data, secs, loop);
+  eln(func, data, secs, loop_id);
 }
 
 inline void later(void (*func)(void*), void* data, double secs) {
-  typedef void (*elnfun)(void (*func)(void*), void*, double);
-  static elnfun eln = NULL;
-  if (!eln) {
-    // Initialize if necessary
-    if (func) {
-      // We're not initialized but someone's trying to actually schedule
-      // some code to be executed!
-      REprintf(
-        "Warning: later::execLaterNative called in uninitialized state. "
-        "If you're using <later.h>, please switch to <later_api.h>.\n"
-      );
-    }
-    eln = (elnfun)R_GetCCallable("later", "execLaterNative");
-  }
-
-  // We didn't want to execute anything, just initialize
-  if (!func) {
-    return;
-  }
-
-  eln(func, data, secs);
-
-
-  // Note 2019-09-11: The above code in this function is here just in case a
-  // package built with this version of later.h is run with an older version
-  // of the later DLL which does not have the execLaterNative2 function. In
-  // the next release of later, after we are confident that users have
-  // installed the newer later DLL which has execLaterNative2, it should be
-  // safe to replace the code in this function with just this:
-  //
-  // later(func, data, secs, GLOBAL_LOOP);
+  later(func, data, secs, GLOBAL_LOOP);
 }
 
 

inst/include/later_api.h

@@ -8,14 +8,12 @@ namespace {
   class LaterInitializer {
   public:
     LaterInitializer() {
-      // See comment in execLaterNative2 to learn why we need to do this in a
-      // statically initialized object.
-      later::later(NULL, NULL, 0, GLOBAL_LOOP);
-      // For execLaterNative
+      // See comment in execLaterNative to learn why we need to do this
+      // in a statically initialized object
       later::later(NULL, NULL, 0);
     }
   };
-
+  
   static LaterInitializer init;
 
 } // namespace