From dab2351354ecbdc6292727fbcfaf9c3be64425f9 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Thu, 12 Sep 2024 14:17:44 -0500 Subject: [PATCH 1/5] Radically simpler approach to stripping irrelevant stack --- R/profvis.R | 21 ++--- R/rprof.R | 135 -------------------------------- tests/testthat/_snaps/rprof.md | 42 ---------- tests/testthat/helper-profvis.R | 22 ++---- tests/testthat/test-profvis.R | 2 + tests/testthat/test-rprof.R | 74 ----------------- 6 files changed, 21 insertions(+), 275 deletions(-) delete mode 100644 R/rprof.R delete mode 100644 tests/testthat/_snaps/rprof.md delete mode 100644 tests/testthat/test-rprof.R diff --git a/R/profvis.R b/R/profvis.R index 6629adee..32022f55 100644 --- a/R/profvis.R +++ b/R/profvis.R @@ -171,12 +171,13 @@ profvis <- function(expr = NULL, if (remove_on_exit) { on.exit(unlink(prof_output), add = TRUE) } - repeat { - # Work around https://github.com/r-lib/rlang/issues/1749 - eval(substitute(delayedAssign("expr", expr_q, eval.env = env))) + # Use unique name so we can easily trim below + `__profvis_execute__` <- new_function(list(), expr_q, env) + + repeat { inject(Rprof(prof_output, !!!rprof_args)) - cnd <- with_profvis_handlers(expr) + cnd <- with_profvis_handlers(`__profvis_execute__`()) Rprof(NULL) lines <- readLines(prof_output) @@ -188,12 +189,7 @@ profvis <- function(expr = NULL, } } - # Must be in the same handler context as `expr` above to get the - # full stack suffix - with_profvis_handlers({ - suffix <- rprof_current_suffix(env, simplify) - lines <- gsub(suffix, "", lines) - }) + lines <- gsub('"__profvis_execute__".*$', "", lines) } else { # If we got here, we were provided a prof_input file instead of expr expr_source <- NULL @@ -308,3 +304,8 @@ renderProfvis <- function(expr, env = parent.frame(), quoted = FALSE) { if (!quoted) { expr <- substitute(expr) } # force quoted shinyRenderWidget(expr, profvisOutput, env, quoted = TRUE) } + + +has_event <- function() { + getRversion() >= "4.4.0" +} diff --git a/R/rprof.R b/R/rprof.R deleted file mode 100644 index 879a66b8..00000000 --- a/R/rprof.R +++ /dev/null @@ -1,135 +0,0 @@ -#' Generate profiler lines for an expression -#' -#' @param expr Expression to profile. The expression is repeatedly -#' evaluated until `Rprof()` produces an output. Can _be_ a quosure -#' injected with [rlang::inject()] but cannot _contain_ injected -#' quosures. -#' @param ... Arguments passed to `Rprof()`. -#' @param trim_stack Whether to trim the current call stack from the -#' profiles. -#' @param rerun Regexp or `NULL`. If supplied, resamples a new -#' profile until the regexp matches the modal profile -#' stack. Metadata is removed from the profiles before matching and -#' taking the modal value. -#' @noRd -rprof_lines <- function(expr, - ..., - interval = 0.010, - filter.callframes = FALSE, - trim_stack = TRUE, - rerun = FALSE) { - c(expr, env) %<-% enquo0_list(expr) - - lines <- character() - - prof_file <- tempfile("profvis-snapshot", fileext = ".prof") - on.exit(unlink(prof_file), add = TRUE) - on.exit(Rprof(NULL), add = TRUE) - - while (TRUE) { - env_bind_lazy(current_env(), do = !!expr, .eval_env = env) - - gc() - Rprof( - prof_file, - ..., - interval = interval, - filter.callframes = filter.callframes - ) - - do - Rprof(NULL) - - lines <- zap_header(readLines(prof_file, warn = FALSE)) - - if (trim_stack) { - suffix <- rprof_current_suffix(env, filter.callframes, ...) - lines <- gsub(suffix, "", lines) - } - - if (prof_matches(lines, rerun)) { - break - } - } - - lines -} - -re_srcref <- "\\d+#\\d+" -re_srcref_opt <- sprintf(" (%s )?", re_srcref) - -rprof_current_suffix <- function(env, simplify, ...) { - if (simplify) { - # We need to call the suffix routine from the caller frame. We - # inline a closure in the call so we can refer to here despite - # evaluating in a foreign environment. Evaluation is done through - # a promise to keep the call stack simple. - call <- call2(function() rprof_current_suffix_linear(...)) - env_bind_lazy(current_env(), do = !!call, .eval_env = env) - do - } else { - rprof_current_suffix_full(...) - } -} -rprof_current_suffix_full <- function(...) { - lines <- rprof_lines( - pause(RPROF_SUFFIX_PAUSE_TIME), - trim_stack = FALSE, - ..., - rerun = "rprof_current_suffix_full" - ) - line <- modal_value(zap_meta_data(lines)) - - pattern <- sprintf(" \"rprof_current_suffix\"( %s)?", re_srcref) - pos <- gregexpr(pattern, line)[[1]] - - if (length(pos) != 1 || pos < 0) { - stop("Unexpected state in `rprof_current_suffix()`.") - } - suffix <- substring(line, pos + attr(pos, "match.length")) - - suffix <- gsub_srcref_as_wildcards(suffix) - paste0(suffix, "$") -} - -rprof_current_suffix_linear <- function(..., filter.callframes = NULL) { - lines <- rprof_lines( - pause(RPROF_SUFFIX_PAUSE_TIME), - trim_stack = FALSE, - ..., - filter.callframes = TRUE, - rerun = "rprof_current_suffix_linear" - ) - line <- modal_value(zap_meta_data(lines)) - - pattern <- sprintf( - "^\"pause\"%s\"rprof_current_suffix_linear\"%s\"\"%s", - re_srcref_opt, - re_srcref_opt, - re_srcref_opt - ) - suffix <- sub(pattern, "", line) - - suffix <- gsub_srcref_as_wildcards(suffix) - paste0(suffix, "$") -} - -RPROF_SUFFIX_PAUSE_TIME <- 0.100 - -# File labels of the suffix will differ with those of the actual -# profiles -gsub_srcref_as_wildcards <- function(lines) { - # Strip all existing srcrefs - lines <- gsub("\\d+#\\d+ ", "", lines) - - # Add wildcards for srcrefs - lines <- gsub("\" \"", sprintf("\"%s\"", re_srcref_opt), lines, fixed = TRUE) - - lines -} - -utils::globalVariables("do") - -has_event <- function() { - getRversion() >= "4.4.0" -} diff --git a/tests/testthat/_snaps/rprof.md b/tests/testthat/_snaps/rprof.md deleted file mode 100644 index ba1a805f..00000000 --- a/tests/testthat/_snaps/rprof.md +++ /dev/null @@ -1,42 +0,0 @@ -# `rprof_lines()` collects profiles - - Code - writeLines(modal_value0(out)) - Output - "pause" "f" - ---- - - Code - cat_rprof(f()) - Output - "pause" "f" - -# `filter.callframes` filters out intervening frames - - Code - cat_rprof(f(), filter.callframes = TRUE) - Output - "pause" "h" "g" "f" - ---- - - Code - cat_rprof(f(), filter.callframes = TRUE) - Output - "pause" "f" - -# stack is correctly stripped even with metadata profiling - - Code - writeLines(zap(metadata)) - Output - "pause" "f" - ---- - - Code - writeLines(zap(metadata_simplified)) - Output - "pause" "f" - diff --git a/tests/testthat/helper-profvis.R b/tests/testthat/helper-profvis.R index 44d29ebb..f74bd38b 100644 --- a/tests/testthat/helper-profvis.R +++ b/tests/testthat/helper-profvis.R @@ -1,23 +1,17 @@ - TEST_PAUSE_TIME <- 0.050 -cat_rprof <- function(expr, ..., rerun = "pause") { - out <- inject(rprof_lines({{ expr }}, ..., rerun = rerun)) - out <- modal_value0(out) - - if (is_null(out)) { - abort("Unexpected profile") - } - - cat(paste0(out, "\n")) -} - repro_profvis <- function(expr, ..., rerun = "pause", interval = 0.010) { inject(profvis({{ expr }}, ..., rerun = rerun, interval = interval)) } -zap_trailing_space <- function(lines) { - gsub(" $", "", lines) +call_stacks <- function(x) { + prof <- x$x$message$prof + stacks <- split(prof$label, prof$time) + vapply(stacks, paste, "", collapse = " ") +} + +modal_call <- function(x) { + modal_value0(call_stacks(x)) } profile_calls <- function(x) { diff --git a/tests/testthat/test-profvis.R b/tests/testthat/test-profvis.R index 0229c10e..424e46b0 100644 --- a/tests/testthat/test-profvis.R +++ b/tests/testthat/test-profvis.R @@ -30,6 +30,8 @@ test_that("expr and prof_input are mutually exclusive", { }) test_that("can capture profile of code with error", { + skip_on_covr() + f <- function() { pause(TEST_PAUSE_TIME) stop("error") diff --git a/tests/testthat/test-rprof.R b/tests/testthat/test-rprof.R deleted file mode 100644 index 29091a55..00000000 --- a/tests/testthat/test-rprof.R +++ /dev/null @@ -1,74 +0,0 @@ - -test_that("`rprof_lines()` collects profiles", { - skip_on_cran() - skip_on_covr() - - f <- function() pause(TEST_PAUSE_TIME) - - out <- rprof_lines(f(), rerun = "pause") - expect_snapshot(writeLines(modal_value0(out))) - - expect_snapshot(cat_rprof(f())) -}) - -test_that("`filter.callframes` filters out intervening frames", { - skip_on_cran() - skip_on_covr() - - # Chains of calls are kept - f <- function() g() - g <- function() h() - h <- function() pause(TEST_PAUSE_TIME) - expect_snapshot(cat_rprof(f(), filter.callframes = TRUE)) - - # Intervening frames are discarded - f <- function() identity(identity(pause(TEST_PAUSE_TIME))) - expect_snapshot(cat_rprof(f(), filter.callframes = TRUE)) -}) - -test_that("stack is correctly stripped even with metadata profiling", { - skip_on_cran() - skip_on_covr() - - f <- function() pause(TEST_PAUSE_TIME) - zap <- function(lines) modal_value0(zap_trailing_space(zap_srcref(zap_meta_data(lines)))) - - metadata <- rprof_lines( - f(), - line.profiling = TRUE, - memory.profiling = TRUE, - filter.callframes = FALSE, - rerun = "pause" - ) - expect_snapshot(writeLines(zap(metadata))) - - metadata_simplified <- rprof_lines( - f(), - line.profiling = TRUE, - memory.profiling = TRUE, - filter.callframes = TRUE, - rerun = "pause" - ) - expect_snapshot(writeLines(zap(metadata_simplified))) -}) - -test_that("`pause()` does not include .Call() when `line.profiling` is set", { - skip_on_cran() - skip_on_covr() - - f <- function() pause(TEST_PAUSE_TIME) - - # `pause()` should appear first on the line - out <- modal_value(rprof_lines(f(), line.profiling = TRUE, rerun = "pause")) - expect_true(grepl("^\"pause\" ", out)) -}) - -test_that("srcrefs do not prevent suffix replacement", { - line <- ":1509169:3184799:91929040:0:\"pause\" 1#1 \"f\" \"doTryCatch\" \"tryCatchOne\" \"tryCatchList\" \"doTryCatch\" \"tryCatchOne\" \"tryCatchList\" \"tryCatch\" 2#193 \"with_profvis_handlers\" 2#151 \"profvis\" " - suffix <- "\"doTryCatch\" \"tryCatchOne\" \"tryCatchList\" \"doTryCatch\" \"tryCatchOne\" \"tryCatchList\" \"tryCatch\" 2#193 \"with_profvis_handlers\" 2#151 \"profvis\" $" - re <- gsub_srcref_as_wildcards(suffix) - expect_equal( - gsub(re, "", line), - ":1509169:3184799:91929040:0:\"pause\" 1#1 \"f\" " - ) -}) From 3f77c0bf22ccfd6a19957a7ab8b697dca5cd85f3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 17 Sep 2024 07:45:06 -0500 Subject: [PATCH 2/5] Add a test that better reflects #130 --- src/pause.gcda | Bin 0 -> 128 bytes src/profvis-init.gcda | Bin 0 -> 76 bytes tests/testthat/test-profvis.R | 11 +++++++++++ 3 files changed, 11 insertions(+) create mode 100644 src/pause.gcda create mode 100644 src/profvis-init.gcda diff --git a/src/pause.gcda b/src/pause.gcda new file mode 100644 index 0000000000000000000000000000000000000000..ac0815e4f143db94209b03644875e9ee4076bae3 GIT binary patch literal 128 zcmYdHNlw?YFfg(H9QT@mfq{`3NPs}oPlY^)*g{4oAYY}Qj}a^ZRRiL@GON&psbK^1 XK^O!;>OnvPp=UA7T#z`-AP^e>>_-s+ literal 0 HcmV?d00001 diff --git a/src/profvis-init.gcda b/src/profvis-init.gcda new file mode 100644 index 0000000000000000000000000000000000000000..9751a608464ee07f313fcfc8df5983e73ec58a32 GIT binary patch literal 76 zcmYdHNlw?YFfe(d@GFXefq{`3NPs}ck!f2YVhb6WfP6-25i8BBIV`~cS literal 0 HcmV?d00001 diff --git a/tests/testthat/test-profvis.R b/tests/testthat/test-profvis.R index 424e46b0..486f7f3a 100644 --- a/tests/testthat/test-profvis.R +++ b/tests/testthat/test-profvis.R @@ -14,6 +14,17 @@ test_that("Irrelevant stack is trimmed from profiles (#123)", { expect_equal(profile_mode(out), "pause f") }) +test_that("Irrelevant stack is trimmed from profiles from inlined code", { + skip_on_cran() + skip_on_covr() + + out <- profvis(for (i in 1:1e4) rnorm(100), simplify = TRUE) + expect_equal(profile_mode(out), "rnorm") + + out <- profvis(for (i in 1:1e4) rnorm(100), simplify = FALSE) + expect_equal(profile_mode(out), "rnorm") +}) + test_that("defaults to elapsed timing", { skip_on_cran() skip_on_covr() From 47654729fb101ace62dc85705d643c30a69ec2bd Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 17 Sep 2024 07:49:24 -0500 Subject: [PATCH 3/5] More tests/polishing --- tests/testthat/helper-profvis.R | 4 ---- tests/testthat/test-profvis.R | 37 ++++++++++++++++++++++----------- 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/tests/testthat/helper-profvis.R b/tests/testthat/helper-profvis.R index f74bd38b..c932f7ba 100644 --- a/tests/testthat/helper-profvis.R +++ b/tests/testthat/helper-profvis.R @@ -1,9 +1,5 @@ TEST_PAUSE_TIME <- 0.050 -repro_profvis <- function(expr, ..., rerun = "pause", interval = 0.010) { - inject(profvis({{ expr }}, ..., rerun = rerun, interval = interval)) -} - call_stacks <- function(x) { prof <- x$x$message$prof stacks <- split(prof$label, prof$time) diff --git a/tests/testthat/test-profvis.R b/tests/testthat/test-profvis.R index 486f7f3a..7c6deb41 100644 --- a/tests/testthat/test-profvis.R +++ b/tests/testthat/test-profvis.R @@ -1,30 +1,42 @@ -test_that("Irrelevant stack is trimmed from profiles (#123)", { +test_that("irrelevant stack trimmed from function calls (#123)", { skip_on_cran() skip_on_covr() f <- function() pause(TEST_PAUSE_TIME) + g <- function() f() - out <- repro_profvis(f(), simplify = FALSE) - expect_equal(profile_mode(out), "pause f") - - out <- profvis(f(), simplify = TRUE, rerun = "pause", interval = 0.005) - expect_equal(profile_mode(out), "pause f") + out <- profvis(g(), simplify = TRUE, rerun = "pause") + expect_equal(profile_mode(out), "pause f g") - out <- repro_profvis(f(), simplify = TRUE) - expect_equal(profile_mode(out), "pause f") + out <- profvis(g(), simplify = FALSE, rerun = "pause") + expect_equal(profile_mode(out), "pause f g") }) -test_that("Irrelevant stack is trimmed from profiles from inlined code", { +test_that("irrelevant stack trimmed from inlined code (#130)", { skip_on_cran() skip_on_covr() - out <- profvis(for (i in 1:1e4) rnorm(100), simplify = TRUE) + out <- profvis(for (i in 1:1e4) rnorm(100), simplify = TRUE, rerun = "rnorm") expect_equal(profile_mode(out), "rnorm") - out <- profvis(for (i in 1:1e4) rnorm(100), simplify = FALSE) + out <- profvis(for (i in 1:1e4) rnorm(100), simplify = FALSE, rerun = "rnorm") expect_equal(profile_mode(out), "rnorm") }) +test_that("strips stack above profvis", { + skip_on_cran() + skip_on_covr() + + f <- function() pause(TEST_PAUSE_TIME) + profvis_wrap <- function(...) profvis(...) + + out <- profvis_wrap(f(), simplify = TRUE, rerun = "pause") + expect_equal(profile_mode(out), "pause f") + + out <- profvis_wrap(f(), simplify = FALSE, rerun = "pause") + expect_equal(profile_mode(out), "pause f") +}) + test_that("defaults to elapsed timing", { skip_on_cran() skip_on_covr() @@ -32,7 +44,7 @@ test_that("defaults to elapsed timing", { f <- function() Sys.sleep(TEST_PAUSE_TIME) - out <- repro_profvis(f(), rerun = "Sys.sleep") + out <- profvis(f(), rerun = "Sys.sleep") expect_equal(profile_mode(out), "Sys.sleep f") }) @@ -41,6 +53,7 @@ test_that("expr and prof_input are mutually exclusive", { }) test_that("can capture profile of code with error", { + skip_on_cran() skip_on_covr() f <- function() { From c9c5bd10f3af6001e94566c257bda0fc71c75b47 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 17 Sep 2024 07:50:55 -0500 Subject: [PATCH 4/5] Delete accidentally committed profiling files --- src/pause.gcda | Bin 128 -> 0 bytes src/profvis-init.gcda | Bin 76 -> 0 bytes 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 src/pause.gcda delete mode 100644 src/profvis-init.gcda diff --git a/src/pause.gcda b/src/pause.gcda deleted file mode 100644 index ac0815e4f143db94209b03644875e9ee4076bae3..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 128 zcmYdHNlw?YFfg(H9QT@mfq{`3NPs}oPlY^)*g{4oAYY}Qj}a^ZRRiL@GON&psbK^1 XK^O!;>OnvPp=UA7T#z`-AP^e>>_-s+ diff --git a/src/profvis-init.gcda b/src/profvis-init.gcda deleted file mode 100644 index 9751a608464ee07f313fcfc8df5983e73ec58a32..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 76 zcmYdHNlw?YFfe(d@GFXefq{`3NPs}ck!f2YVhb6WfP6-25i8BBIV`~cS From fe2286a36fa06079e7354306efcd4bc123ccaf85 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Tue, 17 Sep 2024 08:48:02 -0500 Subject: [PATCH 5/5] Add docs --- NEWS.md | 1 + R/profvis.R | 12 ++++++++++-- man/profvis.Rd | 9 +++++++-- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 0cd9b456..204a3bc2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # profvis (development version) +* New technique for trimming uninteresting frames from the stack (#130). This requires a new evaluationg model where the code you supply to `profvis()` is turned into the body of a zero-argument anonymous function that is then called by profvis. This subtly changes the semantics of evaluation, but it's very unlikely to affect the type of code that you are typically profiling. * Bundled `highlight.js` updated to the latest version 11.10.0. * The CSS for profvis code is scoped so that it does not affect other blocks of code, such as those from RMarkdown or Quarto (@wch, #140). * profvis now relies on R 4.0.0. diff --git a/R/profvis.R b/R/profvis.R index 32022f55..4145ef69 100644 --- a/R/profvis.R +++ b/R/profvis.R @@ -8,10 +8,15 @@ #' corresponding data file as the `prof_input` argument to #' `profvis()`. #' -#' @param expr Expression to profile. Not compatible with `prof_input`. +#' @param expr Expression to profile. The expression will be turned into the +#' body of a zero-argument anonymous function which is then called repeatedly +#' as needed. +#' #' The expression is repeatedly evaluated until `Rprof()` produces #' an output. It can _be_ a quosure injected with [rlang::inject()] but #' it cannot _contain_ injected quosures. +#' +#' Not compatible with `prof_input`. #' @param interval Interval for profiling samples, in seconds. Values less than #' 0.005 (5 ms) will probably not result in accurate timings #' @param prof_output Name of an Rprof output file or directory in which to save @@ -172,7 +177,10 @@ profvis <- function(expr = NULL, on.exit(unlink(prof_output), add = TRUE) } - # Use unique name so we can easily trim below + # We call the quoted expression directly inside a function to make it + # easy to detect in both raw and simplified stack traces. The simplified + # case is particularly tricky because evaluating a promise fails to create + # a call on the trailing edges of the tree returned by simplification `__profvis_execute__` <- new_function(list(), expr_q, env) repeat { diff --git a/man/profvis.Rd b/man/profvis.Rd index de76e882..6a02e20c 100644 --- a/man/profvis.Rd +++ b/man/profvis.Rd @@ -19,10 +19,15 @@ profvis( ) } \arguments{ -\item{expr}{Expression to profile. Not compatible with \code{prof_input}. +\item{expr}{Expression to profile. The expression will be turned into the +body of a zero-argument anonymous function which is then called repeatedly +as needed. + The expression is repeatedly evaluated until \code{Rprof()} produces an output. It can \emph{be} a quosure injected with \code{\link[rlang:inject]{rlang::inject()}} but -it cannot \emph{contain} injected quosures.} +it cannot \emph{contain} injected quosures. + +Not compatible with \code{prof_input}.} \item{interval}{Interval for profiling samples, in seconds. Values less than 0.005 (5 ms) will probably not result in accurate timings}