From f80f9aab4b29c49c7364dd6bf76ff5b93b558632 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Thu, 2 Jul 2026 09:07:00 -0400 Subject: [PATCH] One IRef seam: watches/validators/meta over atom, var, and agent MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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). --- docs/spec/09-core-library.md | 39 +++++++++++ host/chez/atoms.ss | 117 +++++++++++++++++++++++++------ host/chez/dyn-binding.ss | 13 +++- host/chez/java/concurrency.ss | 35 ++++++--- host/chez/natives-meta.ss | 6 +- host/chez/ns.ss | 23 ++++-- test/chez/corpus.edn | 9 +++ test/chez/cts-known-failures.txt | 3 +- 8 files changed, 203 insertions(+), 42 deletions(-) diff --git a/docs/spec/09-core-library.md b/docs/spec/09-core-library.md index d9ddbee..959c380 100644 --- a/docs/spec/09-core-library.md +++ b/docs/spec/09-core-library.md @@ -282,6 +282,45 @@ S1–S4, X1–X3 → corpus `hierarchy / *` rows; clojure-test-suite --- +### atom, add-watch, remove-watch, set-validator!, get-validator — since 1.0 + +``` +(atom x & {:keys [meta validator]}) +(add-watch iref key f) (remove-watch iref key) +(set-validator! iref f) (get-validator iref) +``` + +**Semantics** + +- S1. Watches, validators, and reference metadata are one contract (the JVM's + ARef/IRef) shared by atoms, vars, and agents. `add-watch`/`remove-watch` + return the reference; re-adding a key replaces that watch in place. +- S2. A watch is called `(f key ref old new)` after a state change: atom + swap!/reset!/compare-and-set!, var ROOT changes (`def` on a watched var, + `var-set` outside a thread binding, `alter-var-root` — a thread-binding set + does not notify), and each agent action's state change. +- S3. A validator gates every state change and, via the `:validator` ctor + option, the initial value — an invalid initial value never constructs the + reference. +- S4. The `:meta` ctor option attaches reference metadata (`meta` reads it, + `alter-meta!`/`reset-meta!` update it); nil is allowed. + +**Errors** + +- X1. A rejected value (validator returns logical false or the ctor option + fails on the initial value) throws IllegalStateException "Invalid reference + state". +- X2. A non-map `:meta` ctor option throws ClassCastException. + +**Conformance** + +S1–S4, X1–X2 → corpus `iref / *` rows; clojure-test-suite +`core_test/{atom,add-watch,remove-watch}.cljc` (the remaining baselined error +in the watch namespaces is their STM `ref` section — refs are out of scope, +`stm-refs` in `coverage.md`). + +--- + ## Authoring notes - Source examples from the ClojureDocs export (`clojuredocs-export.edn`, diff --git a/host/chez/atoms.ss b/host/chez/atoms.ss index fedd144..5fcd27c 100644 --- a/host/chez/atoms.ss +++ b/host/chez/atoms.ss @@ -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) diff --git a/host/chez/dyn-binding.ss b/host/chez/dyn-binding.ss index 19be27c..dd2742d 100644 --- a/host/chez/dyn-binding.ss +++ b/host/chez/dyn-binding.ss @@ -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 diff --git a/host/chez/java/concurrency.ss b/host/chez/java/concurrency.ss index 6d96677..bfe9495 100644 --- a/host/chez/java/concurrency.ss +++ b/host/chez/java/concurrency.ss @@ -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 diff --git a/host/chez/natives-meta.ss b/host/chez/natives-meta.ss index f9c3bde..9c7b205 100644 --- a/host/chez/natives-meta.ss +++ b/host/chez/natives-meta.ss @@ -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. diff --git a/host/chez/ns.ss b/host/chez/ns.ss index f65315f..f2db350 100644 --- a/host/chez/ns.ss +++ b/host/chez/ns.ss @@ -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 diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index a644201..d3aad6d 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3542,4 +3542,13 @@ {:suite "hierarchy / classes" :label "ancestors of a concrete class roots at Object" :expected "[true true]" :actual "[(contains? (ancestors (class #{})) java.lang.Object) (contains? (ancestors (class [])) java.lang.Object)]"} {:suite "hierarchy / classes" :label "parents of a class are its direct supers" :expected "true" :actual "(contains? (parents (class [])) clojure.lang.APersistentVector)"} {:suite "hierarchy / classes" :label "a relationship derived on a super applies to the class (isa? supers arm)" :expected "true" :actual "(let [h (derive (make-hierarchy) java.util.Collection :user/coll-like)] (isa? h (class []) :user/coll-like))"} + {:suite "iref / atom ctor options" :label ":meta attaches, :validator gates the initial value" :expected "[{:m 1} 1 nil]" :actual "(let [a (atom 1 :meta {:m 1} :validator pos?)] [(meta a) (deref a) (meta (atom nil :meta nil))])"} + {:suite "iref / atom ctor options" :label "non-map :meta is a ClassCastException" :expected "[:cce :cce]" :actual "[(try (atom nil :meta 5) (catch ClassCastException _ :cce)) (try (atom nil :meta #{}) (catch ClassCastException _ :cce))]"} + {:suite "iref / atom ctor options" :label "an invalid initial value never constructs" :expected ":ise" :actual "(try (atom {} :validator (constantly false)) (catch IllegalStateException _ :ise))"} + {:suite "iref / atom ctor options" :label "validator still gates swap!/reset!" :expected "[:ise 1]" :actual "(let [a (atom 1 :validator pos?)] [(try (reset! a -1) (catch IllegalStateException _ :ise)) (deref a)])"} + {:suite "iref / watches" :label "an atom watch gets key, the ref, old and new" :expected "[:k true 0 1]" :actual "(let [a (atom 0) w (atom nil)] (add-watch a :k (fn [k r o n] (reset! w [k (identical? r a) o n]))) (swap! a inc) (deref w))"} + {:suite "iref / watches" :label "vars are watchable: root changes notify (alter-var-root, def)" :expected "[[1 2] [2 5]]" :actual "(do (def vw-x 1) (def vw-log (atom [])) (add-watch (var vw-x) :w (fn [k r o n] (swap! vw-log conj [o n]))) (alter-var-root (var vw-x) inc) (def vw-x 5) (deref vw-log))"} + {:suite "iref / watches" :label "add-watch returns the var; a validator gates the var root" :expected "[true :ise]" :actual "(do (def vv-y 1) [(= (var vv-y) (add-watch (var vv-y) :k (fn [a b c d] nil))) (do (set-validator! (var vv-y) pos?) (try (alter-var-root (var vv-y) -) (catch IllegalStateException _ :ise)))])"} + {:suite "iref / watches" :label "agent watches fire on state change" :expected "[0 1]" :actual "(let [ag (agent 0) p (promise)] (add-watch ag :w (fn [k r o n] (deliver p [o n]))) (send ag inc) (deref p 2000 :timeout))"} + {:suite "iref / meta" :label "alter-meta! works on atoms" :expected "{:x 1 :y 2}" :actual "(let [a (atom 1 :meta {:x 1})] (alter-meta! a assoc :y 2))"} ] diff --git a/test/chez/cts-known-failures.txt b/test/chez/cts-known-failures.txt index fd15188..1e2bfa0 100644 --- a/test/chez/cts-known-failures.txt +++ b/test/chez/cts-known-failures.txt @@ -2,8 +2,7 @@ # The gate fails on any per-namespace change, worse OR better; regenerate # with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh clojure.core-test.abs 1 0 -clojure.core-test.add-watch 0 3 -clojure.core-test.atom 14 0 +clojure.core-test.add-watch 0 1 clojure.core-test.bigint 6 0 clojure.core-test.bit-set 1 0 clojure.core-test.boolean-qmark 0 3