simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Clojure stack traces via source registry + native frame walk

Browse source 
A direct-link build emits (jolt-register-source! short-name ns name file line)
once per fn def — at definition time, so zero per-call cost. On an uncaught
error the reporter walks Chez's native continuation frames (jolt-throw captures
the live continuation via call/cc; host conditions carry their own
&continuation), maps each frame's procedure name through the registry, and
prints a Clojure backtrace 'ns/name (file:line)'. Wired into both the cli and a
built binary's launcher.

Frames are keyed by the short munged fn name Chez actually reports (emit-fn's
letrec self-binding), not jv$ns$name; a cross-namespace collision degrades to
the bare frame name rather than a wrong attribution. The analyzer carries the
original form's position through defn macroexpansion onto the def node.

Calling a non-fn now throws a catchable ClassCastException (via jolt-throw)
naming the operator, instead of a raw Chez error.

Caveats (documented in source-registry.ss): names map only in direct-link/AOT
closed-world builds — the open-world -e/repl/run path falls back to the
top-level location; and pervasive TCO erases tail-call frames, so a mapped
trace shows only the non-tail spine. JOLT_DEBUG_FRAMES dumps raw frame names.

Re-mint (analyzer + backend); prelude byte-identical (direct-link off during
mint). Corpus rows certified, build-smoke asserts the trace.
This commit is contained in:
Yogthos 2026-06-25 21:49:11 -04:00
parent 9bf3d1c80e
commit 57bab5d409
12 changed files with 288 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

13
host/chez/build-smoke.sh
View file

@ -81,6 +81,19 @@ fi
if ! grep -q '(jv\$app.util\$shout' "$out.build/flat.ss"; then
echo " FAIL: --direct-link did not emit a direct app->app call"; exit 1
fi
# A direct-link build registers fn sources, so an uncaught throw prints a Clojure
# stack trace mapping each native frame back to ns/name (file:line).
if ! grep -q 'jolt-register-source!' "$out.build/flat.ss"; then
echo " FAIL: --direct-link did not emit source registrations"; exit 1
fi
boom_err="$(cd / && "$out" --boom 2>&1 >/dev/null)"
for frame in 'app.util/deep-boom' 'app.util/mid-boom' 'app.core/-main'; do
if ! printf '%s' "$boom_err" | grep -q "$frame"; then
echo " FAIL: stack trace missing frame $frame"
echo "--- got ----"; echo "$boom_err"
exit 1
fi
done
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
# expanded at AOT and never called at runtime) is dropped.
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then

19
host/chez/build.ss
View file

@ -337,18 +337,20 @@
;; ns + register aliases before this ns's forms; dce
;; keeps original order.
(let ((src (read-file-string (cdr nf))))
(append
(map (lambda (s) (dce-rec #t #f '() s))
(bld-ns-prelude (car nf) src))
(ei-emit-ns-records (car nf) src))))
(parameterize ((rdr-source-file (cdr nf)))
(append
(map (lambda (s) (dce-rec #t #f '() s))
(bld-ns-prelude (car nf) src))
(ei-emit-ns-records (car nf) src)))))
ordered))
(string-append entry-ns "/-main"))
(values #f
(apply append
(map (lambda (nf)
(let ((src (read-file-string (cdr nf))))
(append (bld-ns-prelude (car nf) src)
(bld-emit-ns (car nf) src))))
(parameterize ((rdr-source-file (cdr nf)))
(append (bld-ns-prelude (car nf) src)
(bld-emit-ns (car nf) src)))))
ordered))
#f)))
(lambda ()
@ -400,7 +402,10 @@
" (list \"jolt-core\" \"stdlib\"))))\n"))
(put-string out (string-append
" (let ((mainv (var-deref " (ei-str-lit entry-ns) " \"-main\")))\n"
" (apply jolt-invoke mainv args))\n"
;; render an uncaught throw (+ Clojure backtrace) instead
;; of Chez's opaque dump, then exit non-zero.
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n"
" (apply jolt-invoke mainv args)))\n"
" (exit 0)))\n"))
(close-port out))
;; 4. compile -> boot -> embed -> link.

25
host/chez/cli.ss
View file

@ -32,30 +32,17 @@
(set-source-roots! (list "jolt-core" "stdlib"))
;; Render an uncaught jolt throw (any value, not just a Chez condition) to stderr
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. An
;; ex-info shows its message + ex-data; anything else is pr-str'd.
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. The
;; message/ex-data/cause + a mapped Clojure backtrace come from the shared
;; renderer (source-registry.ss); the cli adds the top-level source location.
(define (jolt-report-uncaught v)
(let ((port (current-error-port)))
(if (and (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)))
(jolt-render-throwable v port)
;; The top-level form that was evaluating when this propagated (file:line:col).
(let ((loc (jolt-current-source-string)))
(when loc (display " at " port) (display loc port) (newline port)))
(let ((bt (jolt-backtrace-string v)))
(when bt (display " trace:\n" port) (display bt port)))
(exit 1)))
(guard (v (#t (jolt-report-uncaught v)))

12
host/chez/rt.ss
View file

@ -35,7 +35,13 @@
;; throw raises the jolt value RAW (no envelope);
;; catch (emitted as `guard`) binds it directly. Chez `raise` accepts any
;; object, so a thrown number/map/ex-info all work; uncaught -> non-zero exit.
(define (jolt-throw v) (raise v))
;; Capture the live continuation at the throw site (identity-tagged with the
;; thrown value) so an uncaught error can walk the native frames back to a Clojure
;; 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))
(define (jolt-throw v)
(call/cc (lambda (k) (jolt-throw-cont (cons v k)) (raise v))))
;; ex-info builds the tagged map {:jolt/type :jolt/ex-info :message :data :cause}
;; — a real jolt-hash-map, so the ex-data/ex-message/ex-cause tier fns read it
;; via jolt-get for free. Arity 2 (msg data) or 3 (msg data cause).
@ -408,3 +414,7 @@
;; printing. Loads LAST so its set!-wraps of jolt-class/jolt=2/the printers sit
;; outermost over every earlier extension.
(load "host/chez/java/bigdec.ss")
;; Native stack traces: jv$ns$name -> source registry + continuation frame walk +
;; uncaught-throwable renderer. After the printers/equality it relies on.
(load "host/chez/source-registry.ss")

142
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

7
host/chez/seq.ss
View file

@ -154,7 +154,12 @@
=> (lambda (m) (apply jolt-invoke m f args)))
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
=> (lambda (m) (apply jolt-invoke m f args)))
(else (error 'invoke "not a fn" f))))
;; calling a non-fn: a ClassCastException naming the operator, thrown via
;; jolt-throw so it is catchable and carries the throw-site continuation for a
;; stack trace.
(else (jolt-throw (jolt-host-throwable "java.lang.ClassCastException"
(string-append (guard (e (#t "value")) (jolt-pr-str f))
" cannot be cast to clojure.lang.IFn"))))))
;; ============================================================================
;; map / filter / reduce / into / remove + range / take / concat / apply

128
host/chez/source-registry.ss Normal file
View file

@ -0,0 +1,128 @@
;; 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.
(define (jolt-error-continuation v)
(let ((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)))))))
;; 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.
(define srcreg-debug? (getenv "JOLT_DEBUG_FRAMES"))
(define (jolt-frame-records k)
(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))))
(when (and srcreg-debug? nm)
(display (string-append " [frame] " nm (if src " *MAPPED*" "") "\n")
(current-error-port)))
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
(if src (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.
(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)))))))
;; 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 v port)
(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))))

13
jolt-core/jolt/analyzer.clj
View file

@ -613,7 +613,12 @@
;; macro `def`/`and`/`or` (clojure.spec.alpha) keeps the special form `def`.
(and (form-sym? head) (not shadowed)
(not (contains? handled hname)) (form-macro? ctx head))
(analyze ctx (form-expand-1 ctx form) env)
;; defn/defn- expand to (def name (fn …)); carry the ORIGINAL form's
;; source offset onto the resulting def, since the macro builds a fresh
;; (def …) with no metadata. So the back end can register fn defs.
(let [node (analyze ctx (form-expand-1 ctx form) env)
p (form-position form)]
(if (and p (= :def (:op node))) (assoc node :pos p) node))
;; jolt.ffi/__cfn — the foreign-function special form (always emitted
;; fully-qualified by the jolt.ffi/foreign-fn macro, so aliases resolve).
(and (form-sym? head) (= "jolt.ffi" (form-sym-ns head))
@ -628,7 +633,11 @@
;; `if` does not change the meaning of (if …) in operator position, per
;; spec §3 and the reference. No (not shadowed) guard here.
(and hname (contains? handled hname))
(analyze-special ctx hname items env)
;; stamp the form's source offset onto a top-level def so the back end
;; can register it (jv$ns$name -> source) for native stack traces.
(let [node (analyze-special ctx hname items env)
p (form-position form)]
(if (and p (= :def (:op node))) (assoc node :pos p) node))
(and hname (not shadowed) (method-head? hname))
(analyze-host-call ctx hname items env)
;; (Class. args*) — trailing-dot constructor sugar.

19
jolt-core/jolt/backend_scheme.clj
View file

@ -674,14 +674,25 @@
(str "(begin " (str/join " " (map emit-top-form (:statements node)))
(if (empty? (:statements node)) "" " ") (emit-top-form (:ret node)) ")")
(and (= :def (:op node)) (not (:no-init node)) (not (dl-opt-out? (:meta node))))
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)]
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)
fn? (= :fn (:op (:init node)))
;; A named fn def gets a source-registry entry so a native backtrace can
;; map its frame to ns/name (file:line). Chez names a frame by the fn's
;; SHORT self-binding (emit-fn's letrec name = munge-name), not jv$ns$name,
;; so register under that. Non-fn defs are not procedures.
pos (:pos node)
reg (when (and fn? pos)
(str " (jolt-register-source! " (chez-str-lit (munge-name nm)) " "
(chez-str-lit ns) " " (chez-str-lit nm) " "
(if (get pos :file) (chez-str-lit (get pos :file)) "jolt-nil") " "
(or (get pos :line) 0) ")"))]
;; register before emitting the init so a self-referential body direct-links.
(swap! direct-link-defined conj (dl-fqn ns nm))
(when (= :fn (:op (:init node))) (swap! direct-link-fns conj (dl-fqn ns nm)))
(when fn? (swap! direct-link-fns conj (dl-fqn ns nm)))
(let [init (emit (:init node))]
(if (jmeta-nonempty? (:meta node))
(str "(begin (define " b " " init ") (def-var-with-meta! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) "))")
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) ")" (or reg "") ")")
(str "(begin (define " b " " init ") (def-var! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b "))"))))
(chez-str-lit ns) " " (chez-str-lit nm) " " b ")" (or reg "") ")"))))
:else (emit node)))

4
test/chez/build-app/src/app/core.clj
View file

@ -12,6 +12,10 @@
(defmethod greet :soft [_] "greet:soft")
(defn -main [& args]
;; --boom: throw through a two-deep call chain so build-smoke can assert the
;; native stack trace. Off the normal path, so default output is unchanged.
(when (= (first args) "--boom")
(util/mid-boom "not-a-number"))
;; the resource is baked into the binary (deps.edn :jolt/build :embed), so this
;; resolves with no resources/ dir on disk, run from any cwd.
(println (slurp (io/resource "greeting.txt")))

9
test/chez/build-app/src/app/util.clj
View file

@ -4,6 +4,15 @@
(defn shout [s]
(str/upper-case (str s "!")))
;; A two-deep non-tail call chain that throws — exercises native stack traces in a
;; direct-link build (build-smoke runs -main with a --boom sentinel arg).
(defn deep-boom [x]
(assert (number? x) "needs a number")
(* x 2))
(defn mid-boom [x]
(inc (deep-boom x)))
(defmacro twice [x]
`(do ~x ~x))

2
test/chez/corpus.edn
View file

@ -611,6 +611,8 @@
{:suite "host-interop / class tokens & readers" :label "indexOf int needle is a char code" :expected "1" :actual "(.indexOf \"a=b\" 61)"}
{:suite "host-interop / exception + HashMap shims" :label "getMessage on a thrown string" :expected "\"class java.lang.String cannot be cast to class java.lang.Throwable (java.lang.String and java.lang.Throwable are in module java.base of loader 'bootstrap')\"" :actual "(try (throw \"boom\") (catch Throwable e (.getMessage e)))"}
{:suite "host-interop / exception + HashMap shims" :label "getMessage on ex-info" :expected "\"bad\"" :actual "(try (throw (ex-info \"bad\" {})) (catch Throwable e (.getMessage e)))"}
{:suite "host-interop / exception + HashMap shims" :label "calling a non-fn throws ClassCastException" :expected ":ccx" :actual "(try (1 2) (catch ClassCastException _ :ccx))"}
{:suite "host-interop / exception + HashMap shims" :label "non-fn cast is a RuntimeException too" :expected ":rt" :actual "(try ((identity 5)) (catch RuntimeException _ :rt))"}
{:suite "host-interop / exception + HashMap shims" :label "HashMap get" :expected "2" :actual "(let [m (HashMap. {:a 1 :b 2})] (.get m :b))"}
{:suite "host-interop / exception + HashMap shims" :label "HashMap put + size" :expected "2" :actual "(let [m (HashMap. {})] (.put m :x 1) (.put m :y 2) (.size m))"}
{:suite "host-interop / reader-feature toggle" :label "features default to jolt+default" :expected "true" :actual "(contains? (set (__reader-features)) \"jolt\")"}