Recover TCO-elided frames in uncaught-error stack traces
On the eval path nothing registers a source map, so jolt-backtrace-string dropped every walkable frame and printed no trace at all. Keep any named, non-plumbing continuation frame (rendered as a bare name when unmapped) so a runtime error shows the surviving non-tail spine — "print what is available". Add an opt-in tail-frame history behind JOLT_TRACE for the frames TCO erases. Each compiled fn records itself on entry into a bounded ring-of-rings, MIT Scheme's "history" shape: the outer ring holds one rib per non-tail subproblem, each rib a small inner ring of the tail-calls made at that level. A tight tail loop churns one rib instead of flushing the spine, so the non-tail caller context survives and total space stays bounded. The reporter prefers this history over the continuation when it's present, and resets it per top-level form so an error's trace isn't padded with earlier REPL frames. The emitter marks a tail call with (jolt-trace-mark! #t) so the runtime routes the callee into the current rib vs a fresh one; a *tail?* dynamic var tracks tail position (cleared by default, passed through if/do/let/loop/fn-body). It's all gated on trace-frames?, which compile-eval turns on for JOLT_TRACE and emit-image/`jolt build` force off — so non-trace emitted output is byte-identical (prelude unchanged, seed re-minted), and a built binary carries no per-call cost.
This commit is contained in:
Yogthos
parent
773e647b4a
commit
a3e2365217
8 changed files with 511 additions and 170 deletions
|
|
@ -110,6 +110,13 @@
|
|||
;; older seed during the first re-mint pass.
|
||||
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
||||
(when (procedure? scv) (scv #t)))
|
||||
;; JOLT_TRACE opts into tail-frame history: the emitter prepends a frame-recording
|
||||
;; push to every runtime-compiled fn, and the ring buffer is allocated for this
|
||||
;; thread. Off by default, so a normal run emits and pays exactly as before.
|
||||
(when (getenv "JOLT_TRACE")
|
||||
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
|
||||
(when (procedure? stf) (stf #t)))
|
||||
(jolt-trace-enable!))
|
||||
|
||||
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with
|
||||
;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
|
||||
|
|
@ -235,6 +242,9 @@
|
|||
;; record this form's source location first, so a compile- or run-time error
|
||||
;; in it reports the right place.
|
||||
(jolt-enter-form! form)
|
||||
;; drop tail-frame history from earlier top-level forms, so an error's trace
|
||||
;; shows only this form's own call history (a no-op unless JOLT_TRACE is on).
|
||||
(jolt-trace-reset!)
|
||||
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,10 @@
|
|||
;; after it). Guarded for the first re-mint pass off an older seed.
|
||||
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
||||
(when (procedure? scv) (scv #f)))
|
||||
;; Tail-frame tracing off for the mint + `jolt build`: the seed must stay a
|
||||
;; byte-fixpoint, and a built app should carry no per-call trace overhead.
|
||||
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
|
||||
(when (procedure? stf) (stf #f)))
|
||||
(define (ei-compile-form ctx f optimize?)
|
||||
(let ((ir (jolt-ce-analyze ctx f)))
|
||||
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
|
||||
|
|
|
|||
106
host/chez/rt.ss
106
host/chez/rt.ss
|
|
@ -60,6 +60,112 @@
|
|||
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
|
||||
;; call; the captured k is walked, never invoked.
|
||||
(define jolt-throw-cont (make-thread-parameter #f))
|
||||
|
||||
;; --- tail-frame history: a ring of rings (opt-in) ----------------------------
|
||||
;; TCO erases tail-called frames from the native continuation, so an uncaught
|
||||
;; error's backtrace shows only the surviving non-tail spine — the immediate error
|
||||
;; site is often a tail call and is missing. When tracing is enabled (JOLT_TRACE,
|
||||
;; wired in compile-eval.ss), each compiled fn records its frame-name on entry, and
|
||||
;; the reporter reads this history to recover TCO-elided frames.
|
||||
;;
|
||||
;; The store is MIT-Scheme's "history" shape — a ring of rings. The OUTER ring
|
||||
;; holds one RIB per non-tail subproblem (the real call spine); each rib's INNER
|
||||
;; ring holds the recent tail-calls made AT that subproblem. A non-tail entry
|
||||
;; advances the outer ring (a fresh rib); a tail entry rotates the current rib's
|
||||
;; inner ring. So a tight tail loop (mutual recursion, a non-recur self-tail-call)
|
||||
;; churns ONE rib's small inner ring instead of flushing the outer spine — the
|
||||
;; caller context that led into the loop survives. Both rings are fixed-size, so
|
||||
;; the whole history is bounded: a constant space factor, NOT a change to the
|
||||
;; asymptotic space TCO guarantees.
|
||||
;;
|
||||
;; Whether an entry is tail or non-tail is set by the CALLER: the emitter marks a
|
||||
;; tail call with (jolt-trace-mark! #t) right before it; a non-tail entry is the
|
||||
;; default. NOTE this is best-effort: a tail call routed through jolt-invoke to a
|
||||
;; target that has no entry prologue (a core/native fn, an anonymous fn held in a
|
||||
;; var) does not consume the mark, so a following non-tail frame can be mislabeled
|
||||
;; as a tail rotation — a cosmetic mis-grouping in the trace, never a wrong result.
|
||||
(define jolt-trace-outer-size 48) ; ribs (non-tail spine depth kept)
|
||||
(define jolt-trace-inner-size 6) ; tail-calls kept per subproblem
|
||||
;; A history: #(ribs-vector outer-head outer-count). A rib: #(name-vector head count).
|
||||
(define (jolt-make-rib) (vector (make-vector jolt-trace-inner-size #f) 0 0))
|
||||
(define (jolt-make-history)
|
||||
(let ((ribs (make-vector jolt-trace-outer-size #f)))
|
||||
(let loop ((i 0))
|
||||
(when (fx<? i jolt-trace-outer-size)
|
||||
(vector-set! ribs i (jolt-make-rib)) (loop (fx+ i 1))))
|
||||
(vector ribs 0 0)))
|
||||
;; A global switch (all threads) plus a per-thread ring, lazily created on first
|
||||
;; use — so code run on a spawned thread (a future/agent) records into ITS OWN
|
||||
;; history, not the enabling thread's (make-thread-parameter hands a new thread the
|
||||
;; initial #f, so we can't rely on inheritance).
|
||||
(define jolt-trace-on? #f)
|
||||
(define jolt-trace-ring (make-thread-parameter #f))
|
||||
(define jolt-trace-tail? (make-thread-parameter #f)) ; caller-set, consumed per entry
|
||||
(define (jolt-trace-enable!) (set! jolt-trace-on? #t) (jolt-trace-ring (jolt-make-history)))
|
||||
;; this thread's ring, created on demand while tracing is on
|
||||
(define (jolt-trace-cur-ring)
|
||||
(or (jolt-trace-ring)
|
||||
(and jolt-trace-on? (let ((h (jolt-make-history))) (jolt-trace-ring h) h))))
|
||||
;; Drop accumulated history at a top-level boundary (compile-eval.ss calls this per
|
||||
;; top-level form) so an error's trace shows only the forms that led to it, not the
|
||||
;; frames of earlier, already-returned REPL/eval forms.
|
||||
(define (jolt-trace-reset!)
|
||||
(when (jolt-trace-ring) (jolt-trace-ring (jolt-make-history)) (jolt-trace-tail? #f)))
|
||||
(define (jolt-trace-mark! t) (jolt-trace-tail? t))
|
||||
|
||||
;; push name into a rib's inner ring
|
||||
(define (jolt-rib-push! rib name)
|
||||
(let ((buf (vector-ref rib 0)) (i (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
||||
(vector-set! buf i name)
|
||||
(vector-set! rib 1 (fxmod (fx+ i 1) jolt-trace-inner-size))
|
||||
(when (fx<? cnt jolt-trace-inner-size) (vector-set! rib 2 (fx+ cnt 1)))))
|
||||
;; a non-tail entry: advance the outer ring, reset the new rib, seed it with name
|
||||
(define (jolt-history-nontail! h name)
|
||||
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2))
|
||||
(rib (vector-ref ribs oh)))
|
||||
(vector-set! rib 1 0) (vector-set! rib 2 0)
|
||||
(jolt-rib-push! rib name)
|
||||
(vector-set! h 1 (fxmod (fx+ oh 1) jolt-trace-outer-size))
|
||||
(when (fx<? oc jolt-trace-outer-size) (vector-set! h 2 (fx+ oc 1)))))
|
||||
;; a tail entry: rotate the CURRENT rib's inner ring (bootstrap a rib if none yet)
|
||||
(define (jolt-history-tail! h name)
|
||||
(if (fx=? (vector-ref h 2) 0)
|
||||
(jolt-history-nontail! h name)
|
||||
(let* ((ribs (vector-ref h 0))
|
||||
(cur (fxmod (fx+ (fx- (vector-ref h 1) 1) jolt-trace-outer-size)
|
||||
jolt-trace-outer-size)))
|
||||
(jolt-rib-push! (vector-ref ribs cur) name))))
|
||||
;; Record a frame entry, routed by the caller's tail mark; then reset the mark so a
|
||||
;; subsequent entry reached WITHOUT a mark (e.g. via apply) defaults to non-tail.
|
||||
(define (jolt-trace-push! name)
|
||||
(let ((h (jolt-trace-cur-ring)))
|
||||
(when h
|
||||
(if (jolt-trace-tail?) (jolt-history-tail! h name) (jolt-history-nontail! h name))
|
||||
(jolt-trace-tail? #f)))
|
||||
jolt-nil)
|
||||
|
||||
;; a rib's inner names, most-recent (deepest) tail first
|
||||
(define (jolt-rib-names rib)
|
||||
(let ((buf (vector-ref rib 0)) (head (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
||||
(let loop ((k 1) (acc '()))
|
||||
(if (fx>? k cnt)
|
||||
(reverse acc)
|
||||
(loop (fx+ k 1)
|
||||
(cons (vector-ref buf (fxmod (fx+ (fx- head k) jolt-trace-inner-size)
|
||||
jolt-trace-inner-size))
|
||||
acc))))))
|
||||
;; The whole history flattened to frame-names, most-recent (deepest) first:
|
||||
;; current rib's tail-history, then its non-tail caller's, and so on outward.
|
||||
(define (jolt-trace-snapshot)
|
||||
(let ((h (jolt-trace-ring)))
|
||||
(if (not h) '()
|
||||
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2)))
|
||||
(let loop ((k 1) (acc '()))
|
||||
(if (fx>? k oc)
|
||||
(apply append (reverse acc))
|
||||
(let ((idx (fxmod (fx+ (fx- oh k) jolt-trace-outer-size) jolt-trace-outer-size)))
|
||||
(loop (fx+ k 1) (cons (jolt-rib-names (vector-ref ribs idx)) acc)))))))))
|
||||
|
||||
(define-condition-type &jolt-throw &condition
|
||||
make-jolt-throw-condition jolt-throw-condition?
|
||||
(value jolt-throw-condition-value))
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -30,6 +30,39 @@ check_loc() {
|
|||
fi
|
||||
}
|
||||
|
||||
# An uncaught error's stack trace must name the runtime-eval'd fn frames that
|
||||
# survive TCO (the non-tail spine), even though the eval path registers no source
|
||||
# map — "print what is available". Asserts a substring appears under " trace:".
|
||||
check_trace() {
|
||||
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
|
||||
if printf '%s' "$err" | grep -q ' trace:' && printf '%s' "$err" | grep -q "$2"; then
|
||||
pass=$((pass + 1))
|
||||
else
|
||||
echo " FAIL (trace): $1"
|
||||
echo " want stderr trace to contain \`$2\`, got \`$err\`"
|
||||
fails=$((fails + 1))
|
||||
fi
|
||||
}
|
||||
|
||||
# JOLT_TRACE opts into the tail-frame history (the ring of rings): every $2 (an
|
||||
# ERE) must match the " trace:" block. Used to assert TCO-elided frames are
|
||||
# recovered and non-tail caller context survives a tail loop.
|
||||
check_trace_on() {
|
||||
err="$(JOLT_TRACE=1 bin/joltc -e "$1" 2>&1 >/dev/null)"
|
||||
ok=1
|
||||
printf '%s' "$err" | grep -q ' trace:' || ok=0
|
||||
shift
|
||||
for want in "$@"; do
|
||||
printf '%s' "$err" | grep -Eq "$want" || ok=0
|
||||
done
|
||||
if [ "$ok" = 1 ]; then
|
||||
pass=$((pass + 1))
|
||||
else
|
||||
echo " FAIL (trace-on): want [$*] in trace, got \`$err\`"
|
||||
fails=$((fails + 1))
|
||||
fi
|
||||
}
|
||||
|
||||
check '(+ 1 2)' '3'
|
||||
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
|
||||
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
|
||||
|
|
@ -60,6 +93,38 @@ check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while re
|
|||
check_loc '(throw (ex-info "boom" {}))' 'boom'
|
||||
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:'
|
||||
|
||||
# Runtime-eval'd fns aren't source-mapped, but their native frame names survive on
|
||||
# the non-tail spine; the trace must show them. deepest/+ are tail calls (erased);
|
||||
# middle and outer wait on a non-tail (inc …) so their frames are live at the throw.
|
||||
trace_prog='(defn deepest [x] (+ x 1)) (defn middle [x] (inc (deepest x))) (defn outer [x] (inc (middle x))) (outer :nan)'
|
||||
check_trace "$trace_prog" 'middle'
|
||||
check_trace "$trace_prog" 'outer'
|
||||
|
||||
# JOLT_TRACE (tail-frame history / ring of rings). An all-tail chain is entirely
|
||||
# TCO-erased from the continuation, but the history recovers every frame — incl.
|
||||
# `deepest`, the actual error site.
|
||||
check_trace_on '(defn deepest [x] (+ x 1)) (defn middle [x] (deepest x)) (defn outer [x] (middle x)) (outer :nan)' \
|
||||
'deepest' 'middle' 'outer'
|
||||
# A tail loop (a<->b) under a NON-tail caller: the loop is confined to one rib's
|
||||
# bounded inner ring, so the caller context (`driver`, `top`) is NOT flushed out —
|
||||
# the point of the ring of rings.
|
||||
check_trace_on '(declare b) (defn a [n] (if (zero? n) (+ :x 1) (b (dec n)))) (defn b [n] (a n)) (defn driver [] (inc (a 6))) (defn top [] (inc (driver))) (top)' \
|
||||
'driver' 'top'
|
||||
# A ^long/^double return hint wraps the body in a coercion, so the hinted fn's call
|
||||
# is NOT a tail call — its own frame is still live and must appear (not be elided).
|
||||
check_trace_on '(defn g [n] (+ :x n)) (defn ^long f [n] (g n)) (f 3)' 'f' 'g'
|
||||
# History is per top-level form: a later form's error trace shows its own frames
|
||||
# (h2/u2), not frames from an earlier, already-returned form (h1/u1).
|
||||
check_trace_on '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' \
|
||||
'h2' 'u2'
|
||||
err_stale="$(JOLT_TRACE=1 bin/joltc -e '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' 2>&1 >/dev/null)"
|
||||
if printf '%s' "$err_stale" | grep -q 'h1'; then
|
||||
echo " FAIL (trace-on): stale frame h1 from an earlier form leaked into the trace"
|
||||
fails=$((fails + 1))
|
||||
else
|
||||
pass=$((pass + 1))
|
||||
fi
|
||||
|
||||
# --help prints usage, and lists the nREPL server under its real flag name.
|
||||
help_out="$(bin/joltc --help 2>/dev/null)"
|
||||
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
|
||||
|
|
|
|||
|
|
@ -57,10 +57,36 @@
|
|||
((symbol? nm) (symbol->string nm))
|
||||
(else #f)))))))
|
||||
|
||||
;; Walk a continuation, returning the registered jolt frames (innermost first) as
|
||||
;; (frame-name . record) pairs, where record is #(ns name file line) or the symbol
|
||||
;; 'ambiguous. Unmapped frames (host spine, anonymous lambdas) are skipped; raw
|
||||
;; depth is capped.
|
||||
;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary,
|
||||
;; the var-cell trampoline, continuation/winder internals. They carry no Clojure
|
||||
;; meaning, so an unmapped frame with one of these names is dropped from the trace
|
||||
;; (a MAPPED frame is always kept — a jolt fn that happens to share the name still
|
||||
;; resolves to its source). Any name Chez prefixes with `$` (system) or that jolt
|
||||
;; prefixes with `jolt-` (host runtime) is plumbing too.
|
||||
(define srcreg-plumbing-names
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(for-each (lambda (s) (hashtable-set! h s #t))
|
||||
'("dynamic-wind" "winder-dummy" "ksrc" "invoke" "apply"
|
||||
"call-with-values" "call/cc" "call-with-current-continuation"
|
||||
"raise" "raise-continuable" "with-exception-handler" "guard"
|
||||
"eval" "compile" "interpret" "expand" "read" "load"
|
||||
;; host dispatch/coercion helpers (not `jolt-` prefixed) that carry
|
||||
;; no Clojure meaning in a trace
|
||||
"record-method-dispatch" "protocol-resolve" "devirt-resolve"
|
||||
"list->cseq" "host-static-call" "host-call"))
|
||||
h))
|
||||
(define (srcreg-plumbing-name? nm)
|
||||
(or (hashtable-ref srcreg-plumbing-names nm #f)
|
||||
(and (fx>? (string-length nm) 0) (char=? (string-ref nm 0) #\$))
|
||||
(and (fx>=? (string-length nm) 5) (string=? (substring nm 0 5) "jolt-"))))
|
||||
|
||||
;; Walk a continuation, returning its frames (innermost first) as (frame-name .
|
||||
;; record) pairs. record is a source vector #(ns name file line) for a frame that
|
||||
;; maps to registered Clojure source, the symbol 'ambiguous for a short name shared
|
||||
;; across namespaces, or #f for an unmapped-but-named frame (the common case on the
|
||||
;; open-world eval path, where nothing is registered — the bare frame name is still
|
||||
;; a useful trace line). Plumbing frames (host spine, eval boundary) and unnamed
|
||||
;; frames are skipped; raw depth is capped.
|
||||
(define (jolt-frame-records k)
|
||||
;; read the env at call time, not load time: a built binary runs top-level forms
|
||||
;; at heap-build time, where this would always be unset.
|
||||
|
|
@ -70,39 +96,72 @@
|
|||
(if (or (not io) (fx>=? n 400))
|
||||
(reverse acc)
|
||||
(let* ((nm (srcreg-frame-name io))
|
||||
(src (and nm (hashtable-ref source-registry nm #f))))
|
||||
(src (and nm (hashtable-ref source-registry nm #f)))
|
||||
;; keep a frame that maps, or any named frame that isn't plumbing
|
||||
(keep? (and nm (or src (not (srcreg-plumbing-name? nm))))))
|
||||
(when (and debug? nm)
|
||||
(display (string-append " [frame] " nm (if src " *MAPPED*" "") "\n")
|
||||
(display (string-append " [frame] " nm (if src " *MAPPED*"
|
||||
(if keep? "" " (skipped)")) "\n")
|
||||
(current-error-port)))
|
||||
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
|
||||
(if src (cons (cons nm src) acc) acc))))))))
|
||||
(if keep? (cons (cons nm src) acc) acc))))))))
|
||||
|
||||
;; Multi-line backtrace for an uncaught value — " ns/name (file:line)" for a
|
||||
;; mapped frame, the bare frame name for an ambiguous one — or #f when no jolt
|
||||
;; frame maps (the caller then prints just the top-level location). Capped to the
|
||||
;; innermost frames.
|
||||
;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a
|
||||
;; backtrace string. record is a source vector #(ns name file line) -> "ns/name
|
||||
;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same
|
||||
;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a
|
||||
;; loop re-enters), and the number of distinct lines is capped.
|
||||
(define (jolt-render-recs recs)
|
||||
(let ((port (open-output-string)))
|
||||
(let loop ((rs recs) (shown 0))
|
||||
(if (or (null? rs) (fx>=? shown 30))
|
||||
(get-output-string port)
|
||||
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
|
||||
;; count a maximal run of the same frame-name
|
||||
(let run ((tail (cdr rs)) (cnt 1))
|
||||
(if (and (pair? tail) (string=? (car (car tail)) frame-name))
|
||||
(run (cdr tail) (fx+ cnt 1))
|
||||
(begin
|
||||
(put-string port " ")
|
||||
(if (vector? r)
|
||||
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
|
||||
(file (vector-ref r 2)) (line (vector-ref r 3)))
|
||||
(put-string port ns) (put-string port "/") (put-string port nm)
|
||||
(when (string? file)
|
||||
(put-string port " (") (put-string port file)
|
||||
(put-string port ":") (put-string port (number->string line))
|
||||
(put-string port ")")))
|
||||
(put-string port frame-name)) ; 'ambiguous / unmapped: bare name
|
||||
(when (fx>? cnt 1)
|
||||
(put-string port " (x") (put-string port (number->string cnt)) (put-string port ")"))
|
||||
(put-char port #\newline)
|
||||
(loop tail (fx+ shown 1))))))))))
|
||||
|
||||
;; Multi-line backtrace for an uncaught value. Two sources, in preference order:
|
||||
;; 1. The tail-frame history ring (rt.ss), when JOLT_TRACE enabled it — an
|
||||
;; execution history of the runtime-compiled fns entered before the throw,
|
||||
;; INCLUDING ones TCO erased from the live continuation. Most-recent first.
|
||||
;; 2. Otherwise the live continuation (jolt-frame-records) — the accurate but
|
||||
;; TCO-truncated non-tail spine.
|
||||
;; Each frame maps to "ns/name (file:line)" when registered, else its bare name.
|
||||
;; #f when neither source yields a frame (the caller then prints just the location).
|
||||
(define (jolt-backtrace-string v)
|
||||
(let ((k (jolt-error-continuation v)))
|
||||
(and k
|
||||
(let ((recs (jolt-frame-records k)))
|
||||
(and (pair? recs)
|
||||
(let ((port (open-output-string)))
|
||||
(let loop ((rs recs) (shown 0))
|
||||
(when (and (pair? rs) (fx<? shown 30))
|
||||
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
|
||||
(put-string port " ")
|
||||
(if (vector? r)
|
||||
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
|
||||
(file (vector-ref r 2)) (line (vector-ref r 3)))
|
||||
(put-string port ns) (put-string port "/") (put-string port nm)
|
||||
(when (string? file)
|
||||
(put-string port " (") (put-string port file)
|
||||
(put-string port ":") (put-string port (number->string line))
|
||||
(put-string port ")")))
|
||||
(put-string port frame-name)) ; 'ambiguous: bare name
|
||||
(put-char port #\newline))
|
||||
(loop (cdr rs) (fx+ shown 1))))
|
||||
(get-output-string port)))))))
|
||||
(let* ((hist (jolt-trace-snapshot))
|
||||
;; a mapped frame is always kept; else drop plumbing (same rule as the
|
||||
;; continuation path) so the two backtrace sources read consistently
|
||||
(recs (let loop ((ns hist) (acc '()))
|
||||
(if (null? ns)
|
||||
(reverse acc)
|
||||
(let* ((nm (car ns)) (src (hashtable-ref source-registry nm #f)))
|
||||
(loop (cdr ns)
|
||||
(if (or src (not (srcreg-plumbing-name? nm)))
|
||||
(cons (cons nm src) acc) acc)))))))
|
||||
(if (pair? recs)
|
||||
(jolt-render-recs recs)
|
||||
(let ((k (jolt-error-continuation v)))
|
||||
(and k
|
||||
(let ((recs (jolt-frame-records k)))
|
||||
(and (pair? recs) (jolt-render-recs recs))))))))
|
||||
|
||||
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port:
|
||||
;; an ex-info shows its message + ex-data (+ a host cause); anything else is
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue