e6aa2aace7
Follow-on to the core.logic relational-engine work. These clear every crash in core.logic's constraint-logic-programming and unifier layers (33 errors -> 0) and most of the value mismatches; the suite goes 504 -> 523 passing assertions. All are general gaps, not core.logic-specific. - symbols intern their ns/name strings (JVM Symbol.intern .intern()s them): two separately-read `?a` symbols now share one name-string object. core.logic's non-unique lvars compare names by identity (via (str sym)), so without this a term's lvar and a constraint's lvar built from different `?a` reads never matched and constraints silently never fired. - (str x) of a single arg returns its rendering directly instead of copying through string-append, and a symbol stringifies to its (interned) name — JVM (str x) is x.toString(). Needed for the identity comparison above. - a clojure.core-qualified special form dispatches correctly: syntax-quote namespace-qualifies a macro like letfn to clojure.core/letfn (matching Clojure, where it's a macro), and the analyzer now maps that back to the special form instead of treating it as an invoke of a nil var. core.logic's fnc/defnc emit (clojure.core/letfn ...). Re-mint. - (disj nil ...) is nil (JVM), instead of crashing in the set path — core.logic's constraint store does (disj (get km v) id) where the get can be nil. corpus.edn: 4 JVM-certified rows. make test + shakesmoke green, 0 new divergences, self-host fixpoint holds.
231 lines
11 KiB
Scheme
231 lines
11 KiB
Scheme
;; transients — mutable backing per collection kind, snapshotted to the immutable
|
|
;; collection on persistent!. conj!/assoc!/dissoc!/disj!/pop! mutate in place
|
|
;; (amortized O(1)); persistent! converts back to a pvec / pmap / pset once.
|
|
;;
|
|
;; 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).
|
|
;; 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.
|
|
|
|
;; For a transient MAP, `n` holds the array-mode capacity (entries it can hold
|
|
;; before promoting to hash order) and `ord` the reverse insertion-order key list;
|
|
;; for a vector `n` is the element count. A transient array map promotes to hash
|
|
;; at max(8, source-count) entries (TransientArrayMap, array sized max(16, len)),
|
|
;; with no keyword exception — unlike the persistent assoc growth rule.
|
|
(define-record-type jolt-transient
|
|
(fields kind (mutable buf) (mutable n) (mutable active) (mutable ord))
|
|
(nongenerative jolt-transient-v3))
|
|
|
|
(define tvec-min-cap 8)
|
|
(define tmap-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<? i cnt) (vector-set! buf i (vector-ref v i)) (loop (fx+ i 1))))
|
|
(make-jolt-transient 'vec buf cnt #t #f)))
|
|
((pmap? coll)
|
|
(let ((ht (make-hashtable key-hash jolt=2)) (ord '()) (cnt 0))
|
|
;; visit in iteration order so `ord` ends up reverse-insertion (persistent! reverses it back)
|
|
(pmap-fold-fwd coll (lambda (k v acc) (hashtable-set! ht k v) (set! ord (cons k ord)) (set! cnt (fx+ cnt 1)) acc) 0)
|
|
(make-jolt-transient 'map ht (fxmax tmap-min-cap cnt) #t ord)))
|
|
((pset? coll)
|
|
(let ((ht (make-hashtable key-hash jolt=2)))
|
|
(pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0)
|
|
(make-jolt-transient 'set ht 0 #t #f)))
|
|
(else (make-jolt-transient 'cow coll 0 #t #f))))
|
|
|
|
;; map put/delete that maintain the reverse insertion-order list in `ord`.
|
|
(define (tmap-put! t k v)
|
|
(let ((ht (jolt-transient-buf t)))
|
|
(unless (hashtable-contains? ht k) (jolt-transient-ord-set! t (cons k (jolt-transient-ord t))))
|
|
(hashtable-set! ht k v)))
|
|
(define (tmap-del! t k)
|
|
(let ((ht (jolt-transient-buf t)))
|
|
(when (hashtable-contains? ht k) (jolt-transient-ord-set! t (remove-key (jolt-transient-ord t) k)))
|
|
(hashtable-delete! ht k)))
|
|
|
|
(define (jolt-trans-check t who)
|
|
(unless (jolt-transient? t) (error #f (string-append who ": not a transient") t))
|
|
(unless (jolt-transient-active t) (error #f (string-append who ": transient used after persistent!"))))
|
|
|
|
;; --- persistent! : snapshot back to the immutable collection -----------------
|
|
(define (jolt-persistent! t)
|
|
(jolt-trans-check t "persistent!")
|
|
(jolt-transient-active-set! t #f)
|
|
(case (jolt-transient-kind t)
|
|
((vec)
|
|
(let ((buf (jolt-transient-buf t)) (cnt (jolt-transient-n t)))
|
|
;; exact fit: hand off the buffer (no other reference exists, and the
|
|
;; transient is now inactive so it can't mutate it). Else trim to size —
|
|
;; a pvec's backing length must equal its count.
|
|
(if (fx=? cnt (vector-length buf))
|
|
(make-pvec buf)
|
|
(let ((out (make-vector cnt)))
|
|
(let loop ((i 0))
|
|
(if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
|
|
(make-pvec out)))))))
|
|
((map)
|
|
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t)))
|
|
(if (fx>? cnt cap)
|
|
;; promoted past the array capacity: hash order
|
|
(let ((m empty-pmap-hash))
|
|
(vector-for-each (lambda (k) (set! m (pmap-put-hash m k (hashtable-ref ht k jolt-nil)))) (hashtable-keys ht))
|
|
m)
|
|
;; array map: rebuild in insertion order
|
|
(let ((m empty-pmap))
|
|
(for-each (lambda (k) (set! m (pmap-put-ordered m k (hashtable-ref ht k jolt-nil))))
|
|
(reverse (jolt-transient-ord t)))
|
|
m))))
|
|
((set)
|
|
(let ((ht (jolt-transient-buf t)) (s empty-pset))
|
|
(vector-for-each (lambda (e) (set! s (pset-conj s e))) (hashtable-keys ht))
|
|
s))
|
|
(else (jolt-transient-buf 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 (fx<? i cnt) (vector-set! nbuf i (vector-ref buf i)) (loop (fx+ i 1))))
|
|
(jolt-transient-buf-set! t nbuf)))))
|
|
(define (tvec-conj1! t x)
|
|
(let ((cnt (jolt-transient-n t)))
|
|
(tvec-ensure! t (fx+ cnt 1))
|
|
(vector-set! (jolt-transient-buf t) cnt x)
|
|
(jolt-transient-n-set! t (fx+ cnt 1))))
|
|
(define (tvec-assoc1! t i x)
|
|
(let ((i (->idx i)) (cnt (jolt-transient-n t)))
|
|
(cond ((and (fixnum? i) (fx>=? i 0) (fx<? i cnt)) (vector-set! (jolt-transient-buf t) i x))
|
|
((and (fixnum? i) (fx=? i cnt)) (tvec-conj1! t x))
|
|
(else (error #f "assoc!: index out of bounds")))))
|
|
;; conj! onto a transient map: a [k v] pair (vector/map-entry) or a whole map.
|
|
(define (tmap-conj-entry! t x)
|
|
(cond
|
|
((jolt-nil? x) #t)
|
|
((pvec? x) (tmap-put! t (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
|
((pmap? x) (pmap-fold-fwd x (lambda (k v acc) (tmap-put! t k v) acc) 0))
|
|
(else (error #f "conj!: a transient map takes a map entry or a map" x))))
|
|
|
|
;; (conj!) -> 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)))
|
|
((null? (cdr args)) (car args))
|
|
(else
|
|
(let ((t (car args)) (xs (cdr args)))
|
|
(jolt-trans-check t "conj!")
|
|
(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! 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!")
|
|
(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) (tmap-put! 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!")
|
|
(case (jolt-transient-kind t)
|
|
((map) (for-each (lambda (k) (tmap-del! 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!")
|
|
(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!")
|
|
(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)
|
|
;; (disj nil ...) is nil on the JVM (disj is otherwise set-only).
|
|
(if (jolt-nil? s)
|
|
jolt-nil
|
|
(meta-carry s
|
|
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs)))))))
|
|
|
|
;; --- see-through accessors ---------------------------------------------------
|
|
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))
|
|
(define (t-get t k d)
|
|
(case (jolt-transient-kind t)
|
|
((vec) (let ((i (->idx 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.
|
|
(register-get-arm! jolt-transient? (lambda (coll k d) (t-get coll k d)))
|
|
(define %prev-jolt-count jolt-count)
|
|
(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) (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)
|
|
(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" "transient?" jolt-transient?)
|
|
(def-var! "clojure.core" "persistent!" jolt-persistent!)
|
|
(def-var! "clojure.core" "conj!" jolt-conj!)
|
|
(def-var! "clojure.core" "assoc!" jolt-assoc!)
|
|
(def-var! "clojure.core" "dissoc!" jolt-dissoc!)
|
|
(def-var! "clojure.core" "disj!" jolt-disj!)
|
|
(def-var! "clojure.core" "pop!" jolt-pop!)
|
|
(def-var! "clojure.core" "disj" jolt-disj)
|