7167af4830
A repl or nREPL session now turns tail-frame tracing on, so an uncaught error in evaluated/reloaded code shows a tail-frame backtrace with no JOLT_TRACE set. The REPL and nREPL catch errors themselves rather than going through the uncaught reporter, so they now print the history backtrace via a new jolt.host/backtrace- string (history-only — the live continuation in a REPL is just REPL machinery). Because the recording is baked in at compile time, only code compiled while a session is live is traced; reload a namespace to trace already-loaded code. JOLT_TRACE=1 still forces it on for a whole run (a plain -M:run traces its own load); JOLT_TRACE=0 forces it off even in a session. No seed change — jolt.main/jolt.nrepl are runtime-loaded and compile-eval.ss / source-registry.ss are host files.
206 lines
11 KiB
Scheme
206 lines
11 KiB
Scheme
;; source-registry.ss — map emitted procedures back to Clojure source for native
|
|
;; stack traces, and render an uncaught throwable.
|
|
;;
|
|
;; A direct-linked def compiles to (define jv$ns$name <fn>); the back end also
|
|
;; emits (jolt-register-source! "jv$ns$name" ns name file line) once per such def
|
|
;; — at definition time, so there is zero per-call cost. On an uncaught error we
|
|
;; walk Chez's native continuation frames, read each frame's procedure name, and
|
|
;; look it up here to print a Clojure backtrace.
|
|
;;
|
|
;; CAVEATS. Names map only for stable Chez procedure names — direct-link / AOT
|
|
;; closed-world builds. The open-world -e/repl/run path stores fns in var cells
|
|
;; as anonymous lambdas, so its frames don't map (the trace falls back to the
|
|
;; top-level location compile-eval.ss tracks). Pervasive tail-call optimization
|
|
;; also erases tail-called frames, so even a mapped trace shows only the non-tail
|
|
;; spine — the immediate error site is often a tail call and won't appear.
|
|
|
|
;; Keyed by the procedure name Chez actually reports for a frame — the SHORT
|
|
;; munged fn name (the letrec self-binding emit-fn uses), e.g. "deepest", not the
|
|
;; jv$ns$name global. Two vars in different namespaces can share a short name; an
|
|
;; 'ambiguous marker then keeps the frame name in the trace but drops the
|
|
;; (now-uncertain) ns/file:line, so a trace is never misattributed.
|
|
(define source-registry (make-hashtable string-hash string=?))
|
|
|
|
(define (jolt-register-source! procname ns nm file line)
|
|
(let ((existing (hashtable-ref source-registry procname #f)))
|
|
(cond
|
|
((not existing) (hashtable-set! source-registry procname (vector ns nm file line)))
|
|
((and (vector? existing)
|
|
(or (not (equal? (vector-ref existing 0) ns))
|
|
(not (equal? (vector-ref existing 1) nm))))
|
|
(hashtable-set! source-registry procname 'ambiguous))))
|
|
jolt-nil)
|
|
(def-var! "jolt.host" "register-source!" jolt-register-source!)
|
|
|
|
;; The continuation to walk for an uncaught value: the one jolt-throw captured for
|
|
;; THIS value (identity-tagged via jolt-throw-cont, so a stale entry from an
|
|
;; earlier caught throw is never reused), else a host condition's own
|
|
;; &continuation, else #f. raw may arrive as the &jolt-throw condition wrapping
|
|
;; the value (the built-binary launcher hands jolt-report-throwable the guard's
|
|
;; raw value) or already unwrapped (the cli unwraps first); unwrap here so the
|
|
;; identity match holds either way.
|
|
(define (jolt-error-continuation raw)
|
|
(let* ((v (jolt-unwrap-throw raw))
|
|
(tc (jolt-throw-cont)))
|
|
(cond
|
|
((and (pair? tc) (eq? (car tc) v)) (cdr tc))
|
|
((and (condition? v) (continuation-condition? v)) (condition-continuation v))
|
|
(else #f))))
|
|
|
|
;; A frame inspector's procedure name as a string, or #f for a non-frame / unnamed.
|
|
(define (srcreg-frame-name io)
|
|
(and (guard (e (#t #f)) (eq? (io 'type) 'continuation))
|
|
(let ((code (guard (e (#t #f)) (io 'code))))
|
|
(and code
|
|
(let ((nm (guard (e (#t #f)) (code 'name))))
|
|
(cond ((string? nm) nm)
|
|
((symbol? nm) (symbol->string nm))
|
|
(else #f)))))))
|
|
|
|
;; 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.
|
|
(let ((debug? (getenv "JOLT_DEBUG_FRAMES")))
|
|
(guard (e (#t '()))
|
|
(let loop ((io (inspect/object k)) (n 0) (acc '()))
|
|
(if (or (not io) (fx>=? n 400))
|
|
(reverse acc)
|
|
(let* ((nm (srcreg-frame-name io))
|
|
(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*"
|
|
(if keep? "" " (skipped)")) "\n")
|
|
(current-error-port)))
|
|
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
|
|
(if keep? (cons (cons nm src) acc) acc))))))))
|
|
|
|
;; 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).
|
|
;; The tail-frame history ring rendered as a backtrace, or #f when tracing is off /
|
|
;; empty. A mapped frame is kept; else drop plumbing (same rule as the continuation
|
|
;; path) so the two sources read consistently.
|
|
(define (jolt-history-backtrace)
|
|
(let* ((hist (jolt-trace-snapshot))
|
|
(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)))))))
|
|
(and (pair? recs) (jolt-render-recs recs))))
|
|
|
|
(define (jolt-backtrace-string v)
|
|
(or (jolt-history-backtrace)
|
|
(let ((k (jolt-error-continuation v)))
|
|
(and k
|
|
(let ((recs (jolt-frame-records k)))
|
|
(and (pair? recs) (jolt-render-recs recs)))))))
|
|
|
|
;; Exposed for the REPL / nREPL error paths, which catch errors themselves instead
|
|
;; of going through the uncaught reporter. Returns the " trace:\n<frames>" block
|
|
;; from the tail-frame HISTORY only — the live continuation in a REPL is just the
|
|
;; REPL's own machinery — or nil when tracing is off (so a caller can when-let).
|
|
(def-var! "jolt.host" "backtrace-string"
|
|
(lambda ()
|
|
(let ((bt (jolt-history-backtrace)))
|
|
(if bt (string-append " trace:\n" bt) jolt-nil))))
|
|
|
|
;; 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
|
|
;; pr-str'd. Shared by the cli (cli.ss) and a built binary's launcher (build.ss).
|
|
(define (jolt-render-throwable raw port)
|
|
(let ((v (jolt-unwrap-throw raw)))
|
|
(if (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)
|
|
(begin
|
|
(display "Unhandled exception: " port)
|
|
(display (jolt-str-render-one (jolt-get v jolt-kw-message jolt-nil)) port)
|
|
(newline port)
|
|
(let ((data (jolt-get v jolt-kw-data jolt-nil)))
|
|
(unless (jolt-nil? data)
|
|
(display " ex-data: " port) (display (jolt-pr-str data) port) (newline port)))
|
|
(let ((cause (jolt-get v jolt-kw-cause jolt-nil)))
|
|
(when (condition? cause)
|
|
(display " cause: " port)
|
|
(display (with-output-to-string (lambda () (display-condition cause))) port)
|
|
(newline port))))
|
|
(begin
|
|
(display "Unhandled exception: " port)
|
|
(display (if (condition? v) (with-output-to-string (lambda () (display-condition v))) (jolt-pr-str v)) port)
|
|
(newline port)))))
|
|
|
|
;; Render the throwable, then its Clojure backtrace when one maps. The caller adds
|
|
;; any top-level source location (the runtime cli does; a built binary has none).
|
|
(define (jolt-report-throwable v port)
|
|
(jolt-render-throwable v port)
|
|
(let ((bt (jolt-backtrace-string v)))
|
|
(when bt (display " trace:\n" port) (display bt port))))
|