Compare commits

...

10 commits
v0.1.3 ... main

Author SHA1 Message Date
0598f8e7c5 Allowed the boot script to check multiple names for the chez executable.
Some checks failed
tests / test (push) Has been cancelled
2026-07-06 17:09:51 +01:00
Dmitri Sotnikov
855fbc4794
Merge pull request #306 from jolt-lang/trace-source-lines
JOLT_TRACE: map tail-frame history to ns/name (file:line)
2026-07-04 21:20:16 +00:00
Yogthos
6c88198115 JOLT_TRACE: map tail-frame history to ns/name (file:line)
The eval path recorded only a frame's munged name, so a JOLT_TRACE backtrace was
a list of bare names. Register source for a runtime-compiled fn def when tracing
is on (keyed by the same munged name the entry push records), reusing the
source-registry the renderer already maps to "ns/name (file:line)". Direct-link
builds already registered via emit-def-cached; this covers the open-world eval
path. trace-off output is byte-identical (returns "" — seed mint / `jolt build`
unchanged), seed re-minted. A name shared across namespaces (e.g. -main) stays
bare, the existing ambiguity guard.

smoke asserts a file-backed project run maps a frame to ns/name (file:line).
2026-07-04 17:09:44 -04:00
Dmitri Sotnikov
e297a74501
Merge pull request #305 from jolt-lang/fix-jolt-trace-aot-binary
JOLT_TRACE: honor the env at runtime in a built joltc
2026-07-04 20:51:03 +00:00
Yogthos
c8167e1c05 JOLT_TRACE: honor the env at runtime in a built joltc
The JOLT_TRACE opt-in was a top-level form in compile-eval.ss, so in a
self-contained joltc it ran at heap-build time — where JOLT_TRACE is always
unset — and never at runtime. `JOLT_TRACE=1 joltc -M:run` therefore produced no
trace from the distributed binary (it worked only under the source-loaded dev
launcher). REPL/nREPL tracing was unaffected (those enable at runtime).

Make it a jolt-trace-init-from-env! fn called from the runtime entrypoints — the
cli.ss dispatch and the built-joltc launcher — before any app namespace compiles,
so the app's own code is traced. While here, drop a redundant trace print in the
joltc launcher (jolt-report-throwable already emits it) that double-printed the
block once tracing actually produced one.

joltc-selfbuild-smoke asserts JOLT_TRACE=1 through the built binary yields exactly
one tail-frame trace.
2026-07-04 16:40:14 -04:00
Dmitri Sotnikov
bff1c288b0
Merge pull request #304 from jolt-lang/tail-frame-history
Recover TCO-elided frames in uncaught-error stack traces
2026-07-04 20:01:51 +00:00
Yogthos
94d3bcca20 AOT: run -main with *ns* = user, matching clojure.main
A built binary loaded each namespace with (set-chez-ns! <ns>) and no restore, so
-main ran with *ns* left at the entry ns. clojure.main (and interpreted joltc)
run -main with *ns* = user, where a runtime (resolve 'alias/sym) is nil because
the alias lives in the entry ns, not user. Reset the current ns to user in the
launcher before -main so a compiled binary matches. build-smoke asserts it via a
separate two-namespace app (kept apart from the tree-shake app — a `resolve`
defeats tree-shaking).
2026-07-04 15:51:13 -04:00
Yogthos
79002526bb JOLT_TRACE: one case-insensitive off-check for both enable paths
Review turned up that the disable vocabulary was the exact lowercase strings
"0"/"false"/"no", so JOLT_TRACE=off (or FALSE, No, n) fell through and ENABLED
tracing — the opposite of intent — and the whole-run and dev-mode checks
disagreed on the empty string. Fold both into one jolt-trace-env-off? predicate
(case-insensitive, incl. off/n); empty/unset carries no signal (dev still traces,
a whole run still doesn't).
2026-07-04 15:51:13 -04:00
Yogthos
7167af4830 Trace by default in REPL-driven development
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.
2026-07-04 15:23:17 -04:00
Yogthos
a3e2365217 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.
2026-07-04 15:00:52 -04:00
16 changed files with 707 additions and 187 deletions

View file

@ -14,7 +14,28 @@
# JOLT_PWD. # JOLT_PWD.
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)" root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
export JOLT_PWD="${JOLT_PWD:-$PWD}" export JOLT_PWD="${JOLT_PWD:-$PWD}"
# Identify the Chez Scheme executable
while read -r CHEZ
do
if [ `which ${CHEZ}` ]
then
break;
fi
done <<EOF
chez
chezscheme
EOF
# If we failed to find one, whinge and exit.
if [ ! `which ${CHEZ}` ]
then
echo "No valid Chez Scheme executable found: please install Chez Scheme."
exit 1
fi
# Version for --version / banners: git describe of this checkout, else "dev". # Version for --version / banners: git describe of this checkout, else "dev".
export JOLT_VERSION="${JOLT_VERSION:-$(git -C "$root" describe --tags --always --dirty 2>/dev/null || echo dev)}" export JOLT_VERSION="${JOLT_VERSION:-$(git -C "$root" describe --tags --always --dirty 2>/dev/null || echo dev)}"
cd "$root" || exit 1 cd "$root" || exit 1
exec chez --script host/chez/cli.ss "$@" exec ${CHEZ} --script host/chez/cli.ss "$@"

View file

@ -182,6 +182,30 @@ a root, transitively.
- Source only; compiled `.class` files in a git dep are ignored. - Source only; compiled `.class` files in a git dep are ignored.
- git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one). - git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one).
## Stack traces
An uncaught error prints the message, the top-level source location, and — when
frames are available — a `trace:` backtrace. In an AOT `jolt build --direct-link`
binary the frames map to `ns/name (file:line)`; on the runtime eval path they are
the surviving fn names. Tail-call optimization erases tail-called frames, so the
default trace shows only the non-tail spine.
A fuller **tail-frame history** recovers the frames TCO erases: each compiled fn
records itself on entry into a bounded ring-of-rings buffer, so the trace shows
TCO-elided frames (including the immediate error site) while a tight tail loop
stays bounded and its non-tail caller context is preserved.
It is **on by default in REPL-driven development** — a `repl` or nREPL session
turns it on, so an error in code you evaluate or reload shows a tail-frame trace
with no setup. Because the recording is baked in at compile time, only code
compiled while a session is live is traced; reload a namespace to trace code that
was already loaded (e.g. an app's initial `-M:run` load before its nREPL started).
Elsewhere it is off (a small per-call cost, and never emitted into a `jolt build`
binary). Override with the environment: `JOLT_TRACE=1` forces it on for a whole
run — including a plain `-M:run`, so the app's own load is traced — and
`JOLT_TRACE=0` forces it off, even in a REPL/nREPL session.
## Conformance ## Conformance
The known-working libraries (see [libraries.md](libraries.md)) and the The known-working libraries (see [libraries.md](libraries.md)) and the

View file

@ -145,11 +145,10 @@
(scheme-start (scheme-start
(lambda args (lambda args
(set-source-roots! (list \"jolt-core\" \"stdlib\")) (set-source-roots! (list \"jolt-core\" \"stdlib\"))
(guard (v (#t (jolt-report-throwable v (current-error-port)) ;; JOLT_TRACE at RUNTIME (the env is unset at heap-build), before any app ns
(let ((bt (jolt-backtrace-string v))) ;; compiles, so a `-M:run` traces the app's own code.
(when bt (display \" trace:\\n\" (current-error-port)) (jolt-trace-init-from-env!)
(display bt (current-error-port)))) (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))
(exit 1)))
(cond (cond
((and (= (length args) 2) (string=? (car args) \"-e\")) ((and (= (length args) 2) (string=? (car args) \"-e\"))
(let ((result (jolt-final-str (let ((result (jolt-final-str

View file

@ -94,6 +94,28 @@ for frame in 'app.util/deep-boom' 'app.util/mid-boom' 'app.core/-main'; do
exit 1 exit 1
fi fi
done done
# A built binary runs -main with *ns* = user, like clojure.main — so a runtime
# resolve of an aliased symbol is nil (the alias lives in the entry ns, not user),
# matching the JVM and interpreted joltc rather than the entry ns's alias table. A
# separate app: `resolve` defeats tree-shaking, so keep it out of the shake test's
# app above.
nsp="$(dirname "$out")/nsparity"
mkdir -p "$nsp/src/nsp"
printf '{:paths ["src"]}\n' > "$nsp/deps.edn"
printf '(ns nsp.lib)\n(defn thing [] 1)\n' > "$nsp/src/nsp/lib.clj"
printf '(ns nsp.main (:require [nsp.lib :as l]))\n(defn -main [& _]\n (println "ns:" (str *ns*))\n (println "resolve:" (pr-str (resolve (quote l/thing))))\n (println "ns-resolve:" (pr-str (ns-resolve (quote nsp.lib) (quote thing)))))\n' > "$nsp/src/nsp/main.clj"
nspout="$(dirname "$out")/nsparity-bin"
if ! JOLT_PWD="$nsp" bin/joltc build -m nsp.main -o "$nspout" >/dev/null 2>&1; then
echo " FAIL: jolt build of the ns-parity app exited non-zero"; exit 1
fi
nsp_out="$(cd / && "$nspout" 2>&1)"
if ! printf '%s' "$nsp_out" | grep -q 'ns: user' \
|| ! printf '%s' "$nsp_out" | grep -q '^resolve: nil' \
|| ! printf '%s' "$nsp_out" | grep -q "ns-resolve: #'nsp.lib/thing"; then
echo " FAIL: built binary -main ns parity — want 'ns: user', 'resolve: nil', ns-resolve found"
echo "--- got ----"; echo "$nsp_out"
exit 1
fi
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro, # Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
# expanded at AOT and never called at runtime) is dropped. # 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 if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then

View file

@ -580,6 +580,12 @@
;; render an uncaught throw (+ Clojure backtrace) instead ;; render an uncaught throw (+ Clojure backtrace) instead
;; of Chez's opaque dump, then exit non-zero. ;; of Chez's opaque dump, then exit non-zero.
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n" " (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n"
;; Loading the app left the current ns at the entry ns; reset
;; it to `user` before -main, matching clojure.main (*ns* is
;; `user` when a `-m` -main runs, so a runtime resolve of an
;; aliased symbol behaves the same as on the JVM / interpreted
;; joltc, not off the entry ns's alias table).
" (set-chez-ns! \"user\")\n"
" (when (and maincell (var-cell-defined? maincell))\n" " (when (and maincell (var-cell-defined? maincell))\n"
" (apply jolt-invoke (var-cell-root maincell) args))))\n" " (apply jolt-invoke (var-cell-root maincell) args))))\n"
" (exit 0)))\n")) " (exit 0)))\n"))

View file

@ -66,6 +66,9 @@
(when bt (display " trace:\n" port) (display bt port))) (when bt (display " trace:\n" port) (display bt port)))
(exit 1))) (exit 1)))
;; JOLT_TRACE opt-in, at runtime (before any app ns compiles) so the app is traced.
(jolt-trace-init-from-env!)
(guard (v (#t (jolt-report-uncaught v))) (guard (v (#t (jolt-report-uncaught v)))
(cond (cond
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in ;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in

View file

@ -110,6 +110,38 @@
;; older seed during the first re-mint pass. ;; older seed during the first re-mint pass.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!"))) (let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #t))) (when (procedure? scv) (scv #t)))
;; JOLT_TRACE is a falsey value (case-insensitive) — the single predicate both the
;; dev-mode enable and the whole-run enable consult, so "off" never accidentally
;; means "on". An empty / unset value is NOT falsey here — it carries no signal, so
;; dev mode still traces and a whole run still doesn't.
(define (jolt-trace-env-off? e)
(and (string? e)
(let ((s (string-downcase e)))
(or (string=? s "0") (string=? s "false") (string=? s "no")
(string=? s "off") (string=? s "n")))))
;; Tail-frame history. Turning it on makes the emitter add a per-fn history push to
;; every fn compiled AFTERWARD, and allocates this thread's ring. Suppressed when
;; JOLT_TRACE is a falsey value, so JOLT_TRACE=0 / off / no disables it in dev mode.
(define (jolt-enable-trace!)
(unless (jolt-trace-env-off? (getenv "JOLT_TRACE"))
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
(when (procedure? stf) (stf #t)))
(jolt-trace-enable!)))
;; Exposed so the REPL / nREPL entrypoints (jolt.main, jolt.nrepl) can turn tracing
;; on for REPL-driven development without the user setting JOLT_TRACE. Because the
;; push is baked in at compile time, only code compiled after this call is traced —
;; which is exactly the code you eval / reload in a live session.
(def-var! "jolt.host" "enable-trace!" jolt-enable-trace!)
;; Explicit opt-in for a whole run (JOLT_TRACE=1): turn tracing on BEFORE any app
;; namespace is compiled, so a plain `-M:run` traces the app's own code too. Called
;; from the runtime entrypoints (cli.ss, and the built joltc launcher) — NOT at load
;; time: a built joltc runs top-level forms at heap-build time, where JOLT_TRACE is
;; always unset, so a load-time check would never see the user's runtime env. Only an
;; affirmative value (set, non-empty, not falsey) forces it on.
(define (jolt-trace-init-from-env!)
(let ((e (getenv "JOLT_TRACE")))
(when (and e (fx>? (string-length e) 0) (not (jolt-trace-env-off? e)))
(jolt-enable-trace!))))
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with ;; (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. ;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
@ -235,6 +267,9 @@
;; record this form's source location first, so a compile- or run-time error ;; record this form's source location first, so a compile- or run-time error
;; in it reports the right place. ;; in it reports the right place.
(jolt-enter-form! form) (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))) (eval (read (open-input-string (jolt-analyze-emit-form form ns)))
(interaction-environment))))) (interaction-environment)))))

View file

@ -46,6 +46,10 @@
;; after it). Guarded for the first re-mint pass off an older seed. ;; after it). Guarded for the first re-mint pass off an older seed.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!"))) (let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #f))) (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?) (define (ei-compile-form ctx f optimize?)
(let ((ir (jolt-ce-analyze ctx f))) (let ((ir (jolt-ce-analyze ctx f)))
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir)))) (jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))

View file

@ -42,6 +42,20 @@ if [ "$got_e" != "45" ]; then
exit 1 exit 1
fi fi
# 2b. JOLT_TRACE must take effect in the BUILT binary. The env check runs at
# runtime (the launcher), NOT at heap-build where JOLT_TRACE is always unset — so
# an uncaught error shows a tail-frame trace recovering the TCO-elided chain, and
# exactly ONE trace block (the launcher must not double-print it).
got_tr="$(env -i HOME="$HOME" JOLT_TRACE=1 "$joltc" -e '(defn a [x] (+ x 1)) (defn b [x] (a x)) (b :x)' 2>&1)"
if ! printf '%s' "$got_tr" | grep -q ' trace:' || ! printf '%s' "$got_tr" | grep -q 'b'; then
echo " FAIL: JOLT_TRACE=1 in the built joltc produced no tail-frame trace"
echo "--- got ---"; echo "$got_tr"; exit 1
fi
if [ "$(printf '%s' "$got_tr" | grep -c ' trace:')" != "1" ]; then
echo " FAIL: built joltc double-printed the trace block"
echo "--- got ---"; echo "$got_tr"; exit 1
fi
# 3. Build an app through the distributed joltc with an EMPTY environment — no # 3. Build an app through the distributed joltc with an EMPTY environment — no
# PATH at all, so no chez, no cc, no shell tools are reachable. This is the core # PATH at all, so no chez, no cc, no shell tools are reachable. This is the core
# guarantee: joltc compiles apps entirely on its own. # guarantee: joltc compiles apps entirely on its own.

View file

@ -60,6 +60,112 @@
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per ;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
;; call; the captured k is walked, never invoked. ;; call; the captured k is walked, never invoked.
(define jolt-throw-cont (make-thread-parameter #f)) (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 (define-condition-type &jolt-throw &condition
make-jolt-throw-condition jolt-throw-condition? make-jolt-throw-condition jolt-throw-condition?
(value jolt-throw-condition-value)) (value jolt-throw-condition-value))

File diff suppressed because one or more lines are too long

View file

@ -30,6 +30,39 @@ check_loc() {
fi 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 '(+ 1 2)' '3'
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610' 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' check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
@ -60,6 +93,53 @@ check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while re
check_loc '(throw (ex-info "boom" {}))' 'boom' check_loc '(throw (ex-info "boom" {}))' 'boom'
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:' 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
# A file-backed project run maps each runtime-compiled frame to ns/name (file:line)
# — the eval path registers source in trace mode, so the trace isn't bare names.
tr_proj="$(mktemp -d)"
mkdir -p "$tr_proj/src/tp"
printf '{:paths ["src"] :aliases {:run {:main-opts ["-m" "tp.core"]}}}\n' > "$tr_proj/deps.edn"
printf '(ns tp.core)\n(defn deep [x] (+ x 1))\n(defn mid [x] (inc (deep x)))\n(defn -main [& _] (mid :nan))\n' > "$tr_proj/src/tp/core.clj"
tr_out="$(JOLT_TRACE=1 JOLT_PWD="$tr_proj" bin/joltc -M:run 2>&1)"
if printf '%s' "$tr_out" | grep -Eq 'tp\.core/deep \(.*/tp/core\.clj:2\)'; then
pass=$((pass + 1))
else
echo " FAIL: JOLT_TRACE trace should map a frame to ns/name (file:line)"
printf '%s\n' "$tr_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
rm -rf "$tr_proj"
# --help prints usage, and lists the nREPL server under its real flag name. # --help prints usage, and lists the nREPL server under its real flag name.
help_out="$(bin/joltc --help 2>/dev/null)" help_out="$(bin/joltc --help 2>/dev/null)"
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
@ -159,5 +239,25 @@ else
fails=$((fails + 1)) fails=$((fails + 1))
fi fi
# REPL-driven development traces by default: an error in an evaluated form shows a
# tail-frame backtrace with no JOLT_TRACE set. rb tail-calls ra tail-calls +, all
# TCO-elided from the continuation — only the history recovers them.
repl_err="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | bin/joltc repl 2>&1)"
if printf '%s' "$repl_err" | grep -q ' trace:' && printf '%s' "$repl_err" | grep -q 'rb'; then
pass=$((pass + 1))
else
echo " FAIL: a REPL error should show a tail-frame trace by default"
printf '%s\n' "$repl_err" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# JOLT_TRACE=0 opts out — no trace in the REPL.
repl_off="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | JOLT_TRACE=0 bin/joltc repl 2>&1)"
if printf '%s' "$repl_off" | grep -q ' trace:'; then
echo " FAIL: JOLT_TRACE=0 should suppress the REPL trace"
fails=$((fails + 1))
else
pass=$((pass + 1))
fi
echo "cli smoke: $pass passed, $fails failed" echo "cli smoke: $pass passed, $fails failed"
[ "$fails" -eq 0 ] [ "$fails" -eq 0 ]

View file

@ -57,10 +57,36 @@
((symbol? nm) (symbol->string nm)) ((symbol? nm) (symbol->string nm))
(else #f))))))) (else #f)))))))
;; Walk a continuation, returning the registered jolt frames (innermost first) as ;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary,
;; (frame-name . record) pairs, where record is #(ns name file line) or the symbol ;; the var-cell trampoline, continuation/winder internals. They carry no Clojure
;; 'ambiguous. Unmapped frames (host spine, anonymous lambdas) are skipped; raw ;; meaning, so an unmapped frame with one of these names is dropped from the trace
;; depth is capped. ;; (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) (define (jolt-frame-records k)
;; read the env at call time, not load time: a built binary runs top-level forms ;; 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. ;; at heap-build time, where this would always be unset.
@ -70,26 +96,32 @@
(if (or (not io) (fx>=? n 400)) (if (or (not io) (fx>=? n 400))
(reverse acc) (reverse acc)
(let* ((nm (srcreg-frame-name io)) (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) (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))) (current-error-port)))
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1) (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 ;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a
;; mapped frame, the bare frame name for an ambiguous one — or #f when no jolt ;; backtrace string. record is a source vector #(ns name file line) -> "ns/name
;; frame maps (the caller then prints just the top-level location). Capped to the ;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same
;; innermost frames. ;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a
(define (jolt-backtrace-string v) ;; loop re-enters), and the number of distinct lines is capped.
(let ((k (jolt-error-continuation v))) (define (jolt-render-recs recs)
(and k
(let ((recs (jolt-frame-records k)))
(and (pair? recs)
(let ((port (open-output-string))) (let ((port (open-output-string)))
(let loop ((rs recs) (shown 0)) (let loop ((rs recs) (shown 0))
(when (and (pair? rs) (fx<? shown 30)) (if (or (null? rs) (fx>=? shown 30))
(get-output-string port)
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p))) (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 " ") (put-string port " ")
(if (vector? r) (if (vector? r)
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1)) (let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
@ -99,10 +131,49 @@
(put-string port " (") (put-string port file) (put-string port " (") (put-string port file)
(put-string port ":") (put-string port (number->string line)) (put-string port ":") (put-string port (number->string line))
(put-string port ")"))) (put-string port ")")))
(put-string port frame-name)) ; 'ambiguous: bare name (put-string port frame-name)) ; 'ambiguous / unmapped: bare name
(put-char port #\newline)) (when (fx>? cnt 1)
(loop (cdr rs) (fx+ shown 1)))) (put-string port " (x") (put-string port (number->string cnt)) (put-string port ")"))
(get-output-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: ;; 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 ;; an ex-info shows its message + ex-data (+ a host cause); anything else is

View file

@ -172,6 +172,14 @@
(def var-cache? (atom false)) (def var-cache? (atom false))
(defn set-var-cache! [on] (reset! var-cache? on)) (defn set-var-cache! [on] (reset! var-cache? on))
;; Opt-in tail-frame history (JOLT_TRACE): emit a (jolt-trace-push! "name") at the
;; head of every named fn body, so an entry records the frame into the runtime ring
;; buffer (rt.ss) and a TCO-elided frame still shows in an error's backtrace. OFF
;; during the seed mint and `jolt build` (byte-determinism + no runtime cost);
;; compile-eval.ss turns it on for runtime-eval'd user code when JOLT_TRACE is set.
(def trace-frames? (atom false))
(defn set-trace-frames! [on] (reset! trace-frames? on))
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier ;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are ;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
;; escaped so distinct vars never collide. ;; escaped so distinct vars never collide.
@ -191,6 +199,13 @@
;; recursion auto-restores them (no manual save/restore, no throw-leak). ;; recursion auto-restores them (no manual save/restore, no throw-leak).
(def ^:dynamic *recur-target* nil) (def ^:dynamic *recur-target* nil)
(def ^:dynamic *known-procs* #{}) (def ^:dynamic *known-procs* #{})
;; True while emitting a node in TAIL position. Only used, in trace mode, to mark a
;; tail call so the runtime routes its callee into the current history rib instead
;; of a new one (rt.ss). It never affects semantics — a wrong value only mislabels
;; a debug trace line — so partial propagation is safe. `emit` (the wrapper below)
;; clears it by default; the tail-transparent forms (fn body, if/do/let/loop) pass
;; it to their tail child. Default false so a top-level form is treated non-tail.
(def ^:dynamic *tail?* false)
(def ^:private gensym-counter (atom 0)) (def ^:private gensym-counter (atom 0))
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc))) (defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
@ -253,6 +268,17 @@
(if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s))) (if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
(declare emit) (declare emit)
(declare emit*)
;; Ops that pass tail position through to a child (the child can itself be a tail
;; call): if/do carry it to their tail branch/last form, let/loop to their body,
;; and invoke reads it to decide whether the call is tail. Every other op's
;; children are non-tail, so `emit` clears *tail?* before dispatching them — that
;; way a stray true can't leak into, say, a call sitting in a vector literal.
(def ^:private tail-transparent-ops #{:if :do :let :loop :invoke})
(defn emit [node]
(if (and *tail?* (not (tail-transparent-ops (:op node))))
(binding [*tail?* false] (emit* node))
(emit* node)))
;; A Chez string literal. Every char outside printable ASCII becomes a ;; A Chez string literal. Every char outside printable ASCII becomes a
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what ;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
@ -413,9 +439,10 @@
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns): ;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*. ;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
(defn- emit-let [node] (defn- emit-let [node]
(let [kw (if (:letrec node) "letrec*" "let*")] (let [kw (if (:letrec node) "letrec*" "let*")
(str "(" kw " (" (str/join " " (map emit-binding (:bindings node))) ") " ;; bindings are non-tail; the body inherits the let's tail position
(emit (:body node)) ")"))) binds (binding [*tail?* false] (str/join " " (mapv emit-binding (:bindings node))))]
(str "(" kw " (" binds ") " (emit (:body node)) ")")))
(defn- emit-loop [node] (defn- emit-loop [node]
(let [label (fresh-label "loop") (let [label (fresh-label "loop")
@ -423,9 +450,10 @@
names (map #(munge-name (nth % 0)) pairs) names (map #(munge-name (nth % 0)) pairs)
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like ;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let. ;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let.
inits (map #(emit (nth % 1)) pairs) inits (binding [*tail?* false] (mapv #(emit (nth % 1)) pairs))
seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits)) seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names)) rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names))
;; the loop body inherits the loop's tail position
body (binding [*recur-target* label] (emit (:body node)))] body (binding [*recur-target* label] (emit (:body node)))]
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))"))) (str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
@ -486,7 +514,11 @@
params (map munge-name orig) params (map munge-name orig)
restp (when-let [r (:rest a)] (munge-name r)) restp (when-let [r (:rest a)] (munge-name r))
label (fresh-label "fnrec") label (fresh-label "fnrec")
body (binding [*recur-target* label] (emit (:body a))) ret (:ret-nhint a)
;; the body is the fn's tail position — UNLESS a ^double/^long return hint
;; wraps it in a coercion below, which puts the body back in non-tail.
body-tail? (not (or (= ret :double) (= ret :long)))
body (binding [*recur-target* label *tail?* body-tail?] (emit (:body a)))
paramlist (cond paramlist (cond
(and restp (empty? params)) restp (and restp (empty? params)) restp
restp (str "(" (str/join " " params) " . " restp ")") restp (str "(" (str/join " " params) " . " restp ")")
@ -511,6 +543,16 @@
self (when-let [nm (:name node)] (munge-name nm)) self (when-let [nm (:name node)] (munge-name nm))
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)] clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
(mapv emit-arity-clause arities)) (mapv emit-arity-clause arities))
;; trace mode: record this frame on entry (before the body), so a frame
;; the body then tail-calls away is still in the ring at throw time. A
;; `recur` re-enters via the named-let, not the lambda, so a tight loop
;; records once, not per iteration.
clauses (if (and @trace-frames? self)
(mapv (fn [c] [(nth c 0)
(str "(begin (jolt-trace-push! " (chez-str-lit self) ") "
(nth c 1) ")")])
clauses)
clauses)
lambda (if (= 1 (count clauses)) lambda (if (= 1 (count clauses))
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")")) (let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
(str "(case-lambda " (str "(case-lambda "
@ -573,7 +615,30 @@
(= (nth shape i) kw) i (= (nth shape i) kw) i
:else (recur (inc i)))))) :else (recur (inc i))))))
;; A plain Scheme application: (callee op ...).
(defn- plain-call [callee operand-strs]
(str "(" callee (if (seq operand-strs) (str " " (str/join " " operand-strs)) "") ")"))
;; A tail call in trace mode. Force-bind the operands to temps FIRST (so any
;; operand whose own evaluation records a trace entry runs before our mark), THEN
;; set the tail mark, THEN apply — the callee's entry prologue consumes the mark
;; with nothing in between, so it can't be clobbered. Still a tail call: the let*'s
;; last form is the application, so TCO is preserved.
(defn- tail-marked-call [callee operand-strs]
(let [tmps (mapv (fn [_] (fresh-label "_tt$")) operand-strs)
binds (str/join " " (map (fn [t a] (str "(" t " " a ")")) tmps operand-strs))]
(str "(let* (" binds ") (jolt-trace-mark! #t) " (plain-call callee tmps) ")")))
;; Emit a call, tail-marked when we're in tail position and tracing is on; a plain
;; application otherwise. The mark is consumed by the callee's entry prologue —
;; direct calls (:local known-proc, direct-link) always have one; a jolt-invoke
;; call usually reaches one but not always (see the best-effort note in rt.ss).
(defn- emit-call [tail? callee operand-strs]
(if (and @trace-frames? tail?)
(tail-marked-call callee operand-strs)
(plain-call callee operand-strs)))
(defn- emit-invoke [node] (defn- emit-invoke [node]
(let [tail? *tail?*] ; capture: children below emit non-tail
(binding [*tail?* false]
(let [fnode (:fn node) (let [fnode (:fn node)
arg-nodes (:args node) arg-nodes (:args node)
args (mapv emit arg-nodes) args (mapv emit arg-nodes)
@ -586,8 +651,7 @@
;; order [callee & args] together when ordering is observable. ;; order [callee & args] together when ordering is observable.
invoke (fn [] invoke (fn []
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args) (ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
(fn [[f & as]] (fn [operands] (emit-call tail? "jolt-invoke" operands))))]
(str "(jolt-invoke " f (if (seq as) (str " " (str/join " " as)) "") ")"))))]
(cond (cond
;; devirtualized protocol call: the inference proved the receiver (arg 0) is ;; devirtualized protocol call: the inference proved the receiver (arg 0) is
;; one record type, so resolve the impl by that static tag instead of routing ;; one record type, so resolve the impl by that static tag instead of routing
@ -662,8 +726,7 @@
;; holds an arbitrary IFn -> dynamic dispatch. ;; holds an arbitrary IFn -> dynamic dispatch.
(= :local (:op fnode)) (= :local (:op fnode))
(if (*known-procs* (munge-name (:name fnode))) (if (*known-procs* (munge-name (:name fnode)))
(order-args (fn [as] (str "(" (munge-name (:name fnode)) (order-args (fn [as] (emit-call tail? (munge-name (:name fnode)) as)))
(if (seq as) (str " " (str/join " " as)) "") ")")))
(invoke)) (invoke))
;; closed-world direct call: the callee var is an app fn def already emitted ;; closed-world direct call: the callee var is an app fn def already emitted
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke. ;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
@ -672,8 +735,7 @@
;; below (which still uses the direct binding as the invoke target). ;; below (which still uses the direct binding as the invoke target).
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode)) (and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
(direct-link-fn? (:ns fnode) (:name fnode))) (direct-link-fn? (:ns fnode) (:name fnode)))
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode)) (order-args (fn [as] (emit-call tail? (dl-name (:ns fnode) (:name fnode)) as)))
(if (seq as) (str " " (str/join " " as)) "") ")")))
;; a late-bound :var call head can hold a procedure OR a non-applicable ;; a late-bound :var call head can hold a procedure OR a non-applicable
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via ;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
;; jolt-invoke (transparent for a procedure). ;; jolt-invoke (transparent for a procedure).
@ -681,7 +743,7 @@
(invoke) (invoke)
;; a computed callee can yield ANY IFn — route through jolt-invoke. ;; a computed callee can yield ANY IFn — route through jolt-invoke.
:else :else
(invoke)))) (invoke))))))
;; try/catch/finally. throw raises a Chez condition wrapping the jolt value ;; try/catch/finally. throw raises a Chez condition wrapping the jolt value
;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to ;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to
@ -728,7 +790,22 @@
(returns-scheme-bool? (:body node) bools')) (returns-scheme-bool? (:body node) bools'))
:else false))) :else false)))
(defn emit [node] ;; In trace mode, a fn def also registers its source so the tail-frame history maps
;; the recorded frame-name to "ns/name (file:line)" instead of a bare name. Keyed by
;; the SAME munged name the entry push records (emit-fn's letrec self-binding = the
;; fn's own name). Returns "" when off / not a positioned fn def, so trace-off output
;; (seed mint, `jolt build`) is byte-identical. Direct-link builds already register
;; via emit-def-cached; this covers the open-world eval path.
(defn- trace-source-reg [node]
(let [init (:init node) pos (:pos node)]
(if (and @trace-frames? (= :fn (:op init)) (:name init) pos)
(str " (jolt-register-source! " (chez-str-lit (munge-name (:name init))) " "
(chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(if (:file pos) (chez-str-lit (:file pos)) "jolt-nil") " "
(or (:line pos) 0) ")")
"")))
(defn emit* [node]
(case (:op node) (case (:op node)
:const (emit-const (:val node)) :const (emit-const (:val node))
:local (munge-name (:name node)) :local (munge-name (:name node))
@ -776,11 +853,14 @@
:host-new (str "(host-new " (chez-str-lit (:class node)) :host-new (str "(host-new " (chez-str-lit (:class node))
(let [args (map emit (:args node))] (let [args (map emit (:args node))]
(if (empty? args) "" (str " " (str/join " " args)))) ")") (if (empty? args) "" (str " " (str/join " " args)))) ")")
;; the test is non-tail; then/else inherit the if's tail position
:if (let [test (:test node) :if (let [test (:test node)
t (if (returns-scheme-bool? test) (emit test) t (binding [*tail?* false]
(str "(jolt-truthy? " (emit test) ")"))] (if (returns-scheme-bool? test) (emit test)
(str "(jolt-truthy? " (emit test) ")")))]
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")")) (str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")"))
:do (str "(begin " (str/join " " (map emit (:statements node))) ;; non-last statements are non-tail; the ret inherits the do's tail position
:do (str "(begin " (binding [*tail?* false] (str/join " " (mapv emit (:statements node))))
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")") (if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
:invoke (emit-invoke node) :invoke (emit-invoke node)
;; collection literals -> rt constructors (collections.ss). Elements are ;; collection literals -> rt constructors (collections.ss). Elements are
@ -824,7 +904,8 @@
:fn (emit-fn node) :fn (emit-fn node)
;; (def name) with no init (declare): reserve the cell. A def with non-empty ;; (def name) with no init (declare): reserve the cell. A def with non-empty
;; reader metadata lowers to def-var-with-meta! (ported in a later increment). ;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
:def (cond :def (let [reg (trace-source-reg node)
d (cond
(:no-init node) (:no-init node)
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")") (str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
(jmeta-nonempty? (:meta node)) (jmeta-nonempty? (:meta node))
@ -832,7 +913,8 @@
(emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")") (emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")")
:else :else
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " " (str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit-with-cells #(emit (:init node))) ")")) (emit-with-cells #(emit (:init node))) ")"))]
(if (= reg "") d (str "(begin " d reg ")")))
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {})))) (throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {}))))
;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable, ;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable,

View file

@ -147,6 +147,9 @@
;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL. ;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL.
(try (apply-project! (deps/resolve-project (project-dir))) (try (apply-project! (deps/resolve-project (project-dir)))
(catch :default _ nil)) (catch :default _ nil))
;; REPL-driven development: trace by default so an uncaught error in evaluated
;; code shows a tail-frame backtrace, no JOLT_TRACE needed (JOLT_TRACE=0 opts out).
(jolt.host/enable-trace!)
(println (str ";; jolt " (version) " repl — :repl/quit or ^D to exit")) (println (str ";; jolt " (version) " repl — :repl/quit or ^D to exit"))
(loop [] (loop []
(let [form (repl-read-form)] (let [form (repl-read-form)]
@ -160,7 +163,9 @@
(catch :default e (catch :default e
(println "error:" (or (ex-message e) (println "error:" (or (ex-message e)
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil)) (try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
(pr-str e))))) (pr-str e)))
(when-let [bt (jolt.host/backtrace-string)]
(print bt))))
(recur))))))) (recur)))))))
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}. ;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.

View file

@ -188,7 +188,10 @@
(try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str))) (try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
(in-ns (symbol ns-str))) (in-ns (symbol ns-str)))
(reset! result (load-string code)) (reset! result (load-string code))
(catch :default e (reset! err (err-msg e)))))] (catch :default e
(reset! err (str (err-msg e)
(when-let [bt (jolt.host/backtrace-string)]
(str "\n" bt)))))))]
{:value (when (nil? @err) (pr-str @result)) {:value (when (nil? @err) (pr-str @result))
:out out :out out
:ns (str (ns-name *ns*)) :ns (str (ns-name *ns*))
@ -277,6 +280,11 @@
no-op." no-op."
([port] (start port nil)) ([port] (start port nil))
([port middleware] ([port middleware]
;; An nREPL session is REPL-driven development: trace by default so an uncaught
;; error in code evaluated over the connection shows a tail-frame backtrace, with
;; no JOLT_TRACE needed. Covers both `--nrepl-server` and an app that starts its
;; own server under `-M:run` (reload a namespace to trace already-loaded code).
(jolt.host/enable-trace!)
(let [handler (build-handler (resolve-middleware (or middleware []))) (let [handler (build-handler (resolve-middleware (or middleware [])))
fd (listen-socket port) ; throws on bind/listen failure fd (listen-socket port) ; throws on bind/listen failure
stopped (atom false)] stopped (atom false)]