Fix ever-growing call stacks

NEWS.md

@@ -1,3 +1,8 @@
+# promises (under development)
+
+* Fixed bug introduced in 1.3.1, where promise domains that are active at promise resolution time stay active during handler callback, even if they weren't active when the handler was registered. This was causing stack overflow for long promise chains with many active promise domains. (#115)
+
+
 # promises 1.3.1
 
 * Fixed bug where promise domains were forgotten when handlers were registered from within other handlers. (#110)

R/domains.R

@@ -72,19 +72,20 @@ promiseDomain <- list(
       onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected
     )
     results <- results[!vapply(results, is.null, logical(1))]
-    if (!is.null(domain)) {
-      # If there's a domain, ensure that before any callback is invoked, we
-      # reenter the domain. This is important for this kind of code:
-      #
-      #     with_promise_domain(domain, {
-      #       async_sleep(0.1) %...>% {
-      #         async_sleep(0.1) %...>% {
-      #           # Without re-entry, this would be outside the domain!
-      #         }
-      #       }
-      #     })
-      results <- lapply(results, wrap_callback_reenter, domain = domain)
-    }
+    # If there's a domain, ensure that before any callback is invoked, we
+    # reenter the domain. This is important for this kind of code:
+    #
+    #     with_promise_domain(domain, {
+    #       async_sleep(0.1) %...>% {
+    #         async_sleep(0.1) %...>% {
+    #           # Without re-entry, this would be outside the domain!
+    #         }
+    #       }
+    #     })
+    #
+    # It's important to reenter even if domain is NULL. In that case, we need to
+    # ensure that the current domain is set to NULL while the callback executes.
+    results <- lapply(results, wrap_callback_reenter, domain = domain)
     results
   },
   onError = function(error) {
@@ -100,7 +101,10 @@ wrap_callback_reenter <- function(callback, domain) {
   force(domain)
 
   wrapper <- function(...) {
-    reenter_promise_domain(domain, callback(...))
+    # replace = TRUE because we don't care what the current domain is; we're
+    # (temporarily) putting the world back to the way it was when the callback
+    # was bound to a promise.
+    reenter_promise_domain(domain, callback(...), replace = TRUE)
   }
 
   # There are parts of this package that will inspect formals() to see if
@@ -171,7 +175,7 @@ with_promise_domain <- function(domain, expr, replace = FALSE) {
 }
 
 # Like with_promise_domain, but doesn't include the wrapSync call.
-reenter_promise_domain <- function(domain, expr, replace = FALSE) {
+reenter_promise_domain <- function(domain, expr, replace) {
   oldval <- current_promise_domain()
   if (replace)
     globals$domain <- domain

tests/testthat/test-cpp.R

@@ -17,9 +17,10 @@ describe("C++ interface", {
       }) %...>%
         {
           expect_identical(., 2)
+          expect_identical(cd$counts$onFulfilledCalled, 1L)
           promise_resolve(TRUE) %...>% {
             expect_true(!is.null(current_promise_domain()))
-            expect_identical(cd$counts$onFulfilledCalled, 3L)
+            expect_identical(cd$counts$onFulfilledCalled, 2L)
           }
         } %>%
         wait_for_it()

tests/testthat/test-domains.R

@@ -169,4 +169,48 @@ describe("Promise domains", {
     expect_identical(x, 2L)
 
   })
+
+  it("doesn't grow the call stack", {
+    # See https://github.com/rstudio/promises/issues/114
+    # and also https://github.com/jcheng5/shinychat/issues/16
+
+    recursive_promise <- function(n, .last_callstack_depth = NULL) {
+      if (n == 0) {
+        return(0)
+      } else {
+        promise_resolve(TRUE) %...>% {
+          current_callstack_depth <- length(sys.calls())
+          if (!is.null(.last_callstack_depth)) {
+            expect_identical(current_callstack_depth, .last_callstack_depth)
+          }
+
+          recursive_promise(n - 1, .last_callstack_depth = current_callstack_depth)
+        }
+      }
+    }
+
+    cd <- create_counting_domain()
+    with_promise_domain(cd, {
+      recursive_promise(5) %...>%
+        {
+          # 5 (from inside recursive_promise) + 1 (for the current handler)
+          expect_identical(cd$counts$onFulfilledCalled, 6L)
+        } %>%
+        wait_for_it()
+    })
+
+    cd2 <- create_counting_domain()
+    p <- recursive_promise(5)
+    with_promise_domain(cd2, {
+      p %...>%
+        {
+          # This time, none of the ones inside recursive_promise count, since
+          # they were bound outside of the influence of cd2 (even though they
+          # are resolved within the influence of cd2, thanks to wait_for_it()).
+          expect_identical(cd2$counts$onFulfilledCalled, 1L)
+        } %>%
+        wait_for_it()
+    })
+
+  })
 })