Limit deep stack growth (#4156)

* Limit deep stack growth * Improvements to deep stack trace culling - Keep around the first deep stack trace; it may have useful information. (We may want to change this in the future to keep the first two stack traces, or even make it an option) - Print out an indicator that we've elided stack traces, and how many * Add comments * Add NEWS item * Add test for unlimited deep stacks * Code review feedback * Code review feedback Co-authored-by: Carson Sievert <[email protected]> * Use head() over indexing Co-authored-by: Carson Sievert <[email protected]> * Improve unit test robustness * Remove vector indices from snapshot * Make stack trace stripping work across deep stacks * Pass tests * Try passing tests again * Rename keep_head to retain_first_n * Remove misleading variable assignment * Add more comments, refine dropTrivialTestFrames * Don't call stripStackTraces if we're not stripping * Use deep stack deduplication instead of elision This hopefully will avoid any potential ..stacktraceon../off.. scoring issues, and will be more useful for users. The downside is that it's still possible to have uselessly large deep stack traces, but at least that will only happen now if you have manually written gigantic async/promise chains by hand or maybe did some clever metaprogramming. The coro case should be fine. * Add coro-based unit test * Use rlang::hash, it's much faster * typo Co-authored-by: Carson Sievert <[email protected]> * Remove unnecessary logic * Simplify/robustify reactlog version checking test * Warn only once on call stack digest cache miss * Super conservatively wrap appendCallStackWithDupe in try/catch * Use more specific attribute name Co-authored-by: Carson Sievert <[email protected]> * Remove excessively cautious try/catch --------- Co-authored-by: Carson Sievert <[email protected]>
rstudio · Dec 6, 2024 · 79ee256 · 79ee256
1 parent 82c678a
commit 79ee256
Show file tree

Hide file tree

Showing 6 changed files with 1,067 additions and 77 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -95,6 +95,7 @@ Imports:
     cachem (>= 1.1.0),
     lifecycle (>= 0.2.0)
 Suggests:
+    coro (>= 1.1.0),
     datasets,
     DT,
     Cairo (>= 1.5-5),

diff --git a/NEWS.md b/NEWS.md
@@ -6,6 +6,8 @@
 
 * When spinners and the pulse busy indicators are enabled, Shiny now shows the pulse indicator when dynamic UI elements are recalculating if no other spinners are present in the app. (#4137)
 
+* Improve collection of deep stack traces (stack traces that are tracked across steps in an async promise chain) with `coro` async generators such as `elmer` chat streams. Previously, Shiny treated each iteration of an async generator as a distinct deep stack, leading to pathologically long stack traces; now, Shiny only keeps/prints unique deep stack trace, discarding duplicates. (#4156)
+
 ## Bug fixes
 
 * Fixed a bug in `conditionalPanel()` that would cause the panel to repeatedly show/hide itself when the provided condition was not boolean. (@kamilzyla, #4127)

diff --git a/R/conditions.R b/R/conditions.R
@@ -130,6 +130,44 @@ captureStackTraces <- function(expr) {
 #' @include globals.R
 .globals$deepStack <- NULL
 
+getCallStackDigest <- function(callStack, warn = FALSE) {
+  dg <- attr(callStack, "shiny.stack.digest", exact = TRUE)
+  if (!is.null(dg)) {
+    return(dg)
+  }
+
+  if (isTRUE(warn)) {
+    rlang::warn(
+      "Call stack doesn't have a cached digest; expensively computing one now",
+      .frequency = "once",
+      .frequency_id = "deepstack-uncached-digest-warning"
+    )
+  }
+
+  rlang::hash(getCallNames(callStack))
+}
+
+saveCallStackDigest <- function(callStack) {
+  attr(callStack, "shiny.stack.digest") <- getCallStackDigest(callStack, warn = FALSE)
+  callStack
+}
+
+# Appends a call stack to a list of call stacks, but only if it's not already
+# in the list. The list is deduplicated by digest; ideally the digests on the
+# list are cached before calling this function (you will get a warning if not).
+appendCallStackWithDedupe <- function(lst, x) {
+  digests <- vapply(lst, getCallStackDigest, character(1), warn = TRUE)
+  xdigest <- getCallStackDigest(x, warn = TRUE)
+  stopifnot(all(nzchar(digests)))
+  stopifnot(length(xdigest) == 1)
+  stopifnot(nzchar(xdigest))
+  if (xdigest %in% digests) {
+    return(lst)
+  } else {
+    return(c(lst, list(x)))
+  }
+}
+
 createStackTracePromiseDomain <- function() {
   # These are actually stateless, we wouldn't have to create a new one each time
   # if we didn't want to. They're pretty cheap though.
@@ -142,13 +180,14 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
+        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -165,13 +204,14 @@ createStackTracePromiseDomain <- function() {
         currentStack <- sys.calls()
         currentParents <- sys.parents()
         attr(currentStack, "parents") <- currentParents
+        currentStack <- saveCallStackDigest(currentStack)
         currentDeepStack <- .globals$deepStack
       }
       function(...) {
         # Fulfill time
         if (deepStacksEnabled()) {
           origDeepStack <- .globals$deepStack
-          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          .globals$deepStack <- appendCallStackWithDedupe(currentDeepStack, currentStack)
           on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
         }
 
@@ -199,6 +239,7 @@ doCaptureStack <- function(e) {
     calls <- sys.calls()
     parents <- sys.parents()
     attr(calls, "parents") <- parents
+    calls <- saveCallStackDigest(calls)
     attr(e, "stack.trace") <- calls
   }
   if (deepStacksEnabled()) {
@@ -281,86 +322,113 @@ printStackTrace <- function(cond,
   full = get_devmode_option("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  should_drop <- !full
-  should_strip <- !full
-  should_prune <- !full
-
-  stackTraceCalls <- c(
+  stackTraces <- c(
     attr(cond, "deep.stack.trace", exact = TRUE),
     list(attr(cond, "stack.trace", exact = TRUE))
   )
 
-  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
-  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
-  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
-
-  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
-  if (should_drop) {
-    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
-    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
-    # We apply the list of logical vector indices to each data structure
-    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
-    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+  # Stripping of stack traces is the one step where the different stack traces
+  # interact. So we need to do this in one go, instead of individually within
+  # printOneStackTrace.
+  if (!full) {
+    stripResults <- stripStackTraces(lapply(stackTraces, getCallNames))
+  } else {
+    # If full is TRUE, we don't want to strip anything
+    stripResults <- rep_len(list(TRUE), length(stackTraces))
   }
 
-  delayedAssign("all_true", {
-    # List of logical vectors that are all TRUE, the same shape as
-    # stackTraceCallNames. Delay the evaluation so we don't create it unless
-    # we need it, but if we need it twice then we don't pay to create it twice.
-    lapply(stackTraceCallNames, function(st) {
-      rep_len(TRUE, length(st))
-    })
-  })
-
-  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
-  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
-  # logical vectors.
-  toShow <- mapply(
-    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
-    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
-    FUN = `&`,
+  mapply(
+    seq_along(stackTraces),
+    rev(stackTraces),
+    rev(stripResults),
+    FUN = function(i, trace, stripResult) {
+      if (is.integer(trace)) {
+        noun <- if (trace > 1L) "traces" else "trace"
+        message("[ reached getOption(\"shiny.deepstacktrace\") -- omitted ", trace, " more stack ", noun, " ]")
+      } else {
+        if (i != 1) {
+          message("From earlier call:")
+        }
+        printOneStackTrace(
+          stackTrace = trace,
+          stripResult = stripResult,
+          full = full,
+          offset = offset
+        )
+      }
+      # No mapply return value--we're just printing
+      NULL
+    },
     SIMPLIFY = FALSE
   )
 
-  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
-    st <- data.frame(
-      num = rev(which(index)),
-      call = rev(nms[index]),
-      loc = rev(getLocs(calls[index])),
-      category = rev(getCallCategories(calls[index])),
-      stringsAsFactors = FALSE
-    )
+  invisible()
+}
 
-    if (i != 1) {
-      message("From earlier call:")
-    }
+printOneStackTrace <- function(stackTrace, stripResult, full, offset) {
+  calls <- offsetSrcrefs(stackTrace, offset = offset)
+  callNames <- getCallNames(stackTrace)
+  parents <- attr(stackTrace, "parents", exact = TRUE)
 
-    if (nrow(st) == 0) {
-      message("  [No stack trace available]")
-    } else {
-      width <- floor(log10(max(st$num))) + 1
-      formatted <- paste0(
-        "  ",
-        formatC(st$num, width = width),
-        ": ",
-        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
-          if (category == "pkg")
-            crayon::silver(name)
-          else if (category == "user")
-            crayon::blue$bold(name)
-          else
-            crayon::white(name)
-        }),
-        "\n"
-      )
-      cat(file = stderr(), formatted, sep = "")
-    }
+  should_drop <- !full
+  should_strip <- !full
+  should_prune <- !full
 
-    st
-  }, SIMPLIFY = FALSE)
+  if (should_drop) {
+    toKeep <- dropTrivialFrames(callNames)
+    calls <- calls[toKeep]
+    callNames <- callNames[toKeep]
+    parents <- parents[toKeep]
+    stripResult <- stripResult[toKeep]
+  }
 
-  invisible()
+  toShow <- rep(TRUE, length(callNames))
+  if (should_prune) {
+    toShow <- toShow & pruneStackTrace(parents)
+  }
+  if (should_strip) {
+    toShow <- toShow & stripResult
+  }
+
+  # If we're running in testthat, hide the parts of the stack trace that can
+  # vary based on how testthat was launched. It's critical that this is not
+  # happen at the same time as dropTrivialFrames, which happens before
+  # pruneStackTrace; because dropTrivialTestFrames removes calls from the top
+  # (or bottom? whichever is the oldest?) of the stack, it breaks `parents`
+  # which is based on absolute indices of calls. dropTrivialFrames gets away
+  # with this because it only removes calls from the opposite side of the stack.
+  toShow <- toShow & dropTrivialTestFrames(callNames)
+
+  st <- data.frame(
+    num = rev(which(toShow)),
+    call = rev(callNames[toShow]),
+    loc = rev(getLocs(calls[toShow])),
+    category = rev(getCallCategories(calls[toShow])),
+    stringsAsFactors = FALSE
+  )
+
+  if (nrow(st) == 0) {
+    message("  [No stack trace available]")
+  } else {
+    width <- floor(log10(max(st$num))) + 1
+    formatted <- paste0(
+      "  ",
+      formatC(st$num, width = width),
+      ": ",
+      mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+        if (category == "pkg")
+          crayon::silver(name)
+        else if (category == "user")
+          crayon::blue$bold(name)
+        else
+          crayon::white(name)
+      }),
+      "\n"
+    )
+    cat(file = stderr(), formatted, sep = "")
+  }
+
+  invisible(st)
 }
 
 stripStackTraces <- function(stackTraces, values = FALSE) {
@@ -458,6 +526,33 @@ dropTrivialFrames <- function(callnames) {
   )
 }
 
+dropTrivialTestFrames <- function(callnames) {
+  if (!identical(Sys.getenv("TESTTHAT_IS_SNAPSHOT"), "true")) {
+    return(rep_len(TRUE, length(callnames)))
+  }
+
+  hideable <- callnames %in% c(
+    "test",
+    "devtools::test",
+    "test_check",
+    "testthat::test_check",
+    "test_dir",
+    "testthat::test_dir",
+    "test_file",
+    "testthat::test_file",
+    "test_local",
+    "testthat::test_local"
+  )
+
+  firstGoodCall <- min(which(!hideable))
+  toRemove <- firstGoodCall - 1L
+
+  c(
+    rep_len(FALSE, toRemove),
+    rep_len(TRUE, length(callnames) - toRemove)
+  )
+}
+
 offsetSrcrefs <- function(calls, offset = TRUE) {
   if (offset) {
     srcrefs <- getSrcRefs(calls)