diff --git a/Makefile b/Makefile index 0289c3f..5ece564 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ # build step. `make test` is the full gate. `make remint` rebuilds the seed after a # source change. -.PHONY: test ci values corpus unit smoke selfhost sci certify ffi remint +.PHONY: test ci values corpus unit smoke selfhost sci certify ffi transient remint # Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds # on the same Chez that minted the seed. @@ -15,7 +15,7 @@ test: selfhost ci # lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a # different Chez version may emit byte-different (gensym/order) output, so the # byte-fixpoint is a dev-machine check, not a CI one (jolt-8479). -ci: values corpus unit smoke sci ffi certify +ci: values corpus unit smoke sci ffi transient certify @echo "OK: CI gates passed" # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed. @@ -47,6 +47,10 @@ sci: ffi: @chez --script test/chez/ffi-server-test.ss +# Transients: mutable backing, snapshot on persistent!, and linear-time builds. +transient: + @chez --script test/chez/transient-test.ss + # JVM oracle: certify the corpus against reference Clojure. Skips if clojure absent. certify: @if command -v clojure >/dev/null 2>&1; then \ diff --git a/host/chez/printing.ss b/host/chez/printing.ss index 22796ec..a50ed9c 100644 --- a/host/chez/printing.ss +++ b/host/chez/printing.ss @@ -37,7 +37,8 @@ ;; multimethod; the readable fallback renders it directly). ;; forward refs to transients.ss (loaded later) — resolved at call time. ((jolt-transient? x) - (if (pvec? (jolt-transient-coll x)) "#" "#")) + (case (jolt-transient-kind x) + ((vec) "#") ((set) "#") (else "#"))) ((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1))) diff --git a/host/chez/transients.ss b/host/chez/transients.ss index 923bddf..4aff566 100644 --- a/host/chez/transients.ss +++ b/host/chez/transients.ss @@ -1,31 +1,103 @@ -;; transients (jolt-kl2l) — copy-on-write over the persistent collections. +;; transients (jolt-kl2l) — mutable backing per collection kind, snapshotted to +;; the immutable collection on persistent!. A faithful port of the Janet host's +;; mutable transients: conj!/assoc!/dissoc!/disj!/pop! mutate in place (amortized +;; O(1)); persistent! converts back to a pvec / pmap / pset once. ;; -;; A first cut: each transient op rebuilds the persistent collection (no in-place -;; mutation perf), but the SEMANTICS match — the overlay's transient users (into, -;; frequencies, group-by) get correct results. get/count/contains? are extended to -;; see THROUGH a transient to its held collection (frequencies/group-by do -;; (get tm k) on a transient map). vector? on a transient vector is false (it's a -;; jolt-transient record, not a pvec), which group-by relies on. Loaded after -;; collections.ss (the persistent ops it delegates to) and converters.ss. +;; vec : a growable Scheme vector (capacity) + a fill count `n`. conj!/pop! are +;; O(1) amortized — the old copy-on-write rebuilt the whole vector per op, +;; so building an N-vector was O(N^2). +;; map : a Chez hashtable keyed by key-hash / jolt= (value-equality, nil-safe — +;; a jolt-nil key stores fine here, unlike a Janet table). +;; set : a Chez hashtable of elements. +;; cow : fallback for anything else (e.g. a sorted coll) — copy-on-write over +;; the persistent ops, preserving jolt's superset of Clojure's transients. +;; +;; get/count/contains?/nth see THROUGH a transient (frequencies/group-by read a +;; transient map; a transient is callable). vector? on a transient is false (it's +;; this record, not a pvec), which group-by relies on. Loaded after collections.ss +;; (persistent ops + key-hash) and converters.ss. -(define-record-type jolt-transient (fields (mutable coll) (mutable active)) - (nongenerative jolt-transient-v1)) +(define-record-type jolt-transient + (fields kind (mutable buf) (mutable n) (mutable active)) + (nongenerative jolt-transient-v2)) -(define (jolt-transient-new coll) (make-jolt-transient coll #t)) +(define tvec-min-cap 8) + +(define (jolt-transient-new coll) + (cond + ((pvec? coll) + (let* ((v (pvec-v coll)) (cnt (vector-length v)) (cap (fxmax tvec-min-cap cnt)) + (buf (make-vector cap jolt-nil))) + (let loop ((i 0)) (when (fx a fresh transient vector (Clojure); (conj! coll) is the -;; 1-arity transducer-completion arity, which returns coll as-is with NO transient -;; check (JVM: conj! 1-arity is identity); otherwise mutate t. +;; --- in-place mutation ------------------------------------------------------- +(define (tvec-ensure! t need) ; grow capacity to >= need by doubling + (let ((buf (jolt-transient-buf t))) + (when (fx>? need (vector-length buf)) + (let* ((ncap (let grow ((c (fxmax tvec-min-cap (vector-length buf)))) (if (fx>=? c need) c (grow (fx* 2 c))))) + (nbuf (make-vector ncap jolt-nil)) (cnt (jolt-transient-n t))) + (let loop ((i 0)) (when (fxidx i)) (cnt (jolt-transient-n t))) + (cond ((and (fixnum? i) (fx>=? i 0) (fx fresh transient vector; (conj! coll) -> the 1-arity transducer- +;; completion identity (JVM: no transient check). (conj! t x ...) mutates t. (define (jolt-conj! . args) (cond ((null? args) (jolt-transient-new (jolt-vector))) @@ -33,55 +105,96 @@ (else (let ((t (car args)) (xs (cdr args))) (jolt-trans-check t "conj!") - (jolt-transient-coll-set! t (apply jolt-conj (jolt-transient-coll t) xs)) + (case (jolt-transient-kind t) + ((vec) (for-each (lambda (x) (tvec-conj1! t x)) xs)) + ((set) (for-each (lambda (x) (hashtable-set! (jolt-transient-buf t) x #t)) xs)) + ((map) (for-each (lambda (x) (tmap-conj-entry! t x)) xs)) + (else (jolt-transient-buf-set! t (apply jolt-conj (jolt-transient-buf t) xs)))) t)))) -;; (assoc! t k v & kvs): variadic like Clojure (jolt-assoc already folds pairs). -(define (jolt-assoc! t . kvs) + +;; assoc! is variadic. JVM: a complete first key/val pair present (>=3 kvs) with a +;; trailing lone key fills nil; a lone key alone (1 kv) is a wrong-arity throw. +(define (assoc-pad kvs) (if (and (>= (length kvs) 3) (odd? (length kvs))) (append kvs (list jolt-nil)) kvs)) +(define (jolt-assoc! t . kvs0) (jolt-trans-check t "assoc!") - ;; JVM assoc! is variadic: once a complete first key/val pair is present (>=3 - ;; kvs), a TRAILING lone key fills nil; a lone key alone (1 kv) is a wrong-arity - ;; throw (so don't pad it — the persistent assoc raises on odd args). - (let ((kvs (if (and (>= (length kvs) 3) (odd? (length kvs))) - (append kvs (list jolt-nil)) - kvs))) - (jolt-transient-coll-set! t (apply jolt-assoc (jolt-transient-coll t) kvs))) + (let ((kvs (assoc-pad kvs0))) + (when (odd? (length kvs)) (error #f "assoc!: no value supplied for key")) + (case (jolt-transient-kind t) + ((map) (let lp ((xs kvs)) (unless (null? xs) (hashtable-set! (jolt-transient-buf t) (car xs) (cadr xs)) (lp (cddr xs))))) + ((vec) (let lp ((xs kvs)) (unless (null? xs) (tvec-assoc1! t (car xs) (cadr xs)) (lp (cddr xs))))) + (else (jolt-transient-buf-set! t (apply jolt-assoc (jolt-transient-buf t) kvs))))) t) (define (jolt-dissoc! t . ks) (jolt-trans-check t "dissoc!") - (jolt-transient-coll-set! t (apply jolt-dissoc (jolt-transient-coll t) ks)) + (case (jolt-transient-kind t) + ((map) (for-each (lambda (k) (hashtable-delete! (jolt-transient-buf t) k)) ks)) + (else (jolt-transient-buf-set! t (apply jolt-dissoc (jolt-transient-buf t) ks)))) t) (define (jolt-disj! t . xs) (jolt-trans-check t "disj!") - (jolt-transient-coll-set! t (apply jolt-disj (jolt-transient-coll t) xs)) + (case (jolt-transient-kind t) + ((set) (for-each (lambda (x) (hashtable-delete! (jolt-transient-buf t) x)) xs)) + (else (jolt-transient-buf-set! t (apply jolt-disj (jolt-transient-buf t) xs)))) t) (define (jolt-pop! t) (jolt-trans-check t "pop!") - (jolt-transient-coll-set! t (jolt-pop (jolt-transient-coll t))) + (case (jolt-transient-kind t) + ((vec) (let ((cnt (jolt-transient-n t))) + (if (fx=? cnt 0) (error #f "pop!: can't pop empty transient vector") + (jolt-transient-n-set! t (fx- cnt 1))))) + (else (jolt-transient-buf-set! t (jolt-pop (jolt-transient-buf t))))) t) ;; persistent disj over sets (pset-disj already exists in collections.ss). (define (jolt-disj s . xs) (let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs))))) -;; get / count / contains? see through a transient. Redefine the native procedures -;; (captured first) so the existing emit lowerings (jolt-get/jolt-count/ -;; jolt-contains?) unwrap a transient before delegating; non-transients are -;; untouched. -(define (jolt-deref-transient x) (if (jolt-transient? x) (jolt-transient-coll x) x)) +;; --- see-through accessors --------------------------------------------------- +(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fxidx k))) (if (tvec-in-bounds? t i) (vector-ref (jolt-transient-buf t) i) d))) + ((map) (hashtable-ref (jolt-transient-buf t) k d)) + ((set) (if (hashtable-contains? (jolt-transient-buf t) k) k d)) + (else (%prev-jolt-get (jolt-transient-buf t) k d)))) +(define (t-count t) + (case (jolt-transient-kind t) + ((vec) (jolt-transient-n t)) + ((map set) (hashtable-size (jolt-transient-buf t))) + (else (%prev-jolt-count (jolt-transient-buf t))))) +(define (t-contains? t k) + (case (jolt-transient-kind t) + ((vec) (tvec-in-bounds? t (->idx k))) + ((map set) (hashtable-contains? (jolt-transient-buf t) k)) + (else (%prev-jolt-contains? (jolt-transient-buf t) k)))) + +;; Redefine the native get/count/contains?/nth (captured first) so the existing +;; emit lowerings unwrap a transient; non-transients are untouched. (define %prev-jolt-get jolt-get) (set! jolt-get (case-lambda - ((coll k) (%prev-jolt-get (jolt-deref-transient coll) k)) - ((coll k d) (%prev-jolt-get (jolt-deref-transient coll) k d)))) + ((coll k) (if (jolt-transient? coll) (t-get coll k jolt-nil) (%prev-jolt-get coll k))) + ((coll k d) (if (jolt-transient? coll) (t-get coll k d) (%prev-jolt-get coll k d))))) (define %prev-jolt-count jolt-count) -(set! jolt-count (lambda (coll) (%prev-jolt-count (jolt-deref-transient coll)))) +(set! jolt-count (lambda (coll) (if (jolt-transient? coll) (t-count coll) (%prev-jolt-count coll)))) (define %prev-jolt-contains? jolt-contains?) -(set! jolt-contains? (lambda (coll k) (%prev-jolt-contains? (jolt-deref-transient coll) k))) +(set! jolt-contains? (lambda (coll k) (if (jolt-transient? coll) (t-contains? coll k) (%prev-jolt-contains? coll k)))) (define %prev-jolt-nth jolt-nth) (set! jolt-nth (case-lambda - ((coll i) (%prev-jolt-nth (jolt-deref-transient coll) i)) - ((coll i d) (%prev-jolt-nth (jolt-deref-transient coll) i d)))) + ((coll i) + (if (jolt-transient? coll) + (if (eq? (jolt-transient-kind coll) 'vec) + (let ((idx (->idx i))) + (if (tvec-in-bounds? coll idx) (vector-ref (jolt-transient-buf coll) idx) (error 'nth "index out of bounds"))) + (%prev-jolt-nth (jolt-transient-buf coll) i)) + (%prev-jolt-nth coll i))) + ((coll i d) + (if (jolt-transient? coll) + (if (eq? (jolt-transient-kind coll) 'vec) + (let ((idx (->idx i))) (if (tvec-in-bounds? coll idx) (vector-ref (jolt-transient-buf coll) idx) d)) + (%prev-jolt-nth (jolt-transient-buf coll) i d)) + (%prev-jolt-nth coll i d))))) (def-var! "clojure.core" "transient" jolt-transient-new) (def-var! "clojure.core" "persistent!" jolt-persistent!) diff --git a/test/chez/transient-test.ss b/test/chez/transient-test.ss new file mode 100644 index 0000000..f643d14 --- /dev/null +++ b/test/chez/transient-test.ss @@ -0,0 +1,48 @@ +;; Transient regression: mutable backing + snapshot-on-persist (jolt-kl2l). Run: +;; chez --script test/chez/transient-test.ss +;; Semantics are covered broadly by the corpus; this pins the invariants the +;; mutable port must keep AND that large builds stay linear (a copy-on-write +;; regression would make the 200k builds quadratic and time the gate out). + +(import (chezscheme)) +(load "host/chez/rt.ss") +(set-chez-ns! "clojure.core") +(load "host/chez/seed/prelude.ss") +(load "host/chez/post-prelude.ss") +(set-chez-ns! "user") +(load "host/chez/host-contract.ss") +(load "host/chez/seed/image.ss") +(load "host/chez/compile-eval.ss") + +(define total 0) (define fails 0) +(define (ok name pred) (set! total (+ total 1)) (unless pred (set! fails (+ fails 1)) (printf "FAIL: ~a\n" name))) +(define (ev s) (jolt-final-str (jolt-compile-eval (string-append "(do " s ")") "user"))) +(define (is name s expect) (ok (string-append name " => " expect) (string=? (ev s) expect))) + +;; --- mutation is in place; persistent! snapshots back ----------------------- +(is "vector build" "(persistent! (reduce conj! (transient []) (range 5)))" "[0 1 2 3 4]") +(is "map build" "(= {0 0 1 1 2 2} (persistent! (reduce (fn [t i] (assoc! t i i)) (transient {}) (range 3))))" "true") +(is "set build" "(count (persistent! (reduce conj! (transient #{}) [1 2 2 3])))" "3") +(is "pop!" "(persistent! (pop! (conj! (transient [1 2]) 3)))" "[1 2]") +(is "dissoc!" "(persistent! (dissoc! (assoc! (transient {}) :a 1 :b 2) :a))" "{:b 2}") +(is "disj!" "(persistent! (disj! (conj! (transient #{}) :x :y) :x))" "#{:y}") + +;; --- a transient never mutates its source ----------------------------------- +(is "source map unchanged" "(let [m {:a 1} _ (persistent! (assoc! (transient m) :b 2))] (= m {:a 1}))" "true") +(is "source vector unchanged" "(let [v [1 2] _ (persistent! (conj! (transient v) 3))] (= v [1 2]))" "true") + +;; --- edges the port must keep ----------------------------------------------- +(is "nil key" "(get (persistent! (assoc! (transient {}) nil :v)) nil)" ":v") +(is "collection key" "(get (persistent! (assoc! (transient {}) [1 2] :v)) [1 2])" ":v") +(is "dangling key pads" "(= {:a 1 :b nil} (persistent! (assoc! (transient {}) :a 1 :b)))" "true") +(is "vector? is false" "(vector? (transient []))" "false") +(is "transient sorted (cow)" "(persistent! (assoc! (transient (sorted-map :b 2)) :a 1))" "{:a 1, :b 2}") +(ok "lone key throws" (guard (e (#t #t)) (ev "(persistent! (assoc! (transient {}) :a))") #f)) +(ok "use after persistent!" (guard (e (#t #t)) (ev "(let [t (transient [])] (persistent! t) (conj! t 1))") #f)) + +;; --- linear, not quadratic: 200k builds finish near-instantly --------------- +(is "big vector build" "(count (persistent! (reduce conj! (transient []) (range 200000))))" "200000") +(is "big map build" "(count (persistent! (reduce (fn [t i] (assoc! t i i)) (transient {}) (range 200000))))" "200000") + +(printf "~a/~a passed~n" (- total fails) total) +(exit (if (zero? fails) 0 1))