Nothing
#' Enrich an rlang traceback with details on native calls
#'
#' @description
#'
#' `r lifecycle::badge('deprecated')`
#'
#' This function should be reimplemented in rlang, to avoid a soft dependency between
#' rlang's traceback format and this package.
#'
#' @param trace An rlang traceback as returned by [rlang::trace_back()].
#'
#' @export
#' @keywords internal
winch_add_trace_back <- function(trace = rlang::trace_back(bottom = parent.frame())) {
lifecycle::deprecate_soft("0.1.0", "winch::winch_add_trace_back()")
if (!winch_available()) {
return(trace)
}
# Avoid recursion
old_options <- options(rlang_trace_use_winch = NULL)
on.exit(options(old_options))
rlang_trace <- trace
native_trace <- winch_trace_back()
# Remove __libc_start_main because it comes between two entries pointing to
# .../bin/exec/R
native_trace <- native_trace[is.na(native_trace$func) | native_trace$func != "__libc_start_main", ]
# FIXME: This is artificial, remove when done
#native_trace <- rep(native_trace, each = 3)
is_libr <- native_trace$is_libr
is_libr_idx <- which(is_libr)
if (length(is_libr_idx) == 0) {
warning("winch: libR not found in backtrace, can't merge.", call. = FALSE)
return(rlang_trace)
}
first_libr <- is_libr_idx[[length(is_libr_idx)]]
native_trace <- native_trace[seq_len(first_libr), ]
is_libr <- is_libr[seq_len(first_libr)]
# No native code called?
if (all(is_libr)) {
return(rlang_trace)
}
# Compute chunks of native stack traces between libR.so traces
is_libr_rle <- rle(cumsum(is_libr))
is_native_rle_idx <- which(is_libr_rle$lengths != 1)
native_idx_len <- is_libr_rle$lengths[is_native_rle_idx] - 1L
native_idx_end <- cumsum(is_libr_rle$lengths)[is_native_rle_idx]
native_trace_chunks <- rev(Map(native_idx_end, native_idx_len, f = function(end, len) {
native_trace[seq.int(end, by = -1L, length.out = len), ]
}))
# Find all functions in the stack trace that call .Call(),
# .External() or .External2()
r_funs <- sys_functions()
# The sys_functions() call must be separate, it is very brittle
# At this point the frames after bottom have been chopped off, if any.
# We're doing the same here with head()
r_funs <- utils::head(r_funs, rlang::trace_length(trace))
# Find calls in functions' bodies
r_fun_bodies <- lapply(r_funs, body)
r_fun_calls <- lapply(r_fun_bodies, find_calls)
r_fun_has_call_idx <- which(lengths(r_fun_calls) > 0)
if (length(r_fun_has_call_idx) == 0) {
# No .Call() found? Append at end
r_fun_has_call_idx <- length(r_funs)
}
if (length(r_fun_has_call_idx) > length(native_trace_chunks)) {
# Are there too many occurrences of .Call() etc.? Omit
length(r_fun_has_call_idx) <- length(native_trace_chunks)
} else if (length(r_fun_has_call_idx) < length(native_trace_chunks)) {
# Did we miss a call into native? Append at end
end_idx <- seq.int(length(r_fun_has_call_idx), length(native_trace_chunks), by = 1L)
native_trace_chunks[[length(r_fun_has_call_idx)]] <-
do.call(rbind, native_trace_chunks[end_idx])
length(native_trace_chunks) <- length(r_fun_has_call_idx)
}
# Insert native stack trace chunks into R stack trace
# Reverse order is important to avoid index shifts after inserting
# into the trace
for (i in rev(seq_along(r_fun_has_call_idx))) {
rlang_trace <- insert_native_chunk(rlang_trace, r_fun_has_call_idx[[i]], native_trace_chunks[[i]])
}
class(rlang_trace) <- c("winch_trace", class(rlang_trace))
rlang_trace
}
lag <- function(x, default = NA) {
c(default, x[-length(x)])
}
sys_functions <- function() {
idx <- seq_len(sys.nframe() - 2L)
lapply(idx, sys.function)
}
find_calls <- function(x) {
if (is.call(x)) {
fun <- x[[1L]]
if (identical(fun, quote(.Call))) {
x[[2L]]
} else if (identical(fun, quote(.External))) {
x[[2L]]
} else if (identical(fun, quote(.External2))) {
x[[2L]]
} else {
out <- lapply(as.list(x)[-1], find_calls)
unlist(out)
}
} else {
NULL
}
}
insert_native_chunk <- function(trace, idx, native) {
# Check for trace version
if (identical(attr(trace, "version"), 1L)) {
# pre 1.0.0
return(insert_native_chunk_0(trace, idx, native))
}
added_namespaces <- paste0("/", basename(native$pathname))
added_calls <- lapply(native$func, function(func) call(func))
old_size <- length(trace$call)
new_size <- old_size + length(added_calls)
if (old_size == new_size) {
# Nothing to do
return(native)
}
# Prepare for pasting
added_idx <- seq.int(idx + 1L, length.out = length(added_calls))
added_parents <- lag(added_idx, default = idx)
rechain_idx <- added_idx[[length(added_idx)]]
# Create translation table
xlat <- c(
seq_len(idx),
seq.int(idx + length(added_calls) + 1L, length.out = old_size - idx)
)
xlat1 <- c(0L, xlat)
# Move
new_parents <- rep(-1L, new_size)
new_parents[xlat] <- xlat1[trace$parent + 1L]
new_calls <- rep(NULL, new_size)
new_calls[xlat] <- trace$call
new_visible <- rep(TRUE, new_size)
new_visible[xlat] <- trace$visible
new_namespace <- rep(NA_character_, new_size)
new_namespace[xlat] <- trace$namespace
new_scope <- rep(NA_character_, new_size)
new_scope[xlat] <- trace$scope
new_idx <- seq_len(new_size)
# Rechain existing
parents_fix_idx <- (new_parents == idx)
grandparents_fix_idx <- (new_parents == new_parents[[idx]] & seq_along(new_parents) > idx)
new_parents[parents_fix_idx | grandparents_fix_idx] <- rechain_idx
# Paste (after rechaining!)
new_parents[added_idx] <- added_parents
new_calls[added_idx] <- added_calls
new_namespace[added_idx] <- added_namespaces
new_scope[added_idx] <- "::"
# Use new
new <- data.frame(
call = new_parents, parent = new_parents,
visible = new_visible, namespace = new_namespace, scope = new_scope,
stringsAsFactors = FALSE
)
# Can't pass in constructor
new$call <- new_calls
# Clumsy way of replacing the contents of `trace` without touching the attributes
new_idx <- seq_len(nrow(new))
trace[new_idx, ] <- trace[new_idx, ]
trace[] <- new
trace
}
insert_native_chunk_0 <- function(trace, idx, native) {
added_calls <- Map(
basename(native$pathname),
native$func,
f = function(basename, func) as.call(list(call(
"::",
as.name(paste0("/", basename)),
as.name(func)
)))
)
old_size <- length(trace$calls)
new_size <- old_size + length(added_calls)
if (old_size == new_size) {
# Nothing to do
return(native)
}
# Prepare for pasting
added_idx <- seq.int(idx + 1L, length.out = length(added_calls))
added_parents <- lag(added_idx, default = idx)
rechain_idx <- added_idx[[length(added_idx)]]
# Create translation table
xlat <- c(
seq_len(idx),
seq.int(idx + length(added_calls) + 1L, length.out = old_size - idx)
)
xlat1 <- c(0L, xlat)
# Move
new_parents <- rep(-1L, new_size)
new_parents[xlat] <- xlat1[trace$parents + 1L]
new_calls <- rep(NULL, new_size)
new_calls[xlat] <- trace$calls
new_idx <- seq_len(new_size)
# Rechain existing
parents_fix_idx <- new_parents == idx
grandparents_fix_idx <- (new_parents == new_parents[[idx]] & seq_along(new_parents) > idx)
new_parents[parents_fix_idx | grandparents_fix_idx] <- rechain_idx
# Paste (after rechaining!)
new_parents[added_idx] <- added_parents
new_calls[added_idx] <- added_calls
# Use new
trace$calls <- new_calls
trace$parents <- new_parents
trace$indices <- new_idx
trace
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.