diff --git a/host/chez/dyn-binding.ss b/host/chez/dyn-binding.ss new file mode 100644 index 0000000..7a9a470 --- /dev/null +++ b/host/chez/dyn-binding.ss @@ -0,0 +1,139 @@ +;; dynamic var binding (jolt-2o7x, Phase 2) — binding / with-bindings* / var-set / +;; thread-bound? / with-local-vars / with-redefs / bound-fn* / get-thread-bindings. +;; +;; A per-thread dynamic-binding stack: a list of frames, innermost (most recently +;; pushed) at the HEAD. Each frame is an alist of (var-cell . value) MUTABLE pairs +;; — so var-set can update the innermost binding in place (set-cdr!), matching +;; Clojure where var-set targets the current binding, not the root. +;; +;; The binding macro builds a frame as a jolt map (array-map of (var x) -> value); +;; push-thread-bindings folds it into the alist. Lookups walk frames by cell +;; IDENTITY (eq?) — vars are interned, so (var x) always yields the same cell, and +;; this sidesteps the seed's persistent-hash-map-can't-find-a-var-key quirk. +;; +;; var reads (var-deref in compiled code, jolt-var-get / deref on a cell) consult +;; the stack before falling back to the cell root. Loaded LAST (after vars.ss and +;; ns.ss) so it chains the fully-extended jolt-var-get and overrides rt.ss var-deref. + +(define dyn-binding-stack '()) + +;; find the innermost (cell . value) pair binding CELL, or #f. +(define (dyn-find-binding cell) + (let loop ((frames dyn-binding-stack)) + (and (pair? frames) + (or (assq cell (car frames)) + (loop (cdr frames)))))) + +;; a unique sentinel: distinguishes "no thread binding" from a binding whose +;; value happens to be jolt-nil. +(define dyn-no-binding (list 'no-binding)) +(define (dyn-binding-value cell) + (if (pair? dyn-binding-stack) + (let ((p (dyn-find-binding cell))) + (if p + (let ((val (cdr p))) + (if (var-cell? val) (jolt-var-get val) val)) ; nested var deref (Clojure) + dyn-no-binding)) + dyn-no-binding)) + +;; push-thread-bindings: frame is a jolt map of var-cell -> value. Fold it into an +;; identity-keyed alist of mutable pairs and push. +(define (jolt-push-thread-bindings frame) + (set! dyn-binding-stack + (cons (pmap-fold frame (lambda (k v acc) (cons (cons k v) acc)) '()) + dyn-binding-stack)) + jolt-nil) + +(define (jolt-pop-thread-bindings) + (when (pair? dyn-binding-stack) + (set! dyn-binding-stack (cdr dyn-binding-stack))) + jolt-nil) + +;; get-thread-bindings: a jolt map of every currently-bound cell -> value, +;; innermost wins. Merge oldest-frame-first (the stack head is innermost). The +;; result can be re-pushed by with-bindings* / bound-fn*. +(define (jolt-get-thread-bindings) + (let loop ((frames (reverse dyn-binding-stack)) (m (jolt-hash-map))) + (if (null? frames) + m + (loop (cdr frames) + (let frame-loop ((alist (car frames)) (m m)) + (if (null? alist) + m + (frame-loop (cdr alist) + (pmap-assoc m (caar alist) (cdar alist))))))))) + +;; __thread-bound? — single var; true iff it has a thread binding. +(define (jolt-thread-bound? v) + (and (var-cell? v) (dyn-find-binding v) #t)) + +;; var-set: update the innermost frame that binds v (in place); else set the root. +(define (jolt-var-set v val) + (if (var-cell? v) + (let ((p (dyn-find-binding v))) + (if p + (begin (set-cdr! p val) val) + (begin (var-cell-root-set! v val) (var-cell-defined?-set! v #t) val))) + (error #f "var-set: not a var" v))) + +;; alter-var-root: atomically apply f to the current root plus args. +(define (jolt-alter-var-root v f . args) + (let ((new (apply jolt-invoke f (var-cell-root v) args))) + (var-cell-root-set! v new) + (var-cell-defined?-set! v #t) + new)) + +;; __local-var: a fresh free-standing var cell (not interned). with-local-vars +;; binds these as lexical locals; var-get/var-set read/write the root. Each gets a +;; unique name so two locals never compare/hash equal as map keys. +(define local-var-counter 0) +(define (jolt-local-var . args) + (set! local-var-counter (fx+ local-var-counter 1)) + (make-var-cell "" (string-append "local-" (number->string local-var-counter)) + (if (pair? args) (car args) jolt-nil) + #t)) + +;; --- chain the var-read paths onto the binding stack ------------------------- + +;; var-deref (rt.ss): the compiled-code read path for every clojure.core var +;; reference. Consult the stack first; fall straight back to the root (NOT through +;; jolt-var-get's unbound-error path) so undefined-var reads keep prior behaviour. +(define %dyn-rt-var-deref var-deref) +(set! var-deref + (lambda (ns name) + (let ((cell (jolt-var ns name))) + (let ((bv (dyn-binding-value cell))) + (if (eq? bv dyn-no-binding) (var-cell-root cell) bv))))) + +;; jolt-var-get (vars.ss): the var-get fn + deref/@ on a cell. Stack first, then +;; the original (which errors on an unbound root, matching Clojure). +(define %dyn-var-get jolt-var-get) +(set! jolt-var-get + (lambda (v) + (if (var-cell? v) + (let ((bv (dyn-binding-value v))) + (if (eq? bv dyn-no-binding) (%dyn-var-get v) bv)) + (%dyn-var-get v)))) + +;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares +;; ns/name) — stable under root mutation, so a var works as a map key (with-redefs +;; builds (hash-map (var f) v); get-thread-bindings returns a var-keyed map). +(define %dyn-hash jolt-hash) +(set! jolt-hash + (lambda (x) + (if (var-cell? x) + (equal-hash (cons (var-cell-ns x) (var-cell-name x))) + (%dyn-hash x)))) + +;; --- bind the host seams the overlay references ----------------------------- +(def-var! "clojure.core" "push-thread-bindings" jolt-push-thread-bindings) +(def-var! "clojure.core" "pop-thread-bindings" jolt-pop-thread-bindings) +(def-var! "clojure.core" "get-thread-bindings" jolt-get-thread-bindings) +(def-var! "clojure.core" "__thread-bound?" jolt-thread-bound?) +(def-var! "clojure.core" "var-set" jolt-var-set) +(def-var! "clojure.core" "alter-var-root" jolt-alter-var-root) +(def-var! "clojure.core" "__local-var" jolt-local-var) +;; re-assert var-get / deref to the new (stack-aware) closures (vars.ss captured +;; the pre-chain values). +(def-var! "clojure.core" "var-get" jolt-var-get) +(def-var! "clojure.core" "deref" jolt-deref) diff --git a/host/chez/lazy-bridge.ss b/host/chez/lazy-bridge.ss index 48e32a2..0510b42 100644 --- a/host/chez/lazy-bridge.ss +++ b/host/chez/lazy-bridge.ss @@ -74,5 +74,14 @@ (define %ls-str-render-one jolt-str-render-one) (set! jolt-str-render-one (lambda (x) (if (jolt-lazyseq? x) (%ls-str-render-one (jolt-seq x)) (%ls-str-render-one x)))) +;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq +;; record). Unlike the native-op dispatchers above (called via a direct top-level +;; reference, so the set! is enough), seq? is reached through var-deref, which +;; reads the var-cell root — so the patched closure must be re-def-var!'d, not just +;; set!. (Exposed once dynamic binding let with-in-str/line-seq reach seq?.) +(define %ls-seq? jolt-seq?) +(set! jolt-seq? (lambda (x) (or (jolt-lazyseq? x) (%ls-seq? x)))) +(def-var! "clojure.core" "seq?" jolt-seq?) + (def-var! "clojure.core" "make-lazy-seq" jolt-make-lazy-seq) (def-var! "clojure.core" "coll->cells" jolt-coll->cells) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index c158ddc..00ac8ff 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -258,3 +258,10 @@ ;; var-cell + var-cell-defined?, jolt-symbol/jolt-hash-map/jolt-assoc, chez-current-ns ;; (multimethods.ss), list->cseq (seq.ss), and the fully-patched printers (vars.ss). (load "host/chez/ns.ss") + +;; dynamic var binding (jolt-2o7x, Phase 2): the per-thread binding stack + +;; push/pop/get-thread-bindings/__thread-bound?/var-set/alter-var-root/__local-var. +;; Chains var-deref (rt.ss) and jolt-var-get (vars.ss) onto the stack, so a `binding` +;; frame is seen by every var read. Loaded LAST: needs the fully-extended var-read +;; paths + jolt-hash-map/pmap-fold/pmap-assoc (collections.ss). +(load "host/chez/dyn-binding.ss") diff --git a/test/chez/_dynbind.janet b/test/chez/_dynbind.janet new file mode 100644 index 0000000..96d05b3 --- /dev/null +++ b/test/chez/_dynbind.janet @@ -0,0 +1,77 @@ +# jolt-2o7x — dynamic var binding (binding / with-bindings* / var-set / +# thread-bound? / with-local-vars / with-redefs / bound-fn* / get-thread-bindings). +# Expectations are the JVM-canonical build/jolt values. TDD harness: bin/jolt-chez +# -e per case, last non-empty line == expected. +# +# janet test/chez/_dynbind.janet +(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/jolt-chez")) + +(def cases + [# --- binding: install / restore / seen across a fn call --- + ["binding rebinds" "(do (def ^:dynamic *bx* 10) (binding [*bx* 99] *bx*))" "99"] + ["binding restores" "(do (def ^:dynamic *by* 10) (binding [*by* 99] *by*) *by*)" "10"] + ["binding seen by fn" "(do (def ^:dynamic *bz* 0) (defn rdz [] *bz*) (binding [*bz* 7] (rdz)))" "7"] + ["binding both: vec" "(do (def ^:dynamic *bv* 1) [(binding [*bv* 2] *bv*) *bv*])" "[2 1]"] + ["nested binding" "(do (def ^:dynamic *bn* 1) (binding [*bn* 2] (binding [*bn* 3] *bn*)))" "3"] + ["nested binding outer" "(do (def ^:dynamic *bo* 1) (binding [*bo* 2] (binding [*bo* 3] nil) *bo*))" "2"] + # (a macro reading a dynamic var — corpus 606/607 — needs top-level defmacro + # in the -e path, which the Chez driver can't compile yet; out of scope here.) + + # --- var-set inside a binding targets the frame; restored on exit --- + ["var-set in binding" "(do (def ^:dynamic *z* 1) (binding [*z* 0] (var-set (var *z*) 5) *z*))" "5"] + ["var-set frame restores" "(do (def ^:dynamic *zr* 1) (binding [*zr* 0] (var-set (var *zr*) 5)) *zr*)" "1"] + + # --- thread-bound? --- + ["thread-bound? unbound" "(do (def ^:dynamic *tb* 1) (thread-bound? (var *tb*)))" "false"] + ["thread-bound? in scope" "(do (def ^:dynamic *tc* 1) (binding [*tc* 2] (thread-bound? (var *tc*))))" "true"] + + # --- with-bindings* / bound-fn* / get-thread-bindings --- + # NOTE: build/jolt (the seed) returns 1 here — its persistent-hash-map can't + # find a var key, which is why the seed's `binding` macro uses array-map. On + # Chez array-map IS hash-map and frames look up by cell identity, so this is + # the correct Clojure value 7 (a place Chez is more correct than the seed). + ["with-bindings*" "(do (def ^:dynamic *wb* 1) (with-bindings* {(var *wb*) 7} (fn [] *wb*)))" "7"] + ["bound-fn* conveys" "(do (def ^:dynamic *cf* 1) (let [g (binding [*cf* 3] (bound-fn* (fn [] *cf*)))] (g)))" "3"] + ["get-thread-bindings" "(do (def ^:dynamic *gb* 1) (binding [*gb* 9] (get (get-thread-bindings) (var *gb*))))" "9"] + + # --- with-local-vars --- + ["local-var get" "(with-local-vars [x 1] (var-get x))" "1"] + ["local-var set" "(with-local-vars [x 1] (var-set x 2) (var-get x))" "2"] + ["local-var two" "(with-local-vars [a 1 b 2] [(var-get a) (var-get b)])" "[1 2]"] + ["local-var as value" "(with-local-vars [x 0] (let [bump (fn [v] (var-set v (+ 5 (var-get v))))] (bump x) (var-get x)))" "5"] + ["local-var init outer" "(let [y 3] (with-local-vars [x y] (var-get x)))" "3"] + ["local-var body result" "(with-local-vars [x 1] :done)" ":done"] + + # --- with-redefs --- + ["with-redefs rebinds" "(do (defn wrf [] 1) (with-redefs [wrf (fn [] 42)] (wrf)))" "42"] + ["with-redefs restores" "(do (defn wrg [] 1) (with-redefs [wrg (fn [] 42)]) (wrg))" "1"] + ["with-redefs on throw" "(do (defn wrh [] 1) (try (with-redefs [wrh (fn [] 42)] (throw (ex-info \"x\" {}))) (catch :default e nil)) (wrh))" "1"] + ["with-redefs-fn" "(do (defn wri [] 1) (with-redefs-fn {(var wri) (fn [] 42)} (fn [] (wri))))" "42"] + + # --- alter-var-root --- + ["alter-var-root" "(do (def av 1) (alter-var-root (var av) inc) av)" "2"]]) + +(defn run-capture [expr] + (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) + (def out (ev/read (proc :out) 0x100000)) + (def err (ev/read (proc :err) 0x100000)) + (def code (os/proc-wait proc)) + (def lines (filter (fn [l] (not (empty? l))) + (string/split "\n" (string/trim (if out (string out) ""))))) + [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) + +(var pass 0) +(def fails @[]) +(each [label expr expected] cases + (def [code got err] (run-capture expr)) + (cond + (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) + (= got expected) (++ pass) + (array/push fails [label (string "want `" expected "`, got `" got "`")]))) + +(printf "\n_dynbind parity [%s]: %d/%d passed" jolt-bin pass (length cases)) +(when (> (length fails) 0) + (printf "%d FAIL(s):" (length fails)) + (each [l m] fails (printf " FAIL [%s] %s" l m))) +(flush) +(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index c59ea58..e93aa9a 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -188,8 +188,13 @@ # jolt-zikh (var def-time metadata — :def emit passes reader meta to # def-var-with-meta!; (meta (var v)) is {:ns :name} + ^:private/^Type tag/ # docstring) 1972. +# jolt-2o7x (dynamic var binding — the per-thread binding stack + +# binding/with-bindings*/var-set/thread-bound?/with-local-vars/with-redefs/ +# bound-fn*/get-thread-bindings/alter-var-root; var-deref + jolt-var-get chained +# onto the stack. Also fixed seq? to recognize a lazy-seq, which unblocked +# with-in-str/line-seq) 2000. # Strided runs scale down. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "1972"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2000"))) (def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged)))