One IRef seam: watches/validators/meta over atom, var, and agent
add-watch/remove-watch/set-validator!/get-validator were atom-only; the atom ctor ignored :meta and :validator; watching a var crashed. Now the ARef contract is one seam: atoms keep their record slots (hot path unchanged), every other reference type registers a predicate and stores watches/validators in identity-keyed side tables, and notifies at its mutation points. Vars notify on root changes (def on a watched var, var-set outside a thread binding, alter-var-root — thread-binding sets don't notify, like the JVM); agents notify per action. The def-var! wrap costs two weak-table probes per def and does IRef work only on a watched var. Ctor options follow ARef: the validator gates the initial value (IllegalStateException 'Invalid reference state' — also the class for rejected swap!/reset!), :meta must be a map (else ClassCastException), nil allowed. meta reads any reference through the identity side-table (the type-gated fall-through is gone); alter-meta!/reset-meta! work on non-var references. Runtime-only (no re-mint). 9 JVM-certified corpus rows; spec entry; cts baseline 5781 -> 5805 pass, 73 baselined namespaces (the residual error in the watch namespaces is their STM ref section — refs stay out of scope).
This commit is contained in:
Yogthos
parent
257f822825
commit
f80f9aab4b
8 changed files with 203 additions and 42 deletions
|
|
@ -23,21 +23,38 @@
|
|||
(fields (mutable val) (mutable watches) (mutable validator) lock)
|
||||
(nongenerative jolt-atom-v3))
|
||||
|
||||
;; (atom init) / (atom init :validator f :meta m): scan the trailing keyword opts
|
||||
;; for :validator (the only one with runtime behaviour; :meta is accepted/ignored).
|
||||
;; a rejected reference value is IllegalStateException, like ARef.validate.
|
||||
(define (jolt-iref-state-throw)
|
||||
(jolt-throw (jolt-host-throwable "java.lang.IllegalStateException" "Invalid reference state")))
|
||||
|
||||
;; (atom init :meta m :validator f) — the ARef ctor contract: the validator runs
|
||||
;; against the initial value (an invalid init never constructs), :meta must be a
|
||||
;; map (anything else is the JVM's IPersistentMap cast failure).
|
||||
(define (jolt-atom-new v . opts)
|
||||
(let loop ((o opts) (validator jolt-nil))
|
||||
(let loop ((o opts) (validator jolt-nil) (m #f))
|
||||
(cond
|
||||
((or (null? o) (null? (cdr o))) (make-jolt-atom v '() validator (make-mutex)))
|
||||
((or (null? o) (null? (cdr o)))
|
||||
(let ((a (make-jolt-atom v '() validator (make-mutex))))
|
||||
(jolt-atom-validate a v)
|
||||
(when (and m (not (jolt-nil? m)))
|
||||
(unless (jolt-map? m)
|
||||
(jolt-throw (jolt-host-throwable
|
||||
"java.lang.ClassCastException"
|
||||
(string-append "class " (jolt-class-name m)
|
||||
" cannot be cast to class clojure.lang.IPersistentMap"))))
|
||||
(hashtable-set! meta-table a m))
|
||||
a))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||
(loop (cddr o) (cadr o)))
|
||||
(else (loop (cddr o) validator)))))
|
||||
(loop (cddr o) (cadr o) m))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
|
||||
(loop (cddr o) validator (cadr o)))
|
||||
(else (loop (cddr o) validator m)))))
|
||||
|
||||
;; validate a candidate value: a non-nil validator that returns falsey rejects.
|
||||
(define (jolt-atom-validate a v)
|
||||
(let ((vf (jolt-atom-validator a)))
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
|
||||
(error #f "Invalid reference state"))))
|
||||
(jolt-iref-state-throw))))
|
||||
|
||||
;; notify each watch (k ref old new), in insertion order (alist is reverse-built,
|
||||
;; so walk it reversed to match add order).
|
||||
|
|
@ -106,27 +123,87 @@
|
|||
(jolt-atom-notify a old v)
|
||||
(jolt-vector old v)))
|
||||
|
||||
;; --- watches / validators ---------------------------------------------------
|
||||
;; --- watches / validators: the IRef seam --------------------------------------
|
||||
;; On the JVM these are the ARef contract shared by atom/var/agent/ref. The atom
|
||||
;; keeps its record slots (the hot swap!/reset! path); every OTHER watchable
|
||||
;; reference type registers a predicate here and stores its watches/validator in
|
||||
;; identity-keyed side tables. A ref type makes itself notify by calling
|
||||
;; iref-notify at its mutation points (vars do at root set).
|
||||
(define iref-arms '())
|
||||
(define (register-iref-arm! pred) (set! iref-arms (cons pred iref-arms)))
|
||||
(define (iref? r)
|
||||
(let loop ((as iref-arms))
|
||||
(cond ((null? as) #f) (((car as) r) #t) (else (loop (cdr as))))))
|
||||
(define iref-watch-tbl (make-weak-eq-hashtable))
|
||||
(define iref-validator-tbl (make-weak-eq-hashtable))
|
||||
(define (iref-notify r old new)
|
||||
(for-each (lambda (kv) (jolt-invoke (cdr kv) (car kv) r old new))
|
||||
(reverse (hashtable-ref iref-watch-tbl r '()))))
|
||||
(define (iref-validate r v)
|
||||
(let ((vf (hashtable-ref iref-validator-tbl r jolt-nil)))
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
|
||||
(jolt-iref-state-throw))))
|
||||
|
||||
;; add-watch interns (key . fn) (replacing any existing key, keeping order);
|
||||
;; remove-watch drops it; both return the atom. set-validator! installs a
|
||||
;; remove-watch drops it; both return the reference. set-validator! installs a
|
||||
;; validator and validates the CURRENT value immediately (Clojure throws if it's
|
||||
;; already invalid); get-validator reads the slot.
|
||||
(define (jolt-watch-add alist key f)
|
||||
(cons (cons key f) (remp (lambda (kv) (jolt=2 (car kv) key)) alist)))
|
||||
(define (jolt-add-watch a key f)
|
||||
(jolt-atom-watches-set! a
|
||||
(cons (cons key f)
|
||||
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a))))
|
||||
a)
|
||||
(cond
|
||||
((jolt-atom? a)
|
||||
(jolt-atom-watches-set! a (jolt-watch-add (jolt-atom-watches a) key f))
|
||||
a)
|
||||
((iref? a)
|
||||
(hashtable-set! iref-watch-tbl a (jolt-watch-add (hashtable-ref iref-watch-tbl a '()) key f))
|
||||
a)
|
||||
(else (error #f "add-watch: not a watchable reference" a))))
|
||||
(define (jolt-remove-watch a key)
|
||||
(jolt-atom-watches-set! a
|
||||
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a)))
|
||||
a)
|
||||
(cond
|
||||
((jolt-atom? a)
|
||||
(jolt-atom-watches-set! a
|
||||
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a)))
|
||||
a)
|
||||
((iref? a)
|
||||
(hashtable-set! iref-watch-tbl a
|
||||
(remp (lambda (kv) (jolt=2 (car kv) key)) (hashtable-ref iref-watch-tbl a '())))
|
||||
a)
|
||||
(else (error #f "remove-watch: not a watchable reference" a))))
|
||||
(define (jolt-set-validator! a f)
|
||||
(let ((vf (if (jolt-nil? f) jolt-nil f)))
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
|
||||
(error #f "Invalid reference state"))
|
||||
(jolt-atom-validator-set! a vf)
|
||||
(cond
|
||||
((jolt-atom? a)
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
|
||||
(jolt-iref-state-throw))
|
||||
(jolt-atom-validator-set! a vf))
|
||||
((iref? a)
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-deref a))))
|
||||
(jolt-iref-state-throw))
|
||||
(hashtable-set! iref-validator-tbl a vf))
|
||||
(else (error #f "set-validator!: not a reference" a)))
|
||||
jolt-nil))
|
||||
(define (jolt-get-validator a) (jolt-atom-validator a))
|
||||
(define (jolt-get-validator a)
|
||||
(cond ((jolt-atom? a) (jolt-atom-validator a))
|
||||
((iref? a) (hashtable-ref iref-validator-tbl a jolt-nil))
|
||||
(else jolt-nil)))
|
||||
|
||||
;; vars are watchable IRefs: a root change (def / var-set on the root /
|
||||
;; alter-var-root) validates and notifies like Var.bindRoot. The def-var! wrap
|
||||
;; pays two weak-table probes per def and only does IRef work on a watched var.
|
||||
(register-iref-arm! var-cell?)
|
||||
(define def-var!-pre-iref def-var!)
|
||||
(set! def-var!
|
||||
(lambda (ns name v)
|
||||
(let ((c (jolt-var ns name)))
|
||||
(if (or (pair? (hashtable-ref iref-watch-tbl c '()))
|
||||
(not (jolt-nil? (hashtable-ref iref-validator-tbl c jolt-nil))))
|
||||
(let ((old (var-cell-root c)))
|
||||
(iref-validate c v)
|
||||
(let ((r (def-var!-pre-iref ns name v)))
|
||||
(iref-notify c old v)
|
||||
r))
|
||||
(def-var!-pre-iref ns name v)))))
|
||||
|
||||
(def-var! "clojure.core" "atom" jolt-atom-new)
|
||||
(def-var! "clojure.core" "deref" jolt-deref)
|
||||
|
|
|
|||
|
|
@ -77,14 +77,23 @@
|
|||
(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)))
|
||||
;; a ROOT change is Var.bindRoot: validate, set, notify watches
|
||||
;; (a thread-binding set does not notify, like the JVM).
|
||||
(let ((old (var-cell-root v)))
|
||||
(iref-validate v val)
|
||||
(var-cell-root-set! v val) (var-cell-defined?-set! v #t)
|
||||
(iref-notify v old val)
|
||||
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)))
|
||||
(let* ((old (var-cell-root v))
|
||||
(new (apply jolt-invoke f old args)))
|
||||
(iref-validate v new)
|
||||
(var-cell-root-set! v new)
|
||||
(var-cell-defined?-set! v #t)
|
||||
(iref-notify v old new)
|
||||
new))
|
||||
|
||||
;; __local-var: a fresh free-standing var cell (not interned). with-local-vars
|
||||
|
|
|
|||
|
|
@ -151,16 +151,31 @@
|
|||
(mutable queue) (mutable running?) mu cv)
|
||||
(nongenerative jolt-agent-v1))
|
||||
|
||||
;; (agent state) / (agent state :validator f :error-mode m :meta x): only :validator
|
||||
;; has runtime behaviour here; other opts are accepted/ignored.
|
||||
;; (agent state :meta m :validator f :error-mode e): the ARef ctor contract like
|
||||
;; atom's — the validator runs against the initial state, :meta must be a map.
|
||||
;; :error-mode is accepted/ignored (jolt agents are always :fail).
|
||||
(define (jolt-agent-new state . opts)
|
||||
(let loop ((o opts) (validator jolt-nil))
|
||||
(let loop ((o opts) (validator jolt-nil) (m #f))
|
||||
(cond
|
||||
((or (null? o) (null? (cdr o)))
|
||||
(make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition)))
|
||||
(let ((a (make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition))))
|
||||
(when (and (not (jolt-nil? validator)) (jolt-not (jolt-invoke validator state)))
|
||||
(jolt-iref-state-throw))
|
||||
(when (and m (not (jolt-nil? m)))
|
||||
(unless (jolt-map? m)
|
||||
(jolt-throw (jolt-host-throwable
|
||||
"java.lang.ClassCastException"
|
||||
(string-append "class " (jolt-class-name m)
|
||||
" cannot be cast to class clojure.lang.IPersistentMap"))))
|
||||
(hashtable-set! meta-table a m))
|
||||
a))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||
(loop (cddr o) (cadr o)))
|
||||
(else (loop (cddr o) validator)))))
|
||||
(loop (cddr o) (cadr o) m))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
|
||||
(loop (cddr o) validator (cadr o)))
|
||||
(else (loop (cddr o) validator m)))))
|
||||
;; agents are watchable IRefs; the worker notifies on each state change.
|
||||
(register-iref-arm! jolt-agent?)
|
||||
|
||||
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
|
||||
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
|
||||
|
|
@ -189,11 +204,13 @@
|
|||
(guard (e (#t (with-mutex (jolt-agent-mu a)
|
||||
(jolt-agent-err-set! a e)
|
||||
(condition-broadcast (jolt-agent-cv a)))))
|
||||
(let ((nv (apply jolt-invoke (car act) (jolt-agent-state a) (cdr act))))
|
||||
(let* ((old (jolt-agent-state a))
|
||||
(nv (apply jolt-invoke (car act) old (cdr act))))
|
||||
(let ((vf (jolt-agent-validator a)))
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
|
||||
(error #f "Invalid reference state")))
|
||||
(jolt-agent-state-set! a nv)))
|
||||
(jolt-iref-state-throw)))
|
||||
(jolt-agent-state-set! a nv)
|
||||
(iref-notify a old nv)))
|
||||
(loop)))))
|
||||
|
||||
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
|
||||
|
|
|
|||
|
|
@ -27,9 +27,9 @@
|
|||
;; so dispatch to its meta method rather than the identity side-table — which
|
||||
;; the deftype's reconstructed instances would not share.
|
||||
((and (jrec? x) (jrec-cl x "meta")) => (lambda (m) (jolt-invoke m x)))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
|
||||
(hashtable-ref meta-table x jolt-nil))
|
||||
(else jolt-nil)))
|
||||
;; everything else (collections, fns, reify, atoms/agents and any reference
|
||||
;; type) reads the identity side-table; a value with no entry is nil meta.
|
||||
(else (hashtable-ref meta-table x jolt-nil))))
|
||||
|
||||
;; fresh-identity copy of a metadatable value (so attaching meta doesn't mutate
|
||||
;; the original). cseq/procedure can't be copied meaningfully — keyed in place.
|
||||
|
|
|
|||
|
|
@ -306,13 +306,24 @@
|
|||
(loop (cddr a)))))
|
||||
jolt-nil)
|
||||
|
||||
;; alter-meta! / reset-meta!: update a var's metadata (var-meta-table, rt.ss).
|
||||
;; alter-meta! / reset-meta!: a var's metadata lives in var-meta-table (rt.ss);
|
||||
;; any other reference (atom/agent/namespace) uses the identity meta side-table
|
||||
;; jolt-meta reads.
|
||||
(define (jolt-alter-meta! ref f . args)
|
||||
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
|
||||
(new (apply jolt-invoke f cur args)))
|
||||
(hashtable-set! var-meta-table ref new)
|
||||
new))
|
||||
(define (jolt-reset-meta! ref m) (hashtable-set! var-meta-table ref m) m)
|
||||
(if (var-cell? ref)
|
||||
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
|
||||
(new (apply jolt-invoke f cur args)))
|
||||
(hashtable-set! var-meta-table ref new)
|
||||
new)
|
||||
(let* ((cur (let ((m (jolt-meta ref))) (if (jolt-nil? m) (jolt-hash-map) m)))
|
||||
(new (apply jolt-invoke f cur args)))
|
||||
(hashtable-set! meta-table ref new)
|
||||
new)))
|
||||
(define (jolt-reset-meta! ref m)
|
||||
(if (var-cell? ref)
|
||||
(hashtable-set! var-meta-table ref m)
|
||||
(hashtable-set! meta-table ref m))
|
||||
m)
|
||||
|
||||
;; --- RESOLVE FRICTION: native-op cells -------------------------------------
|
||||
;; Native-op primitives (+ map reduce …) are INLINED at emit, so they have no
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue