Skip to content

Commit

Permalink
Stack trace domain explosion (#4155)
Browse files Browse the repository at this point in the history
* Avoid way too many promise domains being activated

Using `captureStackTraces` in wrapForContext is a bad idea, it
piles on a new domain every time a handler is bound.

* Use captureStackTraces, it means the same thing

* Update promises version requirement

* Add test for stack trace growth

* Simplify stack trace snapshot tests

The `category` column isn't a good candidate for snapshot
testing, as its contents vary depending on how the package
was loaded/installed. During devtools::test() or similar,
shiny package code shows up as 'user'. But during CI, it
doesn't show up as anything.
  • Loading branch information
jcheng5 authored Dec 3, 2024
1 parent 501b012 commit 4589245
Show file tree
Hide file tree
Showing 6 changed files with 154 additions and 48 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -83,7 +83,7 @@ Imports:
R6 (>= 2.0),
sourcetools,
later (>= 1.0.0),
promises (>= 1.1.0),
promises (>= 1.3.2),
tools,
crayon,
rlang (>= 0.4.10),
Expand Down
14 changes: 7 additions & 7 deletions R/react.R
Original file line number Diff line number Diff line change
Expand Up @@ -53,10 +53,12 @@ Context <- R6Class(

promises::with_promise_domain(reactivePromiseDomain(), {
withReactiveDomain(.domain, {
env <- .getReactiveEnvironment()
rLog$enter(.reactId, id, .reactType, .domain)
on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
env$runWith(self, func)
captureStackTraces({
env <- .getReactiveEnvironment()
rLog$enter(.reactId, id, .reactType, .domain)
on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
env$runWith(self, func)
})
})
})
},
Expand Down Expand Up @@ -223,9 +225,7 @@ wrapForContext <- function(func, ctx) {

function(...) {
.getReactiveEnvironment()$runWith(ctx, function() {
captureStackTraces(
func(...)
)
func(...)
})
}
}
Expand Down
2 changes: 1 addition & 1 deletion R/shiny.R
Original file line number Diff line number Diff line change
Expand Up @@ -2024,7 +2024,7 @@ ShinySession <- R6Class(
tmpdata <- tempfile(fileext = ext)
return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
promises::with_promise_domain(reactivePromiseDomain(), {
promises::with_promise_domain(createStackTracePromiseDomain(), {
captureStackTraces({
self$incrementBusyCount()
hybrid_chain(
# ..stacktraceon matches with the top-level ..stacktraceoff..
Expand Down
90 changes: 90 additions & 0 deletions tests/testthat/_snaps/stacks.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,90 @@
# integration tests

Code
df
Output
num call loc
1 64 A [test-stacks.R#3]
2 63 B [test-stacks.R#7]
3 62 <reactive:C> [test-stacks.R#11]
4 42 C
5 41 renderTable [test-stacks.R#18]
6 40 func
7 39 force
8 38 withVisible
9 37 withCallingHandlers

---

Code
df
Output
num call loc
1 67 h
2 66 .handleSimpleError
3 65 stop
4 64 A [test-stacks.R#3]
5 63 B [test-stacks.R#7]
6 62 <reactive:C> [test-stacks.R#11]
7 61 ..stacktraceon..
8 60 .func
9 59 withVisible
10 58 withCallingHandlers
11 57 contextFunc
12 56 env$runWith
13 55 withCallingHandlers
14 54 domain$wrapSync
15 53 promises::with_promise_domain
16 52 captureStackTraces
17 51 force
18 50 domain$wrapSync
19 49 promises::with_promise_domain
20 48 withReactiveDomain
21 47 domain$wrapSync
22 46 promises::with_promise_domain
23 45 ctx$run
24 44 self$.updateValue
25 43 ..stacktraceoff..
26 42 C
27 41 renderTable [test-stacks.R#18]
28 40 func
29 39 force
30 38 withVisible
31 37 withCallingHandlers
32 36 domain$wrapSync
33 35 promises::with_promise_domain
34 34 captureStackTraces
35 33 doTryCatch
36 32 tryCatchOne
37 31 tryCatchList
38 30 tryCatch
39 29 do
40 28 hybrid_chain
41 27 renderFunc
42 26 renderTable({ C() }, server = FALSE)
43 25 ..stacktraceon.. [test-stacks.R#17]
44 24 contextFunc
45 23 env$runWith
46 22 withCallingHandlers
47 21 domain$wrapSync
48 20 promises::with_promise_domain
49 19 captureStackTraces
50 18 force
51 17 domain$wrapSync
52 16 promises::with_promise_domain
53 15 withReactiveDomain
54 14 domain$wrapSync
55 13 promises::with_promise_domain
56 12 ctx$run
57 11 ..stacktraceoff..
58 10 isolate
59 9 withCallingHandlers [test-stacks.R#16]
60 8 domain$wrapSync
61 7 promises::with_promise_domain
62 6 captureStackTraces
63 5 doTryCatch [test-stacks.R#15]
64 4 tryCatchOne
65 3 tryCatchList
66 2 tryCatch
67 1 try

49 changes: 49 additions & 0 deletions tests/testthat/test-promise-domains.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
with_several_promise_domains <- function(expr) {
withReactiveDomain(MockShinySession$new(), {
promises::with_promise_domain(reactivePromiseDomain(), {
captureStackTraces({
expr
})
})
})
}

recursive_promise <- function(n, callback = identity) {
if (n <= 0) {
return(promise_resolve(0))
}

p <- promises::promise_resolve(TRUE)
promises::then(p, ~{
callback(n)
recursive_promise(n - 1, callback = callback)
})
}

test_that("Stack trace doesn't grow (resolution within domain)", {

depths <- list()
with_several_promise_domains({
recursive_promise(10, function(n) {
depths <<- c(depths, list(length(sys.calls())))
})
while (!later::loop_empty()) {
later::run_now()
}
})
expect_equal(diff(range(depths)), 0)
})

test_that("Stack trace doesn't grow (resolution outside domain)", {

depths <- list()
with_several_promise_domains({
recursive_promise(10, function(n) {
depths <<- c(depths, list(length(sys.calls())))
})
})
while (!later::loop_empty()) {
later::run_now()
}
expect_equal(diff(range(depths)), 0)
})
45 changes: 6 additions & 39 deletions tests/testthat/test-stacks.R
Original file line number Diff line number Diff line change
Expand Up @@ -98,14 +98,15 @@ extractStackTrace <- function(calls,
num = index,
call = getCallNames(calls),
loc = getLocs(calls),
category = getCallCategories(calls),
# category = getCallCategories(calls),
stringsAsFactors = FALSE
)
}

cleanLocs <- function(locs) {
locs[!grepl("test-stacks\\.R", locs, perl = TRUE)] <- ""
sub("^.*#", "", locs)
# sub("^.*#", "", locs)
locs
}

dumpTests <- function(df) {
Expand All @@ -129,46 +130,12 @@ test_that("integration tests", {
df <- causeError(full = FALSE)
# dumpTests(df)

expect_equal(df$num, c(56L, 55L, 54L, 38L, 37L, 36L, 35L, 34L, 33L))
expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable",
"func", "force", "withVisible", "withCallingHandlers"))
expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE,
FALSE, FALSE, FALSE, FALSE))
expect_snapshot(df)

df <- causeError(full = TRUE)
# dumpTests(df)

expect_equal(df$num, c(59L, 58L, 57L, 56L, 55L, 54L, 53L,
52L, 51L, 50L, 49L, 48L, 47L, 46L, 45L, 44L, 43L, 42L, 41L,
40L, 39L, 38L, 37L, 36L, 35L, 34L, 33L, 32L, 31L, 30L, 29L,
28L, 27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L,
16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L,
3L, 2L, 1L))
expect_equal(df$call, c("h", ".handleSimpleError", "stop",
"A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible",
"withCallingHandlers", "contextFunc", "env$runWith", "force",
"domain$wrapSync", "promises::with_promise_domain",
"withReactiveDomain", "domain$wrapSync", "promises::with_promise_domain",
"ctx$run", "self$.updateValue", "..stacktraceoff..", "C",
"renderTable", "func", "force", "withVisible", "withCallingHandlers",
"domain$wrapSync", "promises::with_promise_domain",
"captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
"tryCatch", "do", "hybrid_chain", "renderFunc", "renderTable({ C() }, server = FALSE)",
"..stacktraceon..", "contextFunc", "env$runWith", "force",
"domain$wrapSync", "promises::with_promise_domain",
"withReactiveDomain", "domain$wrapSync", "promises::with_promise_domain",
"ctx$run", "..stacktraceoff..", "isolate", "withCallingHandlers",
"domain$wrapSync", "promises::with_promise_domain",
"captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
"tryCatch", "try"))
expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE,
TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE,
FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE,
FALSE))
expect_snapshot(df)
# dumpTests(df)
})

test_that("shiny.error", {
Expand Down

0 comments on commit 4589245

Please sign in to comment.