From 5c5d2cd1fca2e2e68360e8cdfd51aed06e2e2f19 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Wed, 17 Jun 2026 14:33:57 -0400 Subject: [PATCH] Chez Phase 1 (increment 3a): persistent collections on the Chez RT MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Broaden the Scheme back end past the numeric/functional subset to vectors, maps, and sets. host/chez/collections.ss adds a copy-on-write persistent vector and a bitmap HAMT (the structure 0c measured self-hostable) backing both maps and sets, keyed by jolt-hash and compared by jolt=. emit.janet emits :vector/:map/:set literals to the rt constructors and lowers the leaf ops (conj/get/nth/count/assoc/dissoc/contains?/empty?/peek/pop) via the native-ops path, with a per-op arity gate. Also: keyword/map literals in fn position lower to jolt-get ((:k m), ({:k v} k)); arity-1 comparisons emit the vacuous jolt truth (Scheme < rejects a non-number even at arity 1); count returns a flonum and vector indices coerce from flonum, both consequences of the all-double number model; values.ss = / hash and the rt printer learn collections (maps/sets render in HAMT order, so the probe compares unordered values via =, not printed form). Subset parity 182 -> 433/436 compiled cases (2219/2655 out of subset), 0 new divergences. The 3 known divergences are dynamic IFn dispatch (a keyword/vector held in a local, called as a fn) — deferred to the IFn/protocol increment and allowlisted in the probe. emit-test 31/31, full run-tests green (125 files). --- host/chez/collections.ss | 310 ++++++++++++++++++++++++++++++++ host/chez/emit.janet | 63 ++++++- host/chez/rt.ss | 25 ++- host/chez/values.ss | 3 + test/chez/README.md | 18 +- test/chez/emit-test.janet | 48 +++++ test/chez/run-corpus-chez.janet | 24 ++- 7 files changed, 473 insertions(+), 18 deletions(-) create mode 100644 host/chez/collections.ss diff --git a/host/chez/collections.ss b/host/chez/collections.ss new file mode 100644 index 0000000..14ddfbf --- /dev/null +++ b/host/chez/collections.ss @@ -0,0 +1,310 @@ +;; Phase 1 (jolt-cf1q.2, inc 3a) — persistent collections on the Chez RT. +;; +;; The vector / map / set the emitted programs construct from literals and +;; operate on via the lowered leaf ops (conj/get/nth/count/assoc/...). Loaded by +;; rt.ss after values.ss; jolt=2 / jolt-hash (values.ss) call into the +;; jolt-coll? / jolt-coll=? / jolt-coll-hash hooks defined here (forward refs, +;; resolved at run time — nothing is CALLED during load). +;; +;; Phase note: the persistent vector is a copy-on-write Scheme vector and the +;; map/set are a bitmap HAMT (the structure 0c measured self-hostable). They live +;; in Scheme for the Phase-1 bootstrap; the 0c decision is to SELF-HOST them in +;; Clojure once core is up on Chez (Phase 3 shim shrink). Correctness, not perf, +;; is the Phase-1 gate. + +;; ============================================================================ +;; small immutable-vector helpers (manual; avoid stdlib arg-order ambiguity) +;; ============================================================================ +(define (vec-copy-range v start end) + (let ((out (make-vector (fx- end start)))) + (let loop ((i start)) + (when (fxvector xs))) +(define (pvec-count p) (vector-length (pvec-v p))) +;; jolt models every number as a double, so vector indices arrive as flonums — +;; coerce an integer-valued index to a Scheme fixnum before bounds math. +(define (->idx i) (if (fixnum? i) i (if (flonum? i) (exact (floor i)) i))) +(define (pvec-nth-d p i d) + (let ((v (pvec-v p)) (i (->idx i))) + (if (and (fixnum? i) (fx>=? i 0) (fxidx i))) + (cond ((and (fx>=? i 0) (fx? shift max-shift) (fx=? eh h)) + (make-hcoll h (list (cons ek ev) (cons k v))) + (let ((ei (chunk eh shift)) (ni (chunk h shift))) + (if (fx=? ei ni) + (make-hnode (fxsll 1 ei) (vector (split-leaf (fx+ shift 5) ek ev h k v))) + (let ((eb (fxsll 1 ei)) (nb (fxsll 1 ni))) + (if (fx (b a). We have +;; no list type until inc 3b; a reversed pvec is = to that list (sequential =). +(define (jolt-conj coll . xs) + (if (jolt-nil? coll) + (make-pvec (list->vector (reverse xs))) + (fold-left jolt-conj1 coll xs))) + +(define jolt-get + (case-lambda + ((coll k) (jolt-get coll k jolt-nil)) + ((coll k d) + (cond ((pmap? coll) (pmap-get coll k d)) + ((pset? coll) (if (pset-contains? coll k) k d)) + ((pvec? coll) (pvec-nth-d coll k d)) + ((string? coll) (let ((i (->idx k))) + (if (and (fixnum? i) (fx>=? i 0) (fxidx i))) + (cond ((pvec? coll) (let ((v (pvec-v coll))) + (if (and (fx>=? i 0) (fxidx i))) + (cond ((pvec? coll) (pvec-nth-d coll i d)) + ((string? coll) (if (and (fx>=? i 0) (fxinexact + (cond ((pvec? coll) (pvec-count coll)) + ((pmap? coll) (pmap-cnt coll)) + ((pset? coll) (pset-count coll)) + ((string? coll) (string-length coll)) + ((jolt-nil? coll) 0) + (else (error 'count "uncountable"))))) + +(define (jolt-assoc1 coll k v) + (cond ((pmap? coll) (pmap-assoc coll k v)) + ((pvec? coll) (pvec-assoc coll k v)) + ((jolt-nil? coll) (pmap-assoc empty-pmap k v)) + (else (error 'assoc "unsupported collection")))) +(define (jolt-assoc coll . kvs) + (let loop ((coll coll) (kvs kvs)) + (cond ((null? kvs) coll) + ((null? (cdr kvs)) (error 'assoc "assoc expects an even number of key/vals")) + (else (loop (jolt-assoc1 coll (car kvs) (cadr kvs)) (cddr kvs)))))) + +(define (jolt-dissoc coll . ks) + (cond ((jolt-nil? coll) jolt-nil) + ((pmap? coll) (fold-left pmap-dissoc coll ks)) + (else (error 'dissoc "unsupported collection")))) + +(define (jolt-contains? coll k) + (cond ((pmap? coll) (pmap-contains? coll k)) + ((pset? coll) (pset-contains? coll k)) + ((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx" ">" "<=" "<=" ">=" ">=" "=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not" "min" "min" "max" "max" - "mod" "modulo" "rem" "remainder" "quot" "quotient"}) + "mod" "modulo" "rem" "remainder" "quot" "quotient" + # persistent-collection leaf ops (jolt-wgbz) -> rt prims in collections.ss + "vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set" + "conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count" + "assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?" + "empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop"}) -# Unary ops only legal at arity 1; binary at arity 2. Others (arith/compare) are -# variadic in both Scheme and jolt, so any arity is fine. -(def- unary-ops {"inc" true "dec" true "not" true}) -(def- binary-ops {"mod" true "rem" true "quot" true}) +# Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at +# this arity. Ops absent from the table are variadic (arith/compare/=, the +# collection constructors, conj/assoc/dissoc) and legal at any arity. +(def- op-arity + {"inc" |(= $ 1) "dec" |(= $ 1) "not" |(= $ 1) + "count" |(= $ 1) "empty?" |(= $ 1) "peek" |(= $ 1) "pop" |(= $ 1) + "mod" |(= $ 2) "rem" |(= $ 2) "quot" |(= $ 2) "contains?" |(= $ 2) + "get" |(or (= $ 2) (= $ 3)) "nth" |(or (= $ 2) (= $ 3)) + "assoc" |(and (>= $ 3) (odd? $)) "dissoc" |(>= $ 1) "conj" |(>= $ 1)}) # If fnode is a clojure.core (or host) ref to a native-op primitive, return the # Scheme op string — only at an arity where the Scheme op and the jolt fn agree. @@ -44,10 +54,10 @@ :host (get fnode :name) nil)) (def op (and nm (get native-ops nm))) + (def arity-ok (get op-arity nm)) (cond (nil? op) nil - (and (get unary-ops nm) (not= nargs 1)) nil - (and (get binary-ops nm) (not= nargs 2)) nil + (and arity-ok (not (arity-ok nargs))) nil op)) (var- recur-target nil) @@ -74,6 +84,15 @@ s (string s ".0"))) (string? v) (string/format "%j" v) # quoted+escaped string literal + # keyword literal -> (keyword ns name); ns is everything before the first "/" + (keyword? v) (let [s (string v) idx (string/find "/" s)] + (if (and idx (> idx 0)) + (string "(keyword " (string/format "%j" (string/slice s 0 idx)) " " + (string/format "%j" (string/slice s (inc idx))) ")") + (string "(keyword #f " (string/format "%j" s) ")"))) + # jolt char value {:ch :jolt/type :jolt/char} + (and (struct? v) (= :jolt/char (get v :jolt/type))) + (string "(integer->char " (get v :ch) ")") (errorf "emit-const: unsupported literal %p" v))) (defn- emit-binding [b] @@ -136,16 +155,37 @@ (defn- stdlib-var? [n] (and (= :var (get n :op)) (string/has-prefix? "clojure." (or (get n :ns) "")))) +# jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg +# (so (< :kw) is true), but Scheme's < demands a number even there — special-case. +(def- cmp1-ops {"<" true ">" true "<=" true ">=" true}) + +# IFn dispatch for a LITERAL callee (Clojure's "value as fn"): a keyword looks +# itself up in its arg ((:k m) = (get m :k)); a map/set/vector literal looks up +# its arg ((m :k) = (get m :k)). The general dynamic case — a local/var holding a +# keyword — is runtime IFn dispatch, a later increment, and stays out of subset. +(defn- ifn-kind [fnode] + (case (get fnode :op) + :const (when (keyword? (get fnode :val)) :keyword) + :map :coll :set :coll :vector :coll + nil)) + (defn- emit-invoke [node] (def fnode (nn (get node :fn))) (def args (map emit (vv (get node :args)))) (def nop (native-op fnode (length args))) + (def kind (ifn-kind fnode)) + (def default (if (> (length args) 1) (string " " (in args 1)) "")) (cond # zero-arg + / * : Scheme's identity is the EXACT 0 / 1, but jolt models every # number as a double, so emit the flonum identity to keep (= 0 (+)) true. (and nop (empty? args) (= nop "+")) "0.0" (and nop (empty? args) (= nop "*")) "1.0" + (and nop (= 1 (length args)) (get cmp1-ops nop)) (string "(begin " (first args) " #t)") nop (string "(" nop " " (string/join args " ") ")") + # (:k coll [default]) -> (jolt-get coll :k [default]) + (= kind :keyword) (string "(jolt-get " (first args) " " (emit fnode) default ")") + # (coll k [default]) -> (jolt-get coll k [default]) + (= kind :coll) (string "(jolt-get " (emit fnode) " " (first args) default ")") (stdlib-var? fnode) (errorf "emit: unsupported stdlib fn `%s/%s` (no core on Chez yet)" (get fnode :ns) (get fnode :name)) (= :host (get fnode :op)) @@ -172,6 +212,15 @@ (if (empty? (vv (get node :statements))) "" " ") (emit (get node :ret)) ")") :invoke (emit-invoke node) + # collection literals -> rt constructors (collections.ss) + :vector (string "(jolt-vector " (string/join (map emit (vv (get node :items))) " ") ")") + :set (string "(jolt-hash-set " (string/join (map emit (vv (get node :items))) " ") ")") + :map (let [flat @[]] + (each p (vv (get node :pairs)) + (def p (vv p)) + (array/push flat (emit (get p 0))) + (array/push flat (emit (get p 1)))) + (string "(jolt-hash-map " (string/join flat " ") ")")) :let (emit-let node) :loop (emit-loop node) :recur (emit-recur node) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index 24e136b..655a5e2 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -11,6 +11,7 @@ ;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn. (load "host/chez/values.ss") +(load "host/chez/collections.ss") ;; --- rt arithmetic / logic shims (named in emit.janet's native-ops) ---------- (define (jolt-inc x) (+ x 1)) @@ -41,7 +42,17 @@ (number->string (exact x)) (number->string x))) -;; Minimal pr-str for the program's final value (full printer is Phase 2). +;; Program-final-value printer. jolt's `-e` prints in str-style: strings raw (no +;; quotes), chars as `\c`/`\newline`, collections recursively. NOTE: maps/sets +;; render in HAMT-iteration order, which does NOT match the Janet host's order — +;; so unordered values are compared via `=` (true/false), not printed form. +;; The full canonical printer is Phase 2. +(define (jolt-str-join strs) + (cond ((null? strs) "") ((null? (cdr strs)) (car strs)) + (else (string-append (car strs) " " (jolt-str-join (cdr strs)))))) +(define (jolt-char->string c) + (string-append "\\" (case c ((#\newline) "newline") ((#\space) "space") ((#\tab) "tab") + ((#\return) "return") (else (string c))))) (define (jolt-pr-str x) (cond ((jolt-nil? x) "nil") @@ -49,4 +60,16 @@ ((eq? x #f) "false") ((number? x) (jolt-num->string x)) ((string? x) x) + ((char? x) (jolt-char->string x)) + ((keyword? x) (let ((ns (keyword-t-ns x))) + (if ns (string-append ":" ns "/" (keyword-t-name x)) (string-append ":" (keyword-t-name x))))) + ((jolt-symbol? x) (let ((ns (symbol-t-ns x))) + (if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x) + (string-append ns "/" (symbol-t-name x))))) + ((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1))) + (when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1)))) + (string-append "[" (jolt-str-join acc) "]"))) + ((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}")) + ((pmap? x) (string-append "{" (jolt-str-join + (pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}")) (else (format "~a" x)))) diff --git a/host/chez/values.ss b/host/chez/values.ss index 19eb0bf..687d7e2 100644 --- a/host/chez/values.ss +++ b/host/chez/values.ss @@ -56,6 +56,8 @@ ((and (char? a) (char? b)) (char=? a b)) ((and (string? a) (string? b)) (string=? a b)) ((and (boolean? a) (boolean? b)) (eq? a b)) + ;; collections: forward to collections.ss (loaded after this file by rt.ss). + ((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b)) (else (eq? a b)))) (define (jolt= a . rest) (let loop ((a a) (rest rest)) @@ -78,4 +80,5 @@ ((string? x) (string-hash x)) ((char? x) (char->integer x)) ((boolean? x) (if x 1 2)) + ((jolt-coll? x) (jolt-coll-hash x)) ; forward to collections.ss (else (equal-hash x)))) diff --git a/test/chez/README.md b/test/chez/README.md index 59f958e..c886462 100644 --- a/test/chez/README.md +++ b/test/chez/README.md @@ -48,9 +48,17 @@ compile-time signal) and are counted "out of subset", not as divergences. JOLT_CHEZ_CORPUS=1 janet test/chez/run-corpus-chez.janet -Baseline (2026-06-17): **182/182 compiled cases pass, 0 divergences**; 2473/2655 -out of subset (await core on Chez). It's a slow report (a Chez subprocess per -case), so it's gated behind `JOLT_CHEZ_CORPUS` out of the default suite, like the -benches. `test/chez/emit-test.janet` is the fast Phase-1 unit gate (real -analyzer → Chez parity for fib/mandelbrot + regressions); both skip cleanly when +Baseline after inc 3a (persistent collections, jolt-wgbz): **433/436 compiled +cases pass**, 3 known divergences, 0 NEW; 2219/2655 out of subset (await the seq +tier + core on Chez). The 3 known divergences are dynamic IFn dispatch — a +keyword/vector held in a LOCAL and called as a fn (`(let [k :a] (k m))`); the +STATIC literal forms (`(:a m)`, `({:a 1} :a)`) are supported. They're +allowlisted in the probe; it exits non-zero on a NEW divergence. + +(Prior, inc 2 baseline: 182/182 compiled, 0 divergences, 2473 out of subset.) + +It's a slow report (a Chez subprocess per case), so it's gated behind +`JOLT_CHEZ_CORPUS` out of the default suite, like the benches. +`test/chez/emit-test.janet` is the fast Phase-1 unit gate (real analyzer → Chez +parity for fib/mandelbrot + collections + regressions); both skip cleanly when `chez` isn't on PATH. diff --git a/test/chez/emit-test.janet b/test/chez/emit-test.janet index bc8133b..8e59aa7 100644 --- a/test/chez/emit-test.janet +++ b/test/chez/emit-test.janet @@ -25,6 +25,17 @@ (def oracle-ctx (api/init {:compile? true})) (defn oracle [src] (string (api/load-string oracle-ctx src))) +# Canonical CLI oracle (the run-corpus gate's boundary): collection values don't +# round-trip through (string value) — they need jolt's real `-e` printer. Take +# the last non-empty stdout line, exactly like run-corpus.janet. +(defn cli-oracle [src] + (def proc (os/spawn ["build/jolt" "-e" src] :p {:out :pipe :err :pipe})) + (def out (ev/read (proc :out) 0x100000)) + (ev/read (proc :err) 0x100000) + (os/proc-wait proc) + (def lines (filter (fn [l] (not (empty? l))) (string/split "\n" (string/trim (if out (string out) ""))))) + (if (empty? lines) "" (last lines))) + (def ctx (d/make-ctx)) # 1) constant-folded arithmetic: (+ 1 2) -> the analyzer folds to const 3. @@ -73,6 +84,43 @@ (let [[code out err] (d/run-on-chez ctx src)] (ok label (and (= code 0) (= out (oracle src))) (string "chez=" out " janet=" (oracle src) " | " err)))) +# 3c) persistent collections (jolt-wgbz): vector/map/set literals + leaf ops. +# Maps/sets print in jolt's INTERNAL hash order, which a Scheme HAMT won't +# reproduce — so unordered cases are checked via `(= ...)` (prints true/false, +# exactly how the run-corpus gate compares them), and only ORDERED vectors are +# compared by printed form. Parity is still vs the Janet oracle in both shapes. +(each src [# ordered: direct printed-form parity + "[1 2 3]" + "(conj [1 2] 3)" + "(count [1 2 3])" + "(nth [10 20 30] 1)" + "(get [10 20 30] 0)" + "(peek [1 2 3])" + "(pop [1 2 3])" + # unordered / boolean: equality-wrapped, order-independent + "(= {:a 1 :b 2} {:b 2 :a 1})" + "(= {:a 1 :b 2} (assoc {:a 1} :b 2))" + "(= 1 (get {:a 1} :a))" + "(= 2 (count {:a 1 :b 2}))" + "(= 99 (get {:a 1} :z 99))" + "(= {:a 1} (dissoc {:a 1 :b 2} :b))" + "(= #{1 2 3} (conj #{1 2} 3))" + "(= #{1 2} (conj #{1 2} 2))" + "(contains? #{1 2} 1)" + "(contains? #{1 2} 9)" + "(contains? {:a 1} :a)" + "(empty? [])" + "(empty? [1])" + "(empty? {})" + "(= [1 2] [1 2])" + "(= [1 2] [1 3])" + "(= #{1 2} #{2 1})" + "(= {1 2} {1 3})"] + (let [[code out err] (d/run-on-chez ctx src) + want (cli-oracle src)] + (ok (string "coll: " src) (and (= code 0) (= out want)) + (string "chez=" out " janet=" want " | " err)))) + # 4) perf signal: emitted fib(30) in-Scheme timing (excludes Chez startup), to # track against the spike ceiling (hand-Scheme fib ~5ms). Informational — the # jolt-truthy? wrapper (~3x) and flonum modeling are known Phase-4 levers. diff --git a/test/chez/run-corpus-chez.janet b/test/chez/run-corpus-chez.janet index 28d4317..ff2698e 100644 --- a/test/chez/run-corpus-chez.janet +++ b/test/chez/run-corpus-chez.janet @@ -27,9 +27,21 @@ (seq [i :range [0 (length corpus) stride]] (in corpus i))) corpus)) +# Known subset divergences: cases that compile but need a feature beyond the +# current increment. Dynamic IFn dispatch — a keyword/vector held in a LOCAL or +# var then called as a fn ((let [k :a] (k m))) — is runtime dispatch on the +# invoke mechanism, deferred to the IFn/protocol increment. The STATIC literal +# forms ((:a m), ({:a 1} :a)) ARE supported. Allowlisted by label; the gate fails +# only on a NEW divergence. +(def known-divergences + {"param holding a keyword (IFn leftover)" true + "vector-in-local as fn" true + "keyword-in-local as fn" true}) + (def ctx (d/make-ctx)) (var compiled 0) (var pass 0) (var out-of-subset 0) (def diverged @[]) +(def known-hit @[]) (each row cases (def {:expected e :actual a :label l} row) @@ -44,15 +56,17 @@ (++ out-of-subset) (let [[code out] res] (++ compiled) + (defn record-div [m] (if (known-divergences l) (array/push known-hit l) (array/push diverged [l m]))) (cond - (not= code 0) (array/push diverged [l (string "exit " code)]) + (not= code 0) (record-div (string "exit " code)) (= out "true") (++ pass) - (array/push diverged [l (string "got " out)]))))))) + (record-div (string "got " out)))))))) -(printf "\nChez subset parity: %d/%d compiled cases pass (%d/%d corpus out of subset)" - pass compiled out-of-subset (length cases)) +(printf "\nChez subset parity: %d/%d compiled cases pass (%d/%d out of subset, %d known divergences)" + pass compiled out-of-subset (length cases) (length known-hit)) (when (> (length diverged) 0) - (printf "%d divergence(s) within the compiled subset:" (length diverged)) + (printf "%d NEW divergence(s) within the compiled subset:" (length diverged)) (each [l m] (slice diverged 0 (min 25 (length diverged))) (printf " [%s] %s" l m))) (flush) +(os/exit (if (> (length diverged) 0) 1 0))