From 7bdcd23c5ee0818340d649b808850f8051ac3c8f Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Sun, 30 Aug 2026 23:13:49 -0700 Subject: [PATCH 01/31] Add fork-local SCI runtime worlds --- README.md | 35 +++++ doc/forking.md | 61 ++++++++ src/sci/core.cljc | 58 +++++-- src/sci/impl/core_protocols.cljc | 255 ++++++++++++++++++++++++++----- src/sci/impl/fns.cljc | 30 ++-- src/sci/impl/interpreter.cljc | 5 +- src/sci/impl/namespaces.cljc | 21 +-- src/sci/impl/opts.cljc | 35 ++++- src/sci/impl/world.cljc | 227 +++++++++++++++++++++++++++ src/sci/lang.cljc | 126 ++++++++++----- test/sci/core_test.cljc | 84 +++++++++- 11 files changed, 817 insertions(+), 120 deletions(-) create mode 100644 doc/forking.md create mode 100644 src/sci/impl/world.cljc diff --git a/README.md b/README.md index 5b0668af..a242cd54 100644 --- a/README.md +++ b/README.md @@ -584,6 +584,41 @@ aren't visible to other users: (sci/eval-string* sci-ctx "forked") ;;=> Unable to resolve symbol: forked ``` +Forking also snapshots the roots and metadata of existing SCI vars and the +values of atoms and volatiles created inside SCI. The handles keep their +identity, so aliases and functions defined before the fork resolve against the +world in which they are invoked: + +``` clojure +(sci/eval-string* sci-ctx + "(def counter (atom 0)) + (defn bump! [] (swap! counter inc))") + +(def forked (sci/fork sci-ctx)) +(sci/eval-string* forked "(bump!)") ;;=> 1 +(sci/eval-string* sci-ctx "@counter") ;;=> 0 +``` + +Values supplied by the host remain the host application's responsibility. An +optional `:fork-fn` can copy such values as they cross into a fork. It should +return immutable values unchanged and preserve any aliasing that matters to +the application (for example, by memoizing copies by identity): + +``` clojure +(def sci-ctx + (sci/init {:fork-fn #(if (instance? clojure.lang.Atom %) + (atom @%) + %)})) +``` + +Dynamic binding frames remain scoped to their thread and evaluation, matching +the Clojure REPL model; a fork snapshots root bindings, not a running control +continuation. Stateful host objects not handled by `:fork-fn`, and mutable +facilities not owned by SCI such as Java objects, remain shared. + +See [Forkable SCI worlds](doc/forking.md) for the lifecycle, semantic boundary, +and current limitations of this experimental model. + ### Implementing require and load-file SCI supports loading code via a hook that is invoked by SCI's implementation of diff --git a/doc/forking.md b/doc/forking.md new file mode 100644 index 00000000..9ebe4be0 --- /dev/null +++ b/doc/forking.md @@ -0,0 +1,61 @@ +# Forkable SCI worlds + +`sci/fork` creates a branch of an interpreter's runtime state. Namespace maps, +SCI Var roots and metadata, and values of SCI-created atoms and volatiles are +part of that state. Existing Vars, refs, aliases, and interpreted functions +keep their identity; their meaning is selected by the world in which code is +evaluated. + +This is deliberately a value/realization split. The forkable value is a pair +of persistent maps keyed by stable handles. The ordinary SCI context is the +fast mutable realization until its first fork. That fork materializes current +Var and ref values once and changes the original context to persistent +copy-on-write operation. Later forks are O(1) unless host copying is requested. + +This shape combines four useful precedents: + +- Clojure Vars retain a direct mutable root and thread-local binding frames. +- Julia keeps a fast latest-world realization separate from historical world + lookup. +- Yggdrasil and Spindel make branching state and externally owned resources + explicit. +- lambda-join treats the world itself as a persistent value while preserving + stable per-Var cells as a realization detail. + +## Semantics + +- A function defined before a fork resolves Vars and SCI refs in the world + where it is invoked, provided that world belongs to the same context + lineage. +- Dynamic binding frames remain thread/evaluation scoped. A fork snapshots + root bindings; it does not capture a running continuation or binding frame. +- Writes before the first fork have ordinary SCI/Clojure mutable behavior. + The first fork snapshots them. Writes after that point path-copy the selected + world's maps. +- Forking is intended to happen between evaluations. Concurrently mutating and + forking the same primary context does not currently promise a linearizable + snapshot. + +## Host cooperation + +SCI cannot infer how arbitrary host objects should branch. `sci/init` and the +two-argument `sci/fork` accept `:fork-fn`, a one-argument function applied to +values stored in world cells. It may copy application-owned state and should +return immutable values unchanged. If multiple values alias the same host +object, the function must preserve that relationship when it matters, for +example with an identity-keyed memo table. + +## Current boundary + +This first implementation makes Var roots/metadata and the values of +SCI-created atoms and volatiles fork-local. Atom validator and watch +registrations still live on the shared stable host handle. Promises, delays, +futures, transients, mutable host objects, mutable deftype fields, and effects +outside SCI remain shared unless the embedding application models or copies +them. A complete effect inventory and an explicit fork protocol are the next +step before describing an interpreter as fully forkable. + +The primary performance cost that remains is selecting the active world on +each world-sensitive operation. A custom persistent collection could improve +branched writes, but it would not remove that dispatch cost; optimizing the +world-selection/call-site path should come first. diff --git a/src/sci/core.cljc b/src/sci/core.cljc index dd2ca909..b45a88c2 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -23,6 +23,7 @@ [sci.impl.types :as t] [sci.impl.utils :as utils] [sci.impl.vars :as vars] + [sci.impl.world :as world] [sci.lang]) #?(:cljs (:require-macros [sci.core :refer [with-bindings with-out-str copy-var @@ -250,11 +251,13 @@ "Atomically alters the root binding of sci var v by applying f to its current value plus any args." ([v f] - (store/with-ctx (assoc store/*ctx* :unrestricted true) - (vars/alter-var-root v f))) + (let [ctx (assoc store/*ctx* :unrestricted true)] + (store/with-ctx ctx + (world/with-active-world ctx #(vars/alter-var-root v f))))) ([v f & args] - (store/with-ctx (assoc store/*ctx* :unrestricted true) - (apply vars/alter-var-root v f args)))) + (let [ctx (assoc store/*ctx* :unrestricted true)] + (store/with-ctx ctx + (world/with-active-world ctx #(apply vars/alter-var-root v f args)))))) (defn intern "Finds or creates a sci var named by the symbol name in the namespace @@ -264,10 +267,10 @@ sci var." ([ctx sci-ns name] (store/with-ctx ctx - (namespaces/sci-intern sci-ns name))) + (world/with-active-world ctx #(namespaces/sci-intern sci-ns name)))) ([ctx sci-ns name val] (store/with-ctx ctx - (namespaces/sci-intern sci-ns name val)))) + (world/with-active-world ctx #(namespaces/sci-intern sci-ns name val))))) (defn eval-string "Evaluates string `s` as one or multiple Clojure expressions using the Small Clojure Interpreter. @@ -296,6 +299,10 @@ Applies only to this context: a context created during an unrestricted evaluation is sandboxed unless it also gets this option. + - `:fork-fn`: optional one-argument host function used by `fork` to copy + values held in SCI world cells that need application-specific isolation. + SCI-owned mutable primitives are already world-relative and retain identity. + - `:bindings`: DEPRECATED - `:bindings x` is the same as `:namespaces {'user x}`." ([s] (eval-string s nil)) ([s opts] @@ -316,11 +323,32 @@ (opts/merge-opts ctx opts)) (defn fork - "Forks a context (as produced with `init`) into a new context. Any new - vars created in the new context won't be visible in the original - context." - [ctx] - (update ctx :env (fn [env] (atom @env)))) + "Forks a context (as produced with `init`) into an isolated runtime world. + + Existing SCI Vars and SCI-created mutable primitives retain identity, but + their values diverge after the fork. `opts` may contain `:fork-fn`, which + overrides the context's function for application-specific host values." + ([ctx] + (fork ctx nil)) + ([ctx opts] + (let [fork-fn (if (contains? opts :fork-fn) + (:fork-fn opts) + (:fork-fn ctx)) + forked-world (world/fork-world + (:sci.impl/world ctx) fork-fn + #(if (utils/var? %) + (vars/getRawRoot %) + (c/deref %)) + meta) + _ (vreset! (get-in ctx [:sci.impl/read-world :persistent?]) true)] + (assoc ctx + :env (atom @(:env ctx)) + :fork-fn fork-fn + :sci.impl/primary? false + :sci.impl/world forked-world + :sci.impl/read-world {:world forked-world + :primary? false + :persistent? (volatile! true)})))) (defn eval-string* "Evaluates string `s` in the context of `ctx` (as produced with @@ -653,6 +681,14 @@ `ctx`. Returns mutated context." [ctx ns-name ns-map] (swap! (:env ctx) update-in [:namespaces ns-name] merge ns-map) + (store/with-ctx ctx + (world/with-active-world + ctx + #(doseq [[_ v] ns-map + :when (and (utils/var? v) + (not (:sci/built-in (meta v))) + (not (world/registered? (:sci.impl/world ctx) v)))] + (world/register-var! v (vars/getRawRoot v) (meta v))))) ctx) (defn find-ns diff --git a/src/sci/impl/core_protocols.cljc b/src/sci/impl/core_protocols.cljc index 2d5a0d72..25368335 100644 --- a/src/sci/impl/core_protocols.cljc +++ b/src/sci/impl/core_protocols.cljc @@ -8,12 +8,18 @@ [sci.impl.records] [sci.impl.types :as types] [sci.impl.utils :as utils] + [sci.impl.world :as world] [sci.lang :as lang]) #?@(:cljd [] :clj [(:import [sci.impl.records SciRecord] [sci.impl.deftype SciType])])) ;;;; IDeref +(defn- tracked-value [x] + (if (world/primary-world?) + (clojure.core/deref x) + (world/value x nil))) + ;; on cljd built-in multifns are SciMultiFns so records and reify can add ;; methods at runtime, host defmultis have no runtime add on Dart #?(:cljd @@ -37,21 +43,116 @@ ;; protocol slots), so plain cljs.core/deref dispatches into sci impls :cljs nil) -;; on CLJS sci types implement the protocols natively, so clojure.core's -;; deref/swap!/reset! are exposed directly and no re-routing wrappers exist +;; On CLJS, SCI types implement protocols natively; the wrapper only adds +;; world-relative routing before falling back to cljs.core/deref. #?(:cljd (defn deref* [x] - (if (satisfies? IDeref x) + (if (and (world/mutable-primary-world?) (satisfies? IDeref x)) (clojure.core/deref x) - (-deref x))) + (if (world/tracked? x) + (tracked-value x) + (if (satisfies? IDeref x) + (clojure.core/deref x) + (-deref x))))) :clj (defn deref* ([x] - (if (instance? clojure.lang.IDeref x) - (clojure.core/deref x) - (deref x))) + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IDeref x)) + (clojure.core/deref x) + (if (world/tracked? x) + (tracked-value x) + (if (instance? clojure.lang.IDeref x) + (clojure.core/deref x) + (deref x))))) ([x & args] - (apply clojure.core/deref x args)))) + (apply clojure.core/deref x args))) + :cljs + (defn deref* [x] + (if (world/mutable-primary-world?) + (clojure.core/deref x) + (if (world/tracked? x) + (tracked-value x) + (clojure.core/deref x))))) + +(defn atom* + "Creates an atom whose state is owned by the active SCI world. The host atom + is retained as a stable handle and as the carrier for metadata, validators, + and watches." + [x & options] + (let [a (apply clojure.core/atom x options)] + (world/register! a x) + a)) + +(defn volatile!* + "Creates a volatile whose value is owned by the active SCI world." + [x] + (let [v (clojure.core/volatile! x)] + (world/register! v x) + v)) + +(defn vreset!* + [v x] + (if (world/mutable-primary-world?) + (clojure.core/vreset! v x) + (if (world/tracked? v) + (if (world/primary-world?) + (let [new (clojure.core/vreset! v x)] + (world/reset-value! v new) + new) + (world/reset-value! v x)) + (clojure.core/vreset! v x)))) + +(defn vswap!* + [v f & args] + (if (world/mutable-primary-world?) + (clojure.core/vreset! v (apply f (clojure.core/deref v) args)) + (if (world/tracked? v) + (vreset!* v (apply f (tracked-value v) args)) + (clojure.core/vreset! v (apply f (clojure.core/deref v) args))))) + +(defn- validate-ref! [ref v] + (when-let [validator (get-validator ref)] + (when-not (validator v) + (throw #?(:cljd (StateError. "Invalid reference state") + :clj (IllegalStateException. "Invalid reference state") + :cljs (js/Error. "Invalid reference state"))))) + nil) + +(defn- notify-ref! [ref old new] + #?(:clj (.notifyWatches ^clojure.lang.ARef ref old new) + :default nil) + nil) + +(defn- swap-tracked! [ref f args] + (if (world/primary-world?) + (let [new (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f))] + (world/reset-value! ref new) + new) + (world/swap-value! ref f args + #(validate-ref! ref %) + #(notify-ref! ref %1 %2)))) + +(defn- reset-tracked! [ref v] + (if (world/primary-world?) + (let [new (clojure.core/reset! ref v)] + (world/reset-value! ref new) + new) + (world/reset-tracked! ref v + #(validate-ref! ref %) + #(notify-ref! ref %1 %2)))) + +(defn- compare-and-set-tracked!* [ref old new] + (if (world/primary-world?) + (let [changed? (clojure.core/compare-and-set! ref old new)] + (when changed? + (world/reset-value! ref new)) + changed?) + (world/compare-and-set-tracked! ref old new + #(validate-ref! ref %) + #(notify-ref! ref %1 %2)))) #?(:cljd (def cljd-core-ns (lang/->Namespace 'cljd.core nil))) @@ -192,59 +293,135 @@ ;;;; Re-routing -#?(:cljd nil :cljs nil :clj +#?(:clj (defn swap!* [ref f & args] - (if - ;; fast-path for host IAtom - (instance? clojure.lang.IAtom ref) - (if args - (apply clojure.core/swap! ref f args) - (clojure.core/swap! ref f)) - (if args - (apply swap ref f args) - (swap ref f))))) + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) + (apply clojure.core/swap! ref f args) + (if (world/tracked? ref) + (swap-tracked! ref f args) + (if (instance? clojure.lang.IAtom ref) + (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f)) + (if args + (apply swap ref f args) + (swap ref f)))))) + :cljs + (defn swap!* [ref f & args] + (if (world/mutable-primary-world?) + (apply clojure.core/swap! ref f args) + (if (world/tracked? ref) + (swap-tracked! ref f args) + (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f)))))) #?(:cljd (defn swap!* [ref f & args] - (if (or (instance? cljd.core/Atom ref) - (satisfies? ISwap ref)) - (if args - (apply clojure.core/swap! ref f args) - (clojure.core/swap! ref f)) - (if args - (apply -swap! ref f args) - (-swap! ref f))))) + (if (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) + (apply clojure.core/swap! ref f args) + (if (world/tracked? ref) + (swap-tracked! ref f args) + (if (or (instance? cljd.core/Atom ref) + (satisfies? ISwap ref)) + (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f)) + (if args + (apply -swap! ref f args) + (-swap! ref f))))))) #?(:cljd (defn reset!* [ref v] - (if (or (instance? cljd.core/Atom ref) - (satisfies? IReset ref)) + (if (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) (clojure.core/reset! ref v) - (-reset! ref v))) + (if (world/tracked? ref) + (reset-tracked! ref v) + (if (or (instance? cljd.core/Atom ref) + (satisfies? IReset ref)) + (clojure.core/reset! ref v) + (-reset! ref v))))) :clj (defn reset!* [ref v] - (if (instance? clojure.lang.IAtom ref) + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) + (clojure.core/reset! ref v) + (if (world/tracked? ref) + (reset-tracked! ref v) + (if (instance? clojure.lang.IAtom ref) + (clojure.core/reset! ref v) + (reset ref v))))) + :cljs + (defn reset!* [ref v] + (if (world/mutable-primary-world?) (clojure.core/reset! ref v) - (reset ref v)))) + (if (world/tracked? ref) + (reset-tracked! ref v) + (clojure.core/reset! ref v))))) -#?(:clj +#?(:cljd + (defn compare-and-set!* [ref old new] + (if (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) + (clojure.core/compare-and-set! ref old new) + (if (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + (clojure.core/compare-and-set! ref old new)))) + :clj + (defn compare-and-set!* [ref old new] + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) + (clojure.core/compare-and-set! ref old new) + (if (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + (if (instance? clojure.lang.IAtom ref) + ;; fast-path for host IAtoms + (clojure.core/compare-and-set! ref old new) + (compareAndSet ref old new))))) + :cljs (defn compare-and-set!* [ref old new] - (if (instance? clojure.lang.IAtom ref) - ;; fast-path for host IAtoms + (if (world/mutable-primary-world?) (clojure.core/compare-and-set! ref old new) - (compareAndSet ref old new)))) + (if (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + (clojure.core/compare-and-set! ref old new))))) #?(:clj (defn swap-vals!* [ref f & args] - (if (instance? clojure.lang.IAtom ref) + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) (apply clojure.core/swap-vals! ref f args) - (apply swapVals ref f args)))) + (if (world/tracked? ref) + (if (world/primary-world?) + (let [ret (apply clojure.core/swap-vals! ref f args)] + (world/reset-value! ref (nth ret 1)) + ret) + (let [old (world/value ref nil) + new (swap-tracked! ref f args)] + [old new])) + (if (instance? clojure.lang.IAtom ref) + (apply clojure.core/swap-vals! ref f args) + (apply swapVals ref f args)))))) #?(:clj (defn reset-vals!* [ref v] - (if (instance? clojure.lang.IAtom ref) + (if (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) (clojure.core/reset-vals! ref v) - (resetVals ref v)))) + (if (world/tracked? ref) + (if (world/primary-world?) + (let [ret (clojure.core/reset-vals! ref v)] + (world/reset-value! ref (nth ret 1)) + ret) + (let [old (world/value ref nil) + new (reset-tracked! ref v)] + [old new])) + (if (instance? clojure.lang.IAtom ref) + (clojure.core/reset-vals! ref v) + (resetVals ref v)))))) ;;;; Protocol vars diff --git a/src/sci/impl/fns.cljc b/src/sci/impl/fns.cljc index b63c47c6..a21cb3bf 100644 --- a/src/sci/impl/fns.cljc +++ b/src/sci/impl/fns.cljc @@ -3,7 +3,8 @@ (:require [sci.impl.macros :as macros] [sci.impl.types :as types] - [sci.impl.utils :as utils :refer [recur]]) + [sci.impl.utils :as utils :refer [recur]] + [sci.impl.world :as world]) #?(:cljs (:require-macros [sci.impl.fns :refer [gen-fn wrap-this-as]]))) #?(:cljd nil :clj (set! *warn-on-reflection* true)) @@ -36,11 +37,12 @@ ([n _disable-arity-checks varargs] (if (zero? n) (let [varargs-param (when varargs (gensym))] - `(let [recur# recur - interrupt-fn# (:interrupt-fn ~'ctx)] + `(let [recur# recur] (fn ~'arity-0 ~(cond-> [] varargs (conj '& varargs-param)) - (let [~'invoc-array (when-not (zero? ~'invoc-size) + (let [active-ctx# (world/active-ctx ~'ctx) + interrupt-fn# (:interrupt-fn active-ctx#) + ~'invoc-array (when-not (zero? ~'invoc-size) #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) :default (object-array ~'invoc-size)))] (when ~'enclosed->invocation @@ -50,7 +52,7 @@ [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) (loop [] (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret# (types/eval ~'body ~'ctx ~'invoc-array)] + (let [ret# (types/eval ~'body active-ctx# ~'invoc-array)] (if (identical? recur# ret#) (recur) ret#)))))))) @@ -60,11 +62,12 @@ `(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default {:tag 'objects})) ~idx ~fn-param)) fn-params (range)))] - `(let [recur# recur - interrupt-fn# (:interrupt-fn ~'ctx)] + `(let [recur# recur] (fn ~(symbol (str "arity-" n)) ~(cond-> fn-params varargs (conj '& varargs-param)) - (let [~'invoc-array (when-not (zero? ~'invoc-size) + (let [active-ctx# (world/active-ctx ~'ctx) + interrupt-fn# (:interrupt-fn active-ctx#) + ~'invoc-array (when-not (zero? ~'invoc-size) #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) :default (object-array ~'invoc-size)))] (when ~'enclosed->invocation @@ -75,7 +78,7 @@ [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) (loop [] (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret# (types/eval ~'body ~'ctx ~'invoc-array)] + (let [ret# (types/eval ~'body active-ctx# ~'invoc-array)] (if (identical? recur# ret#) (recur) ret#))))))))))) @@ -148,10 +151,11 @@ 19 (gen-fn 19) 20 (gen-fn 20) ;; default case for 20+ args (used by loop) - (let [recur# recur - interrupt-fn# (:interrupt-fn ctx)] + (let [recur# recur] (fn arity-many [& args] - (let [invoc-array (when-not (zero? invoc-size) + (let [active-ctx (world/active-ctx ctx) + interrupt-fn# (:interrupt-fn active-ctx) + invoc-array (when-not (zero? invoc-size) #?(:cljd (#/(List/filled dynamic) invoc-size nil) :default (object-array invoc-size)))] (when enclosed->invocation @@ -164,7 +168,7 @@ (recur (next args) (inc i)))) (loop [] (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret (types/eval body ctx invoc-array)] + (let [ret (types/eval body active-ctx invoc-array)] (if (identical? recur# ret) (recur) ret))))))))] diff --git a/src/sci/impl/interpreter.cljc b/src/sci/impl/interpreter.cljc index f17b9901..cbaeda84 100644 --- a/src/sci/impl/interpreter.cljc +++ b/src/sci/impl/interpreter.cljc @@ -11,7 +11,8 @@ [sci.impl.parser :as parser] [sci.impl.types :as types] [sci.impl.utils :as utils] - [sci.impl.vars :as vars])) + [sci.impl.vars :as vars] + [sci.impl.world :as world])) #?(:cljd nil :clj (set! *warn-on-reflection* true)) @@ -80,7 +81,7 @@ (defn eval-form [ctx form] #?(:cljd (-install-wiring!)) (store/with-ctx ctx - (eval-form* ctx form))) + (world/with-active-world ctx #(eval-form* ctx form)))) (vreset! utils/eval-form-state eval-form) diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 1e3f261b..19bf6623 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -1439,19 +1439,15 @@ 'satisfies? (copy-var sci.impl.protocols/satisfies? clojure-core-ns {:name 'satisfies?}) ;; end protocols ;; IDeref as protocol - 'deref #?(:cljs (copy-core-var deref) - :default (copy-var core-protocols/deref* clojure-core-ns {:name 'deref})) + 'deref (copy-var core-protocols/deref* clojure-core-ns {:name 'deref}) #?@(:cljd ['-deref (new-var '-deref core-protocols/-deref) 'IDeref core-protocols/deref-protocol] :cljs ['-deref (new-var '-deref -deref) 'IDeref core-protocols/deref-protocol]) ;; end IDeref as protocol ;; IAtom / ISwap as protocol - 'swap! #?(:cljs (copy-core-var swap!) - :default (copy-var core-protocols/swap!* clojure-core-ns {:name 'swap!})) - 'compare-and-set! #?(:cljd (copy-core-var compare-and-set!) - :clj (copy-var core-protocols/compare-and-set!* clojure-core-ns {:name 'compare-and-set!}) - :cljs (copy-core-var compare-and-set!)) + 'swap! (copy-var core-protocols/swap!* clojure-core-ns {:name 'swap!}) + 'compare-and-set! (copy-var core-protocols/compare-and-set!* clojure-core-ns {:name 'compare-and-set!}) #?@(:cljd ['IReset core-protocols/reset-protocol 'ISwap core-protocols/swap-protocol '-swap! (new-var '-swap! core-protocols/-swap!) @@ -1544,7 +1540,7 @@ 'assoc! (copy-core-var assoc!) 'assoc-in (copy-core-var assoc-in) 'associative? (copy-core-var associative?) - 'atom (copy-core-var atom) + 'atom (copy-var core-protocols/atom* clojure-core-ns {:name 'atom}) #?@(:clj ['bean (copy-core-var bean)]) 'binding (macrofy 'binding sci-binding) 'binding-conveyor-fn (copy-core-var sci.impl.vars/binding-conveyor-fn) @@ -1852,8 +1848,7 @@ 'reduced (copy-core-var reduced) 'reduced? (copy-core-var reduced?) 'req! (copy-var req!* clojure-core-ns {:name 'req!}) - 'reset! #?(:cljs (copy-core-var reset!) - :default (copy-var core-protocols/reset!* clojure-core-ns {:name 'reset!})) + 'reset! (copy-var core-protocols/reset!* clojure-core-ns {:name 'reset!}) 'reset-thread-binding-frame-impl (new-var 'reset-thread-binding-frame-impl sci.impl.vars/reset-thread-binding-frame) 'resolve (copy-var sci-resolve clojure-core-ns {:name 'resolve}) #?@(:cljd [] :default ['reversible? (copy-core-var reversible?)]) @@ -1972,10 +1967,10 @@ 'vec (copy-core-var vec) 'vector (copy-core-var vector) 'vector? (copy-core-var vector?) - 'volatile! (copy-core-var volatile!) + 'volatile! (copy-var core-protocols/volatile!* clojure-core-ns {:name 'volatile!}) 'volatile? (copy-core-var volatile?) - 'vreset! (copy-core-var vreset!) - 'vswap! (macrofy 'vswap! vswap!) + 'vreset! (copy-var core-protocols/vreset!* clojure-core-ns {:name 'vreset!}) + 'vswap! (copy-var core-protocols/vswap!* clojure-core-ns {:name 'vswap!}) 'when-first (macrofy 'when-first when-first*) 'when-let (macrofy 'when-let when-let*) 'when-some (macrofy 'when-some when-some*) diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index c64d07d2..f41fdbca 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -2,12 +2,26 @@ {:no-doc true} (:require #?(:cljs [goog.string]) + [sci.ctx-store :as store] [sci.impl.namespaces :as namespaces] [sci.impl.types] [sci.impl.utils :as utils :refer [strip-core-ns]] + [sci.impl.vars :as vars] + [sci.impl.world :as world] #?(:cljd [sci.lang :as lang] :default [sci.lang])) #?@(:cljd [] :clj [(:import - [sci.impl.types ICustomType])])) + [sci.impl.types ICustomType])])) + +(defn- register-vars! [ctx] + (store/with-ctx ctx + (world/with-active-world + ctx + #(doseq [[_ ns-map] (:namespaces @(:env ctx)) + [_ v] ns-map + :when (and (utils/var? v) + (not (:sci/built-in (meta v))) + (not (world/registered? (:sci.impl/world ctx) v)))] + (world/register-var! v (vars/getRawRoot v) (meta v)))))) #?(:clj (defrecord Env [namespaces imports load-fn])) @@ -249,6 +263,7 @@ deftype-fn interrupt-fn unrestricted + fork-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases]}] @@ -261,6 +276,8 @@ bindings (merge {'user (assoc bindings :obj utils/user-ns)})) _ (init-env! env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) + world-root (world/new-world) + persistent-world? (volatile! false) ctx (assoc (->ctx {} env features readers (or allow deny) :interrupt-fn interrupt-fn) :allow (when allow (process-permissions #{} allow)) @@ -269,7 +286,15 @@ :proxy-fn proxy-fn :deftype-fn deftype-fn :unrestricted unrestricted + :fork-fn fork-fn + :sci.impl/world world-root + :sci.impl/read-world {:world world-root + :primary? true + :persistent? persistent-world?} + :sci.impl/lineage (atom nil) + :sci.impl/primary? true #?@(:clj [:main-thread-id (.getId (Thread/currentThread))]))] + (register-vars! ctx) ctx)) (defn merge-opts [ctx opts] @@ -286,6 +311,7 @@ readers reify-fn deftype-fn + fork-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases] @@ -299,6 +325,7 @@ _ (init-env! !env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) interrupt-fn (if (contains? opts :interrupt-fn) (:interrupt-fn opts) (:interrupt-fn ctx)) unrestricted (if (contains? opts :unrestricted) (:unrestricted opts) (:unrestricted ctx)) + fork-fn (if (contains? opts :fork-fn) fork-fn (:fork-fn ctx)) ctx (assoc (->ctx {} !env features readers (or (:check-permissions ctx) allow deny) :interrupt-fn interrupt-fn) :allow (when allow (process-permissions (:allow ctx) allow)) @@ -306,5 +333,11 @@ :reify-fn reify-fn :deftype-fn deftype-fn :unrestricted unrestricted + :fork-fn fork-fn + :sci.impl/world (:sci.impl/world ctx) + :sci.impl/read-world (:sci.impl/read-world ctx) + :sci.impl/lineage (:sci.impl/lineage ctx) + :sci.impl/primary? (:sci.impl/primary? ctx) :main-thread-id (:main-thread-id ctx))] + (register-vars! ctx) ctx)) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc new file mode 100644 index 00000000..d4d4ebd6 --- /dev/null +++ b/src/sci/impl/world.cljc @@ -0,0 +1,227 @@ +(ns sci.impl.world + "Fork-local runtime state for SCI contexts. + + A world is a persistent value behind an atom. Stable handles (SCI Vars and + SCI-created mutable primitives) are keys into that value. Forks copy the + persistent value into a fresh atom, preserving identity and aliasing while + isolating subsequent writes." + (:require [sci.ctx-store :as store])) + +(defn new-world [] + (atom {:values {} + :var-meta {} + ;; Before the first fork, the primary context behaves like ordinary + ;; mutable SCI. The first fork realizes a persistent snapshot. + :persistent? false})) + +#?(:clj + (def ^ThreadLocal active-world + (proxy [ThreadLocal] [] + (initialValue [] nil))) + :default + (def active-world (volatile! nil))) + +(defn- active-world-state [] + #?(:clj (.get ^ThreadLocal active-world) + :default @active-world)) + +(defn with-active-world + "Run `f` with the context's read realization installed. Primary contexts use + direct Var/host-ref fields; descendants use their persistent world value." + [ctx f] + (let [previous (active-world-state) + active (:sci.impl/read-world ctx)] + #?(:clj (.set ^ThreadLocal active-world active) + :default (vreset! active-world active)) + (try + (f) + (finally + #?(:clj (if (nil? previous) + (.remove ^ThreadLocal active-world) + (.set ^ThreadLocal active-world previous)) + :default (vreset! active-world previous)))))) + +(defn current-world [] + (:sci.impl/world store/*ctx*)) + +(defn registered? [world handle] + (contains? (:values @world) handle)) + +(defn primary-world? [] + (let [active (active-world-state)] + (if active + (:primary? active) + (true? (:sci.impl/primary? store/*ctx*))))) + +(defn mutable-primary-world? [] + (let [active (active-world-state)] + (and (:primary? active) + (not @(:persistent? active))))) + +(defn tracked? + [handle] + (when-let [world (:world (active-world-state))] + (contains? (:values @world) handle))) + +(defn value + [handle fallback] + (if-let [world (:world (active-world-state))] + (get-in @world [:values handle] fallback) + fallback)) + +(defn var-value + "Primary contexts keep the Var's ordinary mutable root synchronized, which + preserves the Clojure/SCI fast path. Descendants resolve through the world." + [handle fallback] + (let [active (active-world-state)] + (if (or (nil? active) (:primary? active)) + fallback + (get-in @(:world active) [:values handle] fallback)))) + +(defn var-meta + [handle fallback] + (let [active (active-world-state)] + (if (or (nil? active) (:primary? active)) + fallback + (get-in @(:world active) [:var-meta handle] fallback)))) + +(defn register! + [handle value] + (when-let [world (current-world)] + (swap! world assoc-in [:values handle] value)) + handle) + +(defn register-var! + [handle value m] + (when-let [world (current-world)] + (let [state @world] + (when-not (and (primary-world?) + (not (:persistent? state)) + (contains? (:var-meta state) handle)) + (swap! world (fn [state] + (-> state + (assoc-in [:values handle] value) + (assoc-in [:var-meta handle] m))))))) + handle) + +(defn- mutable-primary-state? [state] + (and (primary-world?) (not (:persistent? state)))) + +(defn reset-value! + [handle value] + (if-let [world (current-world)] + (do (let [state @world] + (when-not (and (mutable-primary-state? state) + (contains? (:values state) handle)) + (swap! world assoc-in [:values handle] value))) + value) + ::no-world)) + +(defn reset-var-meta! + [handle m] + (if-let [world (current-world)] + (do (let [state @world] + (when-not (and (mutable-primary-state? state) + (contains? (:var-meta state) handle)) + (swap! world assoc-in [:var-meta handle] m))) + m) + ::no-world)) + +(defn alter-var-meta! + [handle fallback f args] + (if-let [world (current-world)] + (let [state @world] + (if (mutable-primary-state? state) + (apply f fallback args) + (get-in (swap! world update-in [:var-meta handle] + (fn [m] + (apply f (if (nil? m) fallback m) args))) + [:var-meta handle]))) + ::no-world)) + +(defn swap-value! + "Atomically update a tracked handle. `validate!` runs before the CAS and + `notify!` once after a successful transition. Returns the new value." + [handle f args validate! notify!] + (let [world (current-world)] + (loop [] + (let [state @world + old (get-in state [:values handle]) + new (apply f old args)] + (validate! new) + (if (compare-and-set! world state (assoc-in state [:values handle] new)) + (do (notify! old new) + new) + (recur)))))) + +(defn reset-tracked! + [handle new validate! notify!] + (swap-value! handle (constantly new) nil validate! notify!)) + +(defn compare-and-set-tracked! + [handle expected new validate! notify!] + (let [world (current-world)] + (loop [] + (let [state @world + old (get-in state [:values handle])] + (if-not (identical? expected old) + false + (do + (validate! new) + (if (compare-and-set! world state (assoc-in state [:values handle] new)) + (do (notify! old new) + true) + (recur)))))))) + +(defn active-ctx + "Use the currently evaluating descendant context for an interpreted closure. + Unrelated SCI contexts cannot capture one another accidentally." + [captured] + (let [active store/*ctx*] + (if (and active + (identical? (:sci.impl/lineage captured) + (:sci.impl/lineage active))) + active + captured))) + +(defn fork-world + [world fork-value snapshot-value snapshot-var-meta] + (let [realize (fn [] + (let [state @world] + (if (:persistent? state) + state + (let [handles (keys (:values state)) + vars (keys (:var-meta state)) + realized (-> state + (assoc :persistent? true) + (update :values + (fn [values] + (reduce (fn [ret handle] + (assoc ret handle (snapshot-value handle))) + values handles))) + (update :var-meta + (fn [metas] + (reduce (fn [ret v] + (assoc ret v (snapshot-var-meta v))) + metas vars))))] + (reset! world realized) + realized)))) + state #?(:clj (locking world (realize)) + :default (realize))] + ;; Without a host copier, forking is only a new mutable tip over the same + ;; persistent value. The first write in either branch creates divergence. + (if-not fork-value + (atom state) + (let [handles (set (keys (:values state)))] + (atom + (update state :values + (fn [values] + (reduce-kv + (fn [ret handle v] + ;; World-relative handles must retain identity. Other + ;; values cross the explicit cooperation boundary. + (assoc ret handle (if (contains? handles v) + v + (fork-value v)))) + (empty values) + values)))))))) diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index 76a66a24..7d61f78a 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -1,7 +1,8 @@ (ns sci.lang (:require [sci.ctx-store] [sci.impl.types :as types] - [sci.impl.vars :as vars]) + [sci.impl.vars :as vars] + [sci.impl.world :as world]) (:refer-clojure :exclude [Var ->Var var? Namespace ->Namespace])) #?(:cljd nil :clj (set! *warn-on-reflection* true)) @@ -91,41 +92,56 @@ ;; marker interface, clj only for now #?@(:cljd [] :clj [sci.lang.IVar]) types/HasName - (getName [_this] - (or (:name meta) sym)) + (getName [this] + (or (:name (world/var-meta this meta)) sym)) vars/IVar (bindRoot [this v] - (let [old-root (.-root this)] - (vars/with-writeable-var this meta - (vars/bumping-set! root v)) + (let [old-root (world/var-value this root) + current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do (world/register-var! this v current-meta) + (when (world/primary-world?) + (vars/bumping-set! root v))) + (vars/bumping-set! root v))) (notify-watches this watches old-root v)) ;; this is the return value for alter-var-root which should be the only place calling bindRoot directly v) - (getRawRoot [_this] - root) - (toSymbol [_this] + (getRawRoot [this] + (world/var-value this root)) + (toSymbol [this] ;; if we have at least a name from metadata, then build the symbol from that - (if-let [sym-name (some-> (:name meta) name)] - (symbol (some-> (:ns meta) types/getName name) sym-name) + (let [current-meta (world/var-meta this meta)] + (if-let [sym-name (some-> (:name current-meta) name)] + (symbol (some-> (:ns current-meta) types/getName name) sym-name) ;; otherwise, fall back to the symbol - sym)) - (isMacro [_] - (or (:macro meta) - (when-some [m (clojure.core/meta root)] - (:sci/macro m)))) + sym))) + (isMacro [this] + (let [current-meta (world/var-meta this meta) + current-root (world/var-value this root)] + (or (:macro current-meta) + (when-some [m (clojure.core/meta current-root)] + (:sci/macro m))))) (setThreadBound [this v] #?(:cljd (set! thread-bound v) :default (set! (.-thread-bound this) v))) (unbind [this] - (vars/with-writeable-var this meta - (vars/bumping-set! (.-root this) (vars/->SciUnbound this)))) - (hasRoot [_this] + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (let [unbound (vars/->SciUnbound this)] + (world/reset-value! this unbound) + (when (world/primary-world?) + (vars/bumping-set! (.-root this) unbound))) + (vars/bumping-set! (.-root this) (vars/->SciUnbound this)))))) + (hasRoot [this] (not (instance? #?(:cljd vars/SciUnbound :clj sci.impl.vars.SciUnbound - :cljs sci.impl.vars.SciUnbound) root))) + :cljs sci.impl.vars.SciUnbound) + (world/var-value this root)))) vars/DynVar - (dynamic? [_this] - (:dynamic meta)) + (dynamic? [this] + (:dynamic (world/var-meta this meta))) types/IBox (setVal [this v] (if-let [b (vars/get-thread-binding this)] @@ -138,13 +154,21 @@ (types/setVal b v))) :cljs (types/setVal b v)) #?(:cljd (if (:unrestricted sci.ctx-store/*ctx*) - (set! (.-root this) v) + (if (world/current-world) + (do (world/reset-value! this v) + (when (world/primary-world?) + (set! (.-root this) v))) + (set! (.-root this) v)) (throw-root-binding this)) :clj (throw-root-binding this) :cljs (if (:unrestricted sci.ctx-store/*ctx*) - (vars/bumping-set! (.-root this) v) + (if (world/current-world) + (do (world/reset-value! this v) + (when (world/primary-world?) + (vars/bumping-set! (.-root this) v))) + (vars/bumping-set! (.-root this) v)) (throw-root-binding this))))) - (getVal [_this] root) + (getVal [this] (world/var-value this root)) #?(:cljd IDeref :clj clojure.lang.IDeref :cljs IDeref) (#?(:cljd -deref :clj deref @@ -152,8 +176,8 @@ (if thread-bound (if-let [tbox (vars/get-thread-binding this)] (types/getVal tbox) - root) - root)) + (world/var-value this root)) + (world/var-value this root))) Object (toString [this] (str "#'" (vars/toSymbol this))) @@ -162,7 +186,9 @@ (-write writer "#'") (-pr-writer (vars/toSymbol a) writer opts))) #?(:cljd IMeta :clj clojure.lang.IMeta :cljs IMeta) - #?(:cljd (-meta [_] meta) :clj (clojure.core/meta [_] meta) :cljs (-meta [_] meta)) + #?(:cljd (-meta [this] (world/var-meta this meta)) + :clj (clojure.core/meta [this] (world/var-meta this meta)) + :cljs (-meta [this] (world/var-meta this meta))) ;; #?(:clj Comparable :cljs IEquiv) ;; (-equiv [this other] ;; (if (instance? Var other) @@ -173,40 +199,60 @@ ;; (hash-symbol sym)) #?@(:cljd [] :clj [clojure.lang.IReference (alterMeta [this f args] - (vars/with-writeable-var this meta - (locking this (set! meta (apply f meta args))))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (locking this + (if (world/current-world) + (let [m (world/alter-var-meta! this current-meta f args)] + (when (world/primary-world?) + (set! meta m)) + m) + (set! meta (apply f meta args))))))) (resetMeta [this m] - (vars/with-writeable-var this meta - (locking this (set! meta m))))]) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (locking this + (if (world/current-world) + (do (world/reset-var-meta! this m) + (when (world/primary-world?) + (set! meta m)) + m) + (set! meta m))))))]) #?@(:cljd [types/IResetMeta (-reset-meta! [this m] - (vars/with-writeable-var this meta - (set! meta m))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do (world/reset-var-meta! this m) + (when (world/primary-world?) + (set! meta m)) + m) + (set! meta m))))) IWatchable (-add-watch [this key fn] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (assoc watches key fn))) this) (-remove-watch [this key] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (dissoc watches key))) this)] :clj [clojure.lang.IRef (addWatch [this key fn] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (assoc watches key fn))) this) (removeWatch [this key] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (dissoc watches key))) this)] :cljs [IWatchable (-add-watch [this key fn] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (assoc watches key fn))) this) (-remove-watch [this key] - (vars/with-writeable-var this meta + (vars/with-writeable-var this (world/var-meta this meta) (set! watches (dissoc watches key))) this)]) ;; #?(:cljs Fn) ;; In the real CLJS this is there... why? diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 3b2365d5..3a9044e9 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1401,6 +1401,84 @@ #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error) #"Unable to resolve symbol: y" (sci/eval-string* ctx "y")))))) +(deftest forked-world-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(def x 1) + (def ^:dynamic *x* 10) + (def counter (atom 0)) + (def counter-alias counter) + (def scratch (volatile! 20)) + (defn world-value [] [x *x* @counter @counter-alias @scratch]) + (defn bump! [] (swap! counter inc)) + (defn scratch! [] (vswap! scratch inc))") + (let [child (sci/fork parent)] + (is (= [1 10 0 0 20] (sci/eval-string* child "(world-value)"))) + (is (= [2 12 1 1 21] + (sci/eval-string* + child + "(def x 2) + (bump!) + (scratch!) + (binding [*x* 11] + (set! *x* 12) + (world-value))"))) + (testing "existing vars, captured functions, bindings, atoms, and volatiles isolate" + (is (= [1 10 0 0 20] (sci/eval-string* parent "(world-value)"))) + (is (= [2 10 1 1 21] (sci/eval-string* child "(world-value)")))) + (testing "forks from the same basis diverge independently" + (let [sibling (sci/fork parent)] + (is (= 1 (sci/eval-string* sibling "(bump!)"))) + (is (= [1 10 1 1 20] (sci/eval-string* sibling "(world-value)"))) + (is (= [2 10 1 1 21] (sci/eval-string* child "(world-value)"))) + (is (= [1 10 0 0 20] (sci/eval-string* parent "(world-value)")))))))) + +(deftest first-fork-realizes-mutable-primary-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(def x 1) + (def a (atom 0)) + (def v (volatile! 0)) + (defn state [] [x @a @v (:forked (meta #'x))]) + (def x 2) + (reset! a 5) + (vreset! v 9) + (alter-meta! #'x assoc :forked true)") + (let [child (sci/fork parent)] + (is (= [2 5 9 true] (sci/eval-string* child "(state)"))) + (sci/eval-string* + parent + "(def x 3) + (swap! a inc) + (vswap! v inc) + (alter-meta! #'x assoc :forked false)") + (is (= [3 6 10 false] (sci/eval-string* parent "(state)"))) + (is (= [2 5 9 true] (sci/eval-string* child "(state)"))) + (let [grandchild (sci/fork child)] + (sci/eval-string* child + "(alter-var-root #'x (constantly 4)) + (reset! a 7) + (vreset! v 11)") + (is (= [4 7 11 true] (sci/eval-string* child "(state)"))) + (is (= [2 5 9 true] (sci/eval-string* grandchild "(state)"))))))) + +#?(:clj + (deftest fork-host-value-cooperation-test + (let [user-ns (sci/create-ns 'user) + state-var (sci/new-var 'state (atom 0) {:ns user-ns}) + parent (sci/init + {:namespaces {'user {'state state-var}} + :fork-fn #(if (instance? clojure.lang.Atom %) + (atom @%) + %)})] + (sci/eval-string* parent "(defn bump-host! [] (swap! state inc))") + (let [child (sci/fork parent)] + (is (= 1 (sci/eval-string* child "(bump-host!)"))) + (is (= 0 (sci/eval-string* parent "@state"))) + (is (= 1 (sci/eval-string* child "@state"))))))) + (defmacro do-twice [x] `(do ~x ~x)) (defn ^:sci/macro do-twice* [_ _ x] `(do ~x ~x)) (def ^:dynamic *foo* 1) @@ -1662,7 +1740,11 @@ (let [C (atom (sci/init {:namespaces {'n {'foo 1}}}))] (is (= 1 (sci/eval-form @C 'n/foo))) (swap! C sci/merge-opts {:namespaces {'n {'foo 2}}}) - (is (= 2 (sci/eval-form @C 'n/foo))))) + (is (= 2 (sci/eval-form @C 'n/foo))) + (let [forked (sci/fork @C)] + (swap! C sci/merge-opts {:namespaces {'n {'foo 3}}}) + (is (= 3 (sci/eval-form @C 'n/foo))) + (is (= 2 (sci/eval-form forked 'n/foo)))))) (deftest merge-opts-preserves-features-test (let [ctx (sci/init {:features #{:cljs}})] From e78db9f9980d71aece919f86c7b9599820bb66cb Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 00:17:46 -0700 Subject: [PATCH 02/31] Use dense slots for forked SCI worlds --- README.md | 5 + doc/forking.md | 32 ++- src/sci/core.cljc | 8 +- src/sci/impl/analyzer.cljc | 27 +- src/sci/impl/core_protocols.cljc | 42 +-- src/sci/impl/jit.cljs | 46 ++-- src/sci/impl/namespaces.cljc | 39 ++- src/sci/impl/opts.cljc | 6 +- src/sci/impl/vars.cljc | 1 + src/sci/impl/world.cljc | 421 ++++++++++++++++++++----------- src/sci/lang.cljc | 14 +- test/sci/core_test.cljc | 56 ++++ test/sci/jit_test.cljs | 19 +- 13 files changed, 487 insertions(+), 229 deletions(-) diff --git a/README.md b/README.md index a242cd54..77e8fb96 100644 --- a/README.md +++ b/README.md @@ -616,6 +616,11 @@ the Clojure REPL model; a fork snapshots root bindings, not a running control continuation. Stateful host objects not handled by `:fork-fn`, and mutable facilities not owned by SCI such as Java objects, remain shared. +Runtime state is stored in dense lineage-local slots. A fork copies those +slots, favoring the expected case where ordinary reads and writes are much +more frequent than forks. On the JVM a fork waits for active forms in its +source world, so the copied state is a quiescent snapshot. + See [Forkable SCI worlds](doc/forking.md) for the lifecycle, semantic boundary, and current limitations of this experimental model. diff --git a/doc/forking.md b/doc/forking.md index 9ebe4be0..bb348b15 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -6,11 +6,12 @@ part of that state. Existing Vars, refs, aliases, and interpreted functions keep their identity; their meaning is selected by the world in which code is evaluated. -This is deliberately a value/realization split. The forkable value is a pair -of persistent maps keyed by stable handles. The ordinary SCI context is the -fast mutable realization until its first fork. That fork materializes current -Var and ref values once and changes the original context to persistent -copy-on-write operation. Later forks are O(1) unless host copying is requested. +This is deliberately a value/realization split. Stable handles receive dense, +lineage-local integer slots. Each world realizes those slots in an array; a +fork briefly quiesces the source world and copies the array. Var reads in the +ordinary primary context keep their direct SCI realization, while descendants +select their fork-local slot. Stateful primitives update one slot at a time, +so unrelated atoms do not contend on a shared world root. This shape combines four useful precedents: @@ -30,11 +31,13 @@ This shape combines four useful precedents: - Dynamic binding frames remain thread/evaluation scoped. A fork snapshots root bindings; it does not capture a running continuation or binding frame. - Writes before the first fork have ordinary SCI/Clojure mutable behavior. - The first fork snapshots them. Writes after that point path-copy the selected - world's maps. -- Forking is intended to happen between evaluations. Concurrently mutating and - forking the same primary context does not currently promise a linearizable - snapshot. + The first fork materializes the primary values into dense slots; later + writes update the selected world's slots. +- On the JVM, evaluation of a form holds a shared permit for its world and a + fork takes the exclusive permit. A concurrent fork therefore waits for + active forms in that source world and gets a quiescent snapshot. Different + worlds have independent gates. Calling `fork` recursively from inside an + evaluation of that same world is rejected instead of deadlocking. ## Host cooperation @@ -55,7 +58,8 @@ outside SCI remain shared unless the embedding application models or copies them. A complete effect inventory and an explicit fork protocol are the next step before describing an interpreter as fully forkable. -The primary performance cost that remains is selecting the active world on -each world-sensitive operation. A custom persistent collection could improve -branched writes, but it would not remove that dispatch cost; optimizing the -world-selection/call-site path should come first. +Forking is O(number of allocated slots), including spare array capacity, while +slot reads and writes are constant time. This intentionally favors the common +case where reads and mutations greatly outnumber forks. A page-level +copy-on-write representation remains a possible next step if workloads with +large worlds and frequent forks justify its extra read/write indirection. diff --git a/src/sci/core.cljc b/src/sci/core.cljc index b45a88c2..0972b802 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -339,16 +339,13 @@ #(if (utils/var? %) (vars/getRawRoot %) (c/deref %)) - meta) - _ (vreset! (get-in ctx [:sci.impl/read-world :persistent?]) true)] + meta)] (assoc ctx :env (atom @(:env ctx)) :fork-fn fork-fn :sci.impl/primary? false :sci.impl/world forked-world - :sci.impl/read-world {:world forked-world - :primary? false - :persistent? (volatile! true)})))) + :sci.impl/read-world (world/read-world forked-world false))))) (defn eval-string* "Evaluates string `s` in the context of `ctx` (as produced with @@ -686,7 +683,6 @@ ctx #(doseq [[_ v] ns-map :when (and (utils/var? v) - (not (:sci/built-in (meta v))) (not (world/registered? (:sci.impl/world ctx) v)))] (world/register-var! v (vars/getRawRoot v) (meta v))))) ctx) diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index 9fcb48ac..cca44975 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -25,6 +25,7 @@ [ana-macros constant? macro? rethrow-with-location-of-node set-namespace! recur special-syms]] [sci.impl.vars :as vars] + [sci.impl.world :as world] [sci.lang :as lang]) #?(:cljs (:require-macros @@ -2150,7 +2151,10 @@ :cljs (when (utils/var? f) (fn [_ _ v] (deref v))) :clj nil))] #?(:cljs (cond (utils/var? f) - (t/attach-ast node [:call-var f children stack]) + (if-let [slot (when-not (:dynamic f-meta) + (world/slot-of (:sci.impl/world ctx) f))] + (t/attach-ast node [:call-vslot [f slot] children stack]) + (t/attach-ast node [:call-var f children stack])) (fn? f) (t/attach-ast node [:call-direct f children stack]) :else node) @@ -2350,13 +2354,20 @@ (str "Can't take value of a macro: " v "")) :cljs (new js/Error (str "Can't take value of a macro: " v "")))) - (sci.impl.types/->Node - (faster/deref-1 v) - nil - ;; value-position var read: emitted as a - ;; plain deref, never cached (see the - ;; retention note on the deref cache) - [:vderef v]))) + (let [slot (when-not (:dynamic mv) + (world/slot-of (:sci.impl/world ctx) v))] + (sci.impl.types/->Node + #?(:clj (faster/deref-1 v) + :default (if (some? slot) + (vars/getRootAt v slot) + (faster/deref-1 v))) + nil + ;; Dynamic Vars retain binding-frame + ;; lookup. Other registered Vars resolve + ;; their dense lineage slot once here. + (if (some? slot) + [:vslot slot v] + [:vderef v]))))) #?@(:clj [(:sci.impl.analyzer/interop mv) (analyze-interop ctx expr v)]) diff --git a/src/sci/impl/core_protocols.cljc b/src/sci/impl/core_protocols.cljc index 25368335..be582290 100644 --- a/src/sci/impl/core_protocols.cljc +++ b/src/sci/impl/core_protocols.cljc @@ -15,10 +15,11 @@ ;;;; IDeref +(def ^:private untracked-value + #?(:cljd (Object.) :clj (Object.) :cljs (js/Object.))) + (defn- tracked-value [x] - (if (world/primary-world?) - (clojure.core/deref x) - (world/value x nil))) + (world/value x untracked-value)) ;; on cljd built-in multifns are SciMultiFns so records and reify can add ;; methods at runtime, host defmultis have no runtime add on Dart @@ -47,33 +48,36 @@ ;; world-relative routing before falling back to cljs.core/deref. #?(:cljd (defn deref* [x] - (if (and (world/mutable-primary-world?) (satisfies? IDeref x)) + (if (and (world/primary-world?) (satisfies? IDeref x)) (clojure.core/deref x) - (if (world/tracked? x) - (tracked-value x) - (if (satisfies? IDeref x) - (clojure.core/deref x) - (-deref x))))) + (let [v (tracked-value x)] + (if-not (identical? untracked-value v) + v + (if (satisfies? IDeref x) + (clojure.core/deref x) + (-deref x)))))) :clj (defn deref* ([x] - (if (and (world/mutable-primary-world?) + (if (and (world/primary-world?) (instance? clojure.lang.IDeref x)) (clojure.core/deref x) - (if (world/tracked? x) - (tracked-value x) - (if (instance? clojure.lang.IDeref x) - (clojure.core/deref x) - (deref x))))) + (let [v (tracked-value x)] + (if-not (identical? untracked-value v) + v + (if (instance? clojure.lang.IDeref x) + (clojure.core/deref x) + (deref x)))))) ([x & args] (apply clojure.core/deref x args))) :cljs (defn deref* [x] - (if (world/mutable-primary-world?) + (if (world/primary-world?) (clojure.core/deref x) - (if (world/tracked? x) - (tracked-value x) - (clojure.core/deref x))))) + (let [v (tracked-value x)] + (if-not (identical? untracked-value v) + v + (clojure.core/deref x)))))) (defn atom* "Creates an atom whose state is owned by the active SCI world. The host atom diff --git a/src/sci/impl/jit.cljs b/src/sci/impl/jit.cljs index c3e77c5c..d5c86b2e 100644 --- a/src/sci/impl/jit.cljs +++ b/src/sci/impl/jit.cljs @@ -58,14 +58,14 @@ ;; the throwaway NodeR just carries the map to the Stack protocol). (def ^:private helpers (js-obj "d" deref + "v" (fn [_ctx slot v] + (vars/getRootAt v slot)) "ev" (fn [node ctx b] (t/eval node ctx b)) "s" utils/recur ;; stack nil/undefined (s=-1): no enclosing sited call in this ;; template, stay transparent like an interpreter node without a ;; catch (calls with nil stack maps never own a site, see ;; intern-stack!). - ;; g: the var-mutation epoch; call-var sites cache derefs on it - "g" vars/var-epoch ;; cs: case dispatch, the same structural map lookup as ;; eval-case; returns the branch index, -1 = default "cs" (fn [idx-map v] (get idx-map v -1)) @@ -106,8 +106,8 @@ ;; meaningfully). Implementations in `helpers` above. (def ^:private interpret "H.ev") ; interpreter escape (node, CTX, B) (def ^:private deref-var "H.d") ; var deref +(def ^:private read-var-slot "H.v") ; context + dense Var slot (def ^:private recur-sentinel "H.s") -(def ^:private mutation-epoch "H.g") ; var-mutation epoch array (def ^:private case-branch-index "H.cs") (def ^:private rethrow-located "H.re") ; template catch rethrow-with-location (def ^:private read-in-try "H.git") @@ -128,10 +128,12 @@ ;; [:recur [arg ...]] ;; [:or [child ...]] / [:and [child ...]] ;; [:call-direct f [arg ...] stack] f = known fn value -;; [:call-var var [arg ...] stack] deref cached on the epoch +;; [:call-var var [arg ...] stack] dynamic/unregistered Var deref +;; [:call-vslot [var slot] [arg ...] stack] dense world-relative deref ;; [:call-bind idx [arg ...] stack] callee = binding slot ;; [:call-node callee [arg ...] stack] callee = expression ;; [:vderef var] value-position var read +;; [:vslot slot var] dense value-position Var read ;; [:iget obj name stack] instance field ;; [:iset obj name val] instance field write ;; [:imeth obj name [arg ...] stack] instance method @@ -141,7 +143,7 @@ ;; [:mkfn mk capture-pairs enclosed-cnt] closure creation ;; [:try body catches finally sci-error] (defn- call-ast? [op] - (case op (:call-direct :call-var :call-bind :call-node) true false)) + (case op (:call-direct :call-var :call-vslot :call-bind :call-node) true false)) (defn ->ast "Resolve a child (node or constant) to a walkable AST vector." @@ -171,7 +173,7 @@ :let (and (every? escape-free? x2) (escape-free? x3)) :recur (every? escape-free? x1) (:or :and) (every? escape-free? x1) - (:call-direct :call-var :call-bind) (every? escape-free? x2) + (:call-direct :call-var :call-vslot :call-bind) (every? escape-free? x2) :call-node (and (escape-free? x1) (every? escape-free? x2)) :iget (escape-free? x1) :iset (and (escape-free? x1) (escape-free? x3)) @@ -183,7 +185,7 @@ :jsstatic (every? escape-free? x3) ;; closure creation reads captures straight from slots, needs no B :mkfn true - :vderef true + (:vderef :vslot) true ;; :try catch dispatch hands B to eval-catches false))) @@ -416,18 +418,12 @@ ;; .call(null, ...) is what the CLJS compiler emits for unknown ;; callees: works for fns, keywords, MetaFn (IFn types get .call) (let [head (case op - ;; per-call-site deref cache [val epoch], invalidated by - ;; the global var-mutation epoch: hot path is two array - ;; reads + compare instead of the full deref - :call-var (let [cache (const! st #js [nil -1]) - var-ref (const! st callee) - deref-tmp (tmp! st)] - (stmt! st "var " deref-tmp ";") - (stmt! st "if(" cache "[1]===" mutation-epoch "[0]){" deref-tmp "=" cache "[0];}else{" - deref-tmp "=" deref-var "(" var-ref ");" - cache "[0]=" deref-tmp ";" - cache "[1]=" mutation-epoch "[0];}") - deref-tmp) + ;; Dynamic Vars must consult the current binding frame. + ;; Avoid the old global-epoch cache here: a fork-local root + ;; mutation must not expose or retain another world's value. + :call-var (js-call deref-var (const! st callee)) + :call-vslot (let [[v slot] callee] + (js-call read-var-slot "CTX" slot (const! st v))) ;; callee = binding slot index :call-bind (spill st (slot st callee)) ;; computed callee ((add 1) 2): a full expression, itself @@ -435,8 +431,12 @@ :call-node (emit-arg st idx callee)) args (mapv #(emit-arg st idx %) children)] (if (and (= 2 n) - (keyword-identical? op :call-var) - (identical? (deref callee) protocols/instance-impl)) + (or (keyword-identical? op :call-var) + (keyword-identical? op :call-vslot)) + (identical? (deref (if (keyword-identical? op :call-vslot) + (first callee) + callee)) + protocols/instance-impl)) ;; instance-impl walks a cond (sci type, protocol map, ...) before ;; reaching the host check. Only a plain JS constructor takes that ;; last branch, and only those are typeof "function": sci types are @@ -630,6 +630,8 @@ ;; :call-var) so plain data in vars is not retained :vderef (let [[_ v] a] (js-call deref-var (const! st v))) + :vslot (let [[_ slot v] a] + (js-call read-var-slot "CTX" slot (const! st v))) ;; closure creation: build the enclosed array from this template's ;; own slots (static capture pairs) and hand it to mk, which reuses ;; make-fn — stubs, laziness and self-reference patching included. @@ -654,7 +656,7 @@ (if (fn? ctor) (str "new " (const! st ctor) "(" (join-args args) ")") (str "Reflect.construct(" (const! st ctor) ",[" (join-args args) "])"))) - (:call-direct :call-var :call-bind :call-node) (emit-call st amb a)))) + (:call-direct :call-var :call-vslot :call-bind :call-node) (emit-call st amb a)))) (defn- emit-tail [st amb x] (let [[op :as a] (->ast x)] diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 19bf6623..c22393f3 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -10,7 +10,7 @@ clojure-version print-method print-dup - #?(:cljs alter-meta!) + #?@(:cljs [alter-meta! reset-meta!]) memfn time exists? js-in]) @@ -51,6 +51,7 @@ [sci.impl.types :as types] [sci.impl.utils :as utils :refer [eval]] [sci.impl.vars :as vars] + [sci.impl.world :as world] [sci.lang]) #?(:cljs (:require-macros [sci.impl.copy-vars :refer [copy-var copy-core-var macrofy avoid-method-too-large]]))) @@ -1067,13 +1068,35 @@ f must be free of side-effects" [iref f & args] - (if (utils/sci-type? iref) - (types/setVal iref (apply f (types/getVal iref) args)) - (let [m (meta iref)] - (if-not (:sci/built-in m) - (apply cljs.core/alter-meta! iref f args) - (throw (ex-info (str "Built-in var " iref " is read-only.") - {:var iref}))))))) + (if (utils/var? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-var iref current-meta + (if (world/current-world) + (let [m (world/alter-var-meta! iref current-meta f args)] + (when (world/primary-world?) + (cljs.core/reset-meta! iref m)) + m) + (apply cljs.core/alter-meta! iref f args)))) + (if (utils/sci-type? iref) + (types/setVal iref (apply f (types/getVal iref) args)) + (let [m (meta iref)] + (if-not (:sci/built-in m) + (apply cljs.core/alter-meta! iref f args) + (throw (ex-info (str "Built-in var " iref " is read-only.") + {:var iref})))))))) + +#?(:cljs + (defn reset-meta! [iref m] + (if (utils/var? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-var iref current-meta + (if (world/current-world) + (do (world/reset-var-meta! iref m) + (when (world/primary-world?) + (cljs.core/reset-meta! iref m)) + m) + (cljs.core/reset-meta! iref m)))) + (cljs.core/reset-meta! iref m)))) (defn- let** [expr _ bindings & body] (when-not (vector? bindings) diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index f41fdbca..b3cb6b06 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -19,7 +19,6 @@ #(doseq [[_ ns-map] (:namespaces @(:env ctx)) [_ v] ns-map :when (and (utils/var? v) - (not (:sci/built-in (meta v))) (not (world/registered? (:sci.impl/world ctx) v)))] (world/register-var! v (vars/getRawRoot v) (meta v)))))) @@ -277,7 +276,6 @@ _ (init-env! env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) world-root (world/new-world) - persistent-world? (volatile! false) ctx (assoc (->ctx {} env features readers (or allow deny) :interrupt-fn interrupt-fn) :allow (when allow (process-permissions #{} allow)) @@ -288,9 +286,7 @@ :unrestricted unrestricted :fork-fn fork-fn :sci.impl/world world-root - :sci.impl/read-world {:world world-root - :primary? true - :persistent? persistent-world?} + :sci.impl/read-world (world/read-world world-root true) :sci.impl/lineage (atom nil) :sci.impl/primary? true #?@(:clj [:main-thread-id (.getId (Thread/currentThread))]))] diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index 471ac923..57fef9bc 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -99,6 +99,7 @@ (defprotocol IVar (bindRoot [this v]) (getRawRoot [this]) + (getRootAt [this slot]) (toSymbol [this]) (isMacro [this]) (hasRoot [this]) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index d4d4ebd6..8b2e2983 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -1,18 +1,87 @@ (ns sci.impl.world - "Fork-local runtime state for SCI contexts. + "Dense, fork-local runtime state for SCI contexts. - A world is a persistent value behind an atom. Stable handles (SCI Vars and - SCI-created mutable primitives) are keys into that value. Forks copy the - persistent value into a fresh atom, preserving identity and aliasing while - isolating subsequent writes." - (:require [sci.ctx-store :as store])) + Stable handles are assigned integer slots once per context lineage. A world + stores slot values densely and a frozen fork copies that array while the + source world is quiescent. Mutable primitives CAS only their own slot, so + unrelated atoms never contend on a shared world root." + (:require [sci.ctx-store :as store]) + #?(:clj (:import [java.util.concurrent.atomic AtomicReferenceArray] + [java.util.concurrent.locks ReentrantReadWriteLock]))) + +(def absent #?(:cljd (Object.) :clj (Object.) :cljs (js/Object.))) + +(deftype DenseWorld [cells-holder registry gate persistent?]) +(deftype ReadWorld [world primary?]) + +(defn read-world [world primary?] + (ReadWorld. world primary?)) + +(defn- new-cells [n] + #?(:clj + (let [a (AtomicReferenceArray. (int n))] + (dotimes [i n] (.set a i absent)) + a) + :cljs + (let [a (object-array n)] + (dotimes [i n] (aset a i absent)) + a) + :cljd + (#/(List/filled dynamic) n absent))) + +(defn- cells-length [cells] + #?(:clj (.length ^AtomicReferenceArray cells) + :cljs (alength cells) + :cljd (.-length ^List cells))) + +(defn- cells-get [cells slot] + #?(:clj (.get ^AtomicReferenceArray cells (int slot)) + :cljs (aget cells slot) + :cljd (aget ^List cells slot))) + +(defn- cells-set! [cells slot value] + #?(:clj (.set ^AtomicReferenceArray cells (int slot) value) + :cljs (aset cells slot value) + :cljd (aset ^List cells slot value)) + value) + +(defn- cells-cas! [cells slot old new] + #?(:clj (.compareAndSet ^AtomicReferenceArray cells (int slot) old new) + :default + (if (identical? old (cells-get cells slot)) + (do (cells-set! cells slot new) true) + false))) + +(defn- current-cells [^DenseWorld world] + @(.-cells-holder world)) + +(defn- with-registry-lock [registry f] + #?(:clj (locking registry (f)) + :default (f))) + +(defn- ensure-capacity! [^DenseWorld world required] + (let [holder (.-cells-holder world)] + (when (> required (cells-length @holder)) + (with-registry-lock + holder + (fn [] + (let [old @holder + old-n (cells-length old)] + (when (> required old-n) + (let [new-n (loop [n (max 16 old-n)] + (if (>= n required) n (recur (* 2 n)))) + new (new-cells new-n)] + (dotimes [i old-n] + (cells-set! new i (cells-get old i))) + (vreset! holder new)))))))) + world) (defn new-world [] - (atom {:values {} - :var-meta {} - ;; Before the first fork, the primary context behaves like ordinary - ;; mutable SCI. The first fork realizes a persistent snapshot. - :persistent? false})) + (DenseWorld. + (volatile! (new-cells 64)) + (atom {:next-slot 0 :descriptors {}}) + #?(:clj (ReentrantReadWriteLock.) :default nil) + (volatile! false))) #?(:clj (def ^ThreadLocal active-world @@ -25,10 +94,7 @@ #?(:clj (.get ^ThreadLocal active-world) :default @active-world)) -(defn with-active-world - "Run `f` with the context's read realization installed. Primary contexts use - direct Var/host-ref fields; descendants use their persistent world value." - [ctx f] +(defn- call-with-active-world [ctx f] (let [previous (active-world-state) active (:sci.impl/read-world ctx)] #?(:clj (.set ^ThreadLocal active-world active) @@ -41,137 +107,199 @@ (.set ^ThreadLocal active-world previous)) :default (vreset! active-world previous)))))) +(defn with-active-world + "Run `f` with the context's world installed. On the JVM evaluations take a + shared gate permit; a fork takes the exclusive permit and therefore observes + a quiescent source world without adding locks to individual reads." + [ctx f] + #?(:clj + (let [^DenseWorld world (:sci.impl/world ctx) + lock (.readLock ^ReentrantReadWriteLock (.-gate world))] + (.lock lock) + (try + (call-with-active-world ctx f) + (finally (.unlock lock)))) + :default + (call-with-active-world ctx f))) + (defn current-world [] (:sci.impl/world store/*ctx*)) +(defn- descriptor [^DenseWorld world handle] + (get-in @(.-registry world) [:descriptors handle])) + +(defn slot-of + "Return the value slot assigned to `handle`, or nil when it is not registered + in this lineage. Intended for analyzer-time resolution." + [world handle] + (:value-slot (descriptor world handle))) + +(defn- present-slot? [^DenseWorld world slot] + (and (some? slot) + (< slot (cells-length (current-cells world))) + (not (identical? absent (cells-get (current-cells world) slot))))) + (defn registered? [world handle] - (contains? (:values @world) handle)) + (when-let [desc (descriptor world handle)] + (present-slot? world (:value-slot desc)))) (defn primary-world? [] (let [active (active-world-state)] (if active - (:primary? active) + (.-primary? ^ReadWorld active) (true? (:sci.impl/primary? store/*ctx*))))) (defn mutable-primary-world? [] (let [active (active-world-state)] - (and (:primary? active) - (not @(:persistent? active))))) + (and active + (.-primary? ^ReadWorld active) + (not @(.-persistent? ^DenseWorld (.-world ^ReadWorld active)))))) -(defn tracked? - [handle] - (when-let [world (:world (active-world-state))] - (contains? (:values @world) handle))) +(defn tracked? [handle] + (when-let [^ReadWorld active (active-world-state)] + (registered? (.-world active) handle))) -(defn value - [handle fallback] - (if-let [world (:world (active-world-state))] - (get-in @world [:values handle] fallback) +(defn- slot-value [^DenseWorld world slot fallback] + (if (nil? slot) + fallback + (let [cells (current-cells world)] + (if (>= slot (cells-length cells)) + fallback + (let [v (cells-get cells slot)] + (if (identical? absent v) fallback v)))))) + +(defn value [handle fallback] + (if-let [^ReadWorld active (active-world-state)] + (let [world (.-world active)] + (slot-value world (:value-slot (descriptor world handle)) fallback)) fallback)) +(defn var-value-at + "Read a Var through a slot already resolved by the analyzer." + [slot fallback] + (let [^ReadWorld active (active-world-state)] + (if (or (nil? active) (.-primary? active)) + fallback + (slot-value (.-world active) slot fallback)))) + (defn var-value - "Primary contexts keep the Var's ordinary mutable root synchronized, which - preserves the Clojure/SCI fast path. Descendants resolve through the world." + "Primary contexts retain their direct Var realization. Descendants resolve + the stable Var handle through its dense lineage slot." [handle fallback] (let [active (active-world-state)] - (if (or (nil? active) (:primary? active)) + (if (or (nil? active) (.-primary? ^ReadWorld active)) fallback - (get-in @(:world active) [:values handle] fallback)))) + (let [world (.-world ^ReadWorld active)] + (slot-value world (:value-slot (descriptor world handle)) fallback))))) -(defn var-meta - [handle fallback] +(defn var-meta [handle fallback] (let [active (active-world-state)] - (if (or (nil? active) (:primary? active)) + (if (or (nil? active) (.-primary? ^ReadWorld active)) fallback - (get-in @(:world active) [:var-meta handle] fallback)))) + (let [world (.-world ^ReadWorld active)] + (slot-value world (:meta-slot (descriptor world handle)) fallback))))) -(defn register! - [handle value] - (when-let [world (current-world)] - (swap! world assoc-in [:values handle] value)) +(defn- allocate-descriptor! [^DenseWorld world handle kind host-fork?] + (let [registry (.-registry world)] + (with-registry-lock + registry + (fn [] + (if-let [desc (get-in @registry [:descriptors handle])] + desc + (let [start (:next-slot @registry) + width (if (= :var kind) 2 1) + desc (cond-> {:kind kind + :value-slot start + :host-fork? host-fork?} + (= :var kind) (assoc :meta-slot (inc start)))] + (swap! registry + (fn [r] + (-> r + (assoc :next-slot (+ start width)) + (assoc-in [:descriptors handle] desc)))) + desc)))))) + +(defn register! [handle value] + (when-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} (allocate-descriptor! world handle :ref true)] + (ensure-capacity! world (inc value-slot)) + (cells-set! (current-cells world) value-slot value))) handle) -(defn register-var! - [handle value m] - (when-let [world (current-world)] - (let [state @world] - (when-not (and (primary-world?) - (not (:persistent? state)) - (contains? (:var-meta state) handle)) - (swap! world (fn [state] - (-> state - (assoc-in [:values handle] value) - (assoc-in [:var-meta handle] m))))))) +(defn register-var! [handle value m] + (when-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot meta-slot]} + (allocate-descriptor! world handle :var (not (:sci/built-in m)))] + (ensure-capacity! world (inc meta-slot)) + (let [cells (current-cells world)] + (cells-set! cells value-slot value) + (cells-set! cells meta-slot m)))) handle) -(defn- mutable-primary-state? [state] - (and (primary-world?) (not (:persistent? state)))) +(defn- reset-slot! [^DenseWorld world slot value] + (if (nil? slot) + ::no-world + (do + (ensure-capacity! world (inc slot)) + (cells-set! (current-cells world) slot value)))) -(defn reset-value! - [handle value] +(defn reset-value! [handle value] (if-let [world (current-world)] - (do (let [state @world] - (when-not (and (mutable-primary-state? state) - (contains? (:values state) handle)) - (swap! world assoc-in [:values handle] value))) - value) + (reset-slot! world (:value-slot (descriptor world handle)) value) ::no-world)) -(defn reset-var-meta! - [handle m] - (if-let [world (current-world)] - (do (let [state @world] - (when-not (and (mutable-primary-state? state) - (contains? (:var-meta state) handle)) - (swap! world assoc-in [:var-meta handle] m))) - m) +(defn reset-var-meta! [handle m] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [meta-slot]} (or (descriptor world handle) + (allocate-descriptor! world handle :var + (not (:sci/built-in m))))] + (reset-slot! world meta-slot m)) ::no-world)) -(defn alter-var-meta! - [handle fallback f args] - (if-let [world (current-world)] - (let [state @world] - (if (mutable-primary-state? state) - (apply f fallback args) - (get-in (swap! world update-in [:var-meta handle] - (fn [m] - (apply f (if (nil? m) fallback m) args))) - [:var-meta handle]))) +(defn alter-var-meta! [handle fallback f args] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [meta-slot]} (or (descriptor world handle) + (allocate-descriptor! world handle :var + (not (:sci/built-in fallback))))] + (ensure-capacity! world (inc meta-slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells meta-slot) + old (if (identical? absent raw-old) fallback raw-old) + new (apply f old args)] + (if (cells-cas! cells meta-slot raw-old new) new (recur))))) ::no-world)) (defn swap-value! - "Atomically update a tracked handle. `validate!` runs before the CAS and - `notify!` once after a successful transition. Returns the new value." + "Atomically update one tracked slot. Unrelated SCI atoms do not contend and + cannot cause `f` to be retried." [handle f args validate! notify!] - (let [world (current-world)] + (let [^DenseWorld world (current-world) + slot (:value-slot (descriptor world handle))] (loop [] - (let [state @world - old (get-in state [:values handle]) + (let [cells (current-cells world) + old (cells-get cells slot) new (apply f old args)] (validate! new) - (if (compare-and-set! world state (assoc-in state [:values handle] new)) - (do (notify! old new) - new) + (if (cells-cas! cells slot old new) + (do (notify! old new) new) (recur)))))) -(defn reset-tracked! - [handle new validate! notify!] +(defn reset-tracked! [handle new validate! notify!] (swap-value! handle (constantly new) nil validate! notify!)) -(defn compare-and-set-tracked! - [handle expected new validate! notify!] - (let [world (current-world)] - (loop [] - (let [state @world - old (get-in state [:values handle])] - (if-not (identical? expected old) - false - (do - (validate! new) - (if (compare-and-set! world state (assoc-in state [:values handle] new)) - (do (notify! old new) - true) - (recur)))))))) +(defn compare-and-set-tracked! [handle expected new validate! notify!] + (let [^DenseWorld world (current-world) + slot (:value-slot (descriptor world handle)) + cells (current-cells world) + old (cells-get cells slot)] + (if-not (identical? expected old) + false + (do + (validate! new) + (if (cells-cas! cells slot old new) + (do (notify! old new) true) + false))))) (defn active-ctx "Use the currently evaluating descendant context for an interpreted closure. @@ -184,44 +312,53 @@ active captured))) -(defn fork-world - [world fork-value snapshot-value snapshot-var-meta] - (let [realize (fn [] - (let [state @world] - (if (:persistent? state) - state - (let [handles (keys (:values state)) - vars (keys (:var-meta state)) - realized (-> state - (assoc :persistent? true) - (update :values - (fn [values] - (reduce (fn [ret handle] - (assoc ret handle (snapshot-value handle))) - values handles))) - (update :var-meta - (fn [metas] - (reduce (fn [ret v] - (assoc ret v (snapshot-var-meta v))) - metas vars))))] - (reset! world realized) - realized)))) - state #?(:clj (locking world (realize)) - :default (realize))] - ;; Without a host copier, forking is only a new mutable tip over the same - ;; persistent value. The first write in either branch creates divergence. - (if-not fork-value - (atom state) - (let [handles (set (keys (:values state)))] - (atom - (update state :values - (fn [values] - (reduce-kv - (fn [ret handle v] - ;; World-relative handles must retain identity. Other - ;; values cross the explicit cooperation boundary. - (assoc ret handle (if (contains? handles v) - v - (fork-value v)))) - (empty values) - values)))))))) +(defn- realize-primary! [^DenseWorld world snapshot-value snapshot-var-meta] + (when-not @(.-persistent? world) + (doseq [[handle {:keys [kind value-slot meta-slot]}] + (:descriptors @(.-registry world))] + (when (present-slot? world value-slot) + (cells-set! (current-cells world) value-slot (snapshot-value handle)) + (when (= :var kind) + (cells-set! (current-cells world) meta-slot (snapshot-var-meta handle))))) + (vreset! (.-persistent? world) true)) + world) + +(defn- copy-world [^DenseWorld world fork-value] + (let [source (current-cells world) + n (cells-length source) + target (new-cells n) + registry (.-registry world) + descriptors (:descriptors @registry) + handles (set (keys descriptors))] + (dotimes [i n] + (cells-set! target i (cells-get source i))) + (when fork-value + (doseq [[_ {:keys [value-slot host-fork?]}] descriptors + :when host-fork? + :when (< value-slot n) + :let [v (cells-get target value-slot)] + :when (not (identical? absent v))] + (cells-set! target value-slot + (if (contains? handles v) v (fork-value v))))) + (DenseWorld. + (volatile! target) + registry + #?(:clj (ReentrantReadWriteLock.) :default nil) + (volatile! true)))) + +(defn fork-world [^DenseWorld world fork-value snapshot-value snapshot-var-meta] + #?(:clj + (let [^ReentrantReadWriteLock gate (.-gate world)] + (when (pos? (.getReadHoldCount gate)) + (throw (IllegalStateException. + "Cannot fork a SCI world from inside its active evaluation; suspend it first."))) + (let [lock (.writeLock gate)] + (.lock lock) + (try + (realize-primary! world snapshot-value snapshot-var-meta) + (copy-world world fork-value) + (finally (.unlock lock))))) + :default + (do + (realize-primary! world snapshot-value snapshot-var-meta) + (copy-world world fork-value)))) diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index 7d61f78a..6cf0ea9f 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -109,6 +109,15 @@ v) (getRawRoot [this] (world/var-value this root)) + (getRootAt [this slot] + ;; A Var can be marked ^:dynamic after this read site was analyzed. Keep + ;; the same late binding-frame check as deref while retaining the resolved + ;; root slot for the common non-dynamic case. + (if thread-bound + (if-let [tbox (vars/get-thread-binding this)] + (types/getVal tbox) + (world/var-value-at slot root)) + (world/var-value-at slot root))) (toSymbol [this] ;; if we have at least a name from metadata, then build the symbol from that (let [current-meta (world/var-meta this meta)] @@ -130,7 +139,10 @@ (vars/with-writeable-var this current-meta (if (world/current-world) (let [unbound (vars/->SciUnbound this)] - (world/reset-value! this unbound) + ;; A newly interned Var has no slot yet, especially in a child + ;; world. Registering here preserves unboundness without mutating + ;; the shared direct root. + (world/register-var! this unbound current-meta) (when (world/primary-world?) (vars/bumping-set! (.-root this) unbound))) (vars/bumping-set! (.-root this) (vars/->SciUnbound this)))))) diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 3a9044e9..5c4085cd 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1410,7 +1410,9 @@ (def counter (atom 0)) (def counter-alias counter) (def scratch (volatile! 20)) + (def late-dynamic 30) (defn world-value [] [x *x* @counter @counter-alias @scratch]) + (defn read-late-dynamic [] late-dynamic) (defn bump! [] (swap! counter inc)) (defn scratch! [] (vswap! scratch inc))") (let [child (sci/fork parent)] @@ -1427,6 +1429,24 @@ (testing "existing vars, captured functions, bindings, atoms, and volatiles isolate" (is (= [1 10 0 0 20] (sci/eval-string* parent "(world-value)"))) (is (= [2 10 1 1 21] (sci/eval-string* child "(world-value)")))) + (testing "a Var made dynamic after analysis still observes its binding frame" + (is (= 31 (sci/eval-string* + child + "(alter-meta! #'late-dynamic assoc :dynamic true) + (binding [late-dynamic 31] (read-late-dynamic))"))) + (is (= 30 (sci/eval-string* parent "(read-late-dynamic)"))) + (is (true? (sci/eval-string* + child + "(reset-meta! #'late-dynamic + (assoc (meta #'late-dynamic) :reset true)) + (:reset (meta #'late-dynamic))"))) + (is (nil? (sci/eval-string* parent "(:reset (meta #'late-dynamic))")))) + (testing "new unbound Vars belong to the child world" + (is (false? (sci/eval-string* child "(declare child-only) (bound? #'child-only)"))) + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error) + #"Unable to resolve symbol: child-only" + (sci/eval-string* parent "child-only")))) (testing "forks from the same basis diverge independently" (let [sibling (sci/fork parent)] (is (= 1 (sci/eval-string* sibling "(bump!)"))) @@ -1479,6 +1499,42 @@ (is (= 0 (sci/eval-string* parent "@state"))) (is (= 1 (sci/eval-string* child "@state"))))))) +#?(:clj + (deftest fork-waits-for-active-evaluation-test + (let [entered (promise) + release (promise) + parent (sci/init {:bindings {'block! (fn [] + (deliver entered true) + @release)}}) + evaluation (future (sci/eval-string* parent "(block!)"))] + (is (= true (deref entered 1000 ::timeout))) + (let [forking (future (sci/fork parent))] + (is (= ::waiting (deref forking 50 ::waiting))) + (deliver release true) + (is (= true (deref evaluation 1000 ::timeout))) + (is (map? (deref forking 1000 ::timeout))))))) + +#?(:clj + (deftest independent-world-slots-do-not-retry-test + (let [n 1000 + a-calls (atom 0) + b-calls (atom 0) + parent (sci/init + {:bindings + {'step-a (fn [x] (swap! a-calls inc) (inc x)) + 'step-b (fn [x] (swap! b-calls inc) (inc x))}})] + (sci/eval-string* parent "(def a (atom 0)) (def b (atom 0))") + (let [a-run (future (sci/eval-string* + parent + (str "(dotimes [_ " n "] (swap! a step-a))"))) + b-run (future (sci/eval-string* + parent + (str "(dotimes [_ " n "] (swap! b step-b))")))] + (is (nil? (deref a-run 5000 ::timeout))) + (is (nil? (deref b-run 5000 ::timeout))) + (is (= [n n] [@a-calls @b-calls])) + (is (= [n n] (sci/eval-string* parent "[@a @b]"))))))) + (defmacro do-twice [x] `(do ~x ~x)) (defn ^:sci/macro do-twice* [_ _ x] `(do ~x ~x)) (def ^:dynamic *foo* 1) diff --git a/test/sci/jit_test.cljs b/test/sci/jit_test.cljs index 0b3861ee..3a053f76 100644 --- a/test/sci/jit_test.cljs +++ b/test/sci/jit_test.cljs @@ -248,10 +248,9 @@ (is (= interp jitted) src)))) (deftest jit-var-mutation-visibility-test - ;; BOTH modes cache var derefs keyed on sci.impl.vars/var-epoch, so - ;; interp/jit agreement alone can't catch a missed bump — each case - ;; asserts the literal expected value. Every public mutation path must - ;; be immediately visible through a warm call site. + ;; Each case asserts the literal expected value so interp/jit agreement + ;; alone cannot hide a stale warm call site. Every public mutation path + ;; must be immediately visible. (doseq [[expected src] [["[1 2]" "(defn f [] 1) (defn call [] (f)) (def before (call)) (defn f [] 2) [before (call)]"] ["[1 2]" "(defn f [] 1) (defn call [] (f)) (def before (call)) (alter-var-root #'f (constantly (fn [] 2))) [before (call)]"] @@ -262,6 +261,18 @@ (is (= {:val expected} interp) src) (is (= {:val expected} jitted) src)))) +(deftest jit-fork-world-test + (let [parent (sci/init {})] + (sci/eval-string* + parent + "(def x 1) (defn f [] 1) (defn call [] [(f) x])") + ;; Warm the generated call-var and value-position Var paths before fork. + (is (= [1 1] (sci/eval-string* parent "(call)"))) + (let [child (sci/fork parent)] + (sci/eval-string* child "(def x 2) (defn f [] 2)") + (is (= [2 2] (sci/eval-string* child "(call)"))) + (is (= [1 1] (sci/eval-string* parent "(call)")))))) + (deftest jit-interop-member-name-emission-test ;; interop member names are interpolated into generated JS source as a ;; JSON.stringify'd string literal, not a bare identifier, so a name that From 5e8617d31fe67108b9484ab736fbe71e61edfb44 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 00:50:24 -0700 Subject: [PATCH 03/31] Optimize forked Var reads through dense slots --- src/sci/impl/analyzer.cljc | 45 ++++++++++++++++++++++++++++---------- src/sci/impl/vars.cljc | 2 ++ src/sci/lang.cljc | 12 ++++++++++ 3 files changed, 47 insertions(+), 12 deletions(-) diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index cca44975..16f9b261 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -55,6 +55,22 @@ (declare analyze analyze-children analyze-call return-call return-map) +#?(:clj + (deftype VarNode [^sci.impl.vars.IVar v + ^int slot] + sci.impl.types/Eval + (eval [_ _ctx _bindings] + (let [^sci.impl.world.ReadWorld active + (.get ^ThreadLocal world/active-world)] + (if (or (nil? active) (.-primary? active)) + (.getDirectRoot v) + (let [^sci.impl.world.DenseWorld world (.-world active) + ^java.util.concurrent.atomic.AtomicReferenceArray cells + @(.-cells-holder world)] + (.selectRoot v (.get cells slot)))))) + sci.impl.types/Stack + (stack [_] nil))) + ;;;; Constant children ;; A constant child carries its value at analysis time, so a consumer can read @@ -2356,18 +2372,23 @@ (str "Can't take value of a macro: " v "")))) (let [slot (when-not (:dynamic mv) (world/slot-of (:sci.impl/world ctx) v))] - (sci.impl.types/->Node - #?(:clj (faster/deref-1 v) - :default (if (some? slot) - (vars/getRootAt v slot) - (faster/deref-1 v))) - nil - ;; Dynamic Vars retain binding-frame - ;; lookup. Other registered Vars resolve - ;; their dense lineage slot once here. - (if (some? slot) - [:vslot slot v] - [:vderef v]))))) + #?(:clj + (if (some? slot) + (VarNode. v (int slot)) + (sci.impl.types/->Node + (faster/deref-1 v) nil)) + :default + (sci.impl.types/->Node + (if (some? slot) + (vars/getRootAt v slot) + (faster/deref-1 v)) + nil + ;; Dynamic Vars retain binding-frame + ;; lookup. Other registered Vars resolve + ;; their dense lineage slot once here. + (if (some? slot) + [:vslot slot v] + [:vderef v])))))) #?@(:clj [(:sci.impl.analyzer/interop mv) (analyze-interop ctx expr v)]) diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index 57fef9bc..dac7f840 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -99,6 +99,8 @@ (defprotocol IVar (bindRoot [this v]) (getRawRoot [this]) + (getDirectRoot [this]) + (selectRoot [this world-value]) (getRootAt [this slot]) (toSymbol [this]) (isMacro [this]) diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index 6cf0ea9f..c71e198b 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -109,6 +109,18 @@ v) (getRawRoot [this] (world/var-value this root)) + (getDirectRoot [this] + (if thread-bound + (if-let [tbox (vars/get-thread-binding this)] + (types/getVal tbox) + root) + root)) + (selectRoot [this world-value] + (if thread-bound + (if-let [tbox (vars/get-thread-binding this)] + (types/getVal tbox) + world-value) + world-value)) (getRootAt [this slot] ;; A Var can be marked ^:dynamic after this read site was analyzed. Keep ;; the same late binding-frame check as deref while retaining the resolved From 09f11740b5e153746587886b5d1f195946312e96 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 01:14:24 -0700 Subject: [PATCH 04/31] Add host fork capability protocol --- README.md | 9 ++++-- doc/forking.md | 28 ++++++++++++++---- src/sci/core.cljc | 14 +++++---- src/sci/fork.cljc | 64 +++++++++++++++++++++++++++++++++++++++++ test/sci/core_test.cljc | 54 ++++++++++++++++++++++++++++++++++ 5 files changed, 155 insertions(+), 14 deletions(-) create mode 100644 src/sci/fork.cljc diff --git a/README.md b/README.md index 77e8fb96..f89f75a4 100644 --- a/README.md +++ b/README.md @@ -600,9 +600,12 @@ world in which they are invoked: ``` Values supplied by the host remain the host application's responsibility. An -optional `:fork-fn` can copy such values as they cross into a fork. It should -return immutable values unchanged and preserve any aliasing that matters to -the application (for example, by memoizing copies by identity): +application-owned type can implement `sci.fork/Forkable`; SCI invokes its +`fork-value` method once per identical value in each fork and preserves aliases +to the resulting copy. Returning the object itself explicitly shares it, while +throwing rejects the fork. For unclassified values, the optional `:fork-fn` +remains a general fallback. It should return immutable values unchanged and +preserve any aliasing that matters to the application: ``` clojure (def sci-ctx diff --git a/doc/forking.md b/doc/forking.md index bb348b15..335280be 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -41,12 +41,28 @@ This shape combines four useful precedents: ## Host cooperation -SCI cannot infer how arbitrary host objects should branch. `sci/init` and the -two-argument `sci/fork` accept `:fork-fn`, a one-argument function applied to -values stored in world cells. It may copy application-owned state and should -return immutable values unchanged. If multiple values alias the same host -object, the function must preserve that relationship when it matters, for -example with an identity-keyed memo table. +SCI cannot infer how arbitrary host objects should branch. Host types can +implement `sci.fork/Forkable`; its `fork-value` method determines the value +stored in the child world. SCI calls the method once per identical value during +one fork and preserves aliases to its result. + +| Resource class | Fork behavior | +|---|---| +| Immutable or persistent value | Share it by returning `this`, or leave it unclassified | +| Duplicable application state | Return an independent copy from `fork-value` | +| Deliberately shared external resource | Return `this` | +| Affine or movable authority | Reject the non-destructive fork, or keep authority outside the SCI value world | +| Prohibited resource | Throw an explanatory exception from `fork-value` | + +Only values directly stored in world cells are inspected. A host container that +holds mutable children must implement the protocol and copy its own graph. +Unclassified values retain the compatibility behavior of being shared. + +`sci/init` and the two-argument `sci/fork` also accept `:fork-fn`, a legacy +one-argument fallback applied to unclassified values stored in world cells. It +may copy application-owned state and should return immutable values unchanged. +Unlike the protocol path, callback alias preservation remains the +application's responsibility, for example with an identity-keyed memo table. ## Current boundary diff --git a/src/sci/core.cljc b/src/sci/core.cljc index 0972b802..be541e3c 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -13,6 +13,7 @@ [edamame.core :as edamame] [edamame.impl.parser] [sci.ctx-store :as store] + [sci.fork :as fork] [sci.impl.callstack :as cs] [sci.impl.interpreter :as i] [sci.impl.io :as sio] @@ -300,8 +301,9 @@ evaluation is sandboxed unless it also gets this option. - `:fork-fn`: optional one-argument host function used by `fork` to copy - values held in SCI world cells that need application-specific isolation. - SCI-owned mutable primitives are already world-relative and retain identity. + values held in SCI world cells that do not implement `sci.fork/Forkable` and + need application-specific isolation. SCI-owned mutable primitives are + already world-relative and retain identity. - `:bindings`: DEPRECATED - `:bindings x` is the same as `:namespaces {'user x}`." ([s] (eval-string s nil)) @@ -326,16 +328,18 @@ "Forks a context (as produced with `init`) into an isolated runtime world. Existing SCI Vars and SCI-created mutable primitives retain identity, but - their values diverge after the fork. `opts` may contain `:fork-fn`, which - overrides the context's function for application-specific host values." + their values diverge after the fork. Host values may implement + `sci.fork/Forkable`; `opts` may contain `:fork-fn`, which overrides the + context's fallback function for other application-specific host values." ([ctx] (fork ctx nil)) ([ctx opts] (let [fork-fn (if (contains? opts :fork-fn) (:fork-fn opts) (:fork-fn ctx)) + fork-value (fork/value-forker fork-fn) forked-world (world/fork-world - (:sci.impl/world ctx) fork-fn + (:sci.impl/world ctx) fork-value #(if (utils/var? %) (vars/getRawRoot %) (c/deref %)) diff --git a/src/sci/fork.cljc b/src/sci/fork.cljc new file mode 100644 index 00000000..de3cf4ae --- /dev/null +++ b/src/sci/fork.cljc @@ -0,0 +1,64 @@ +(ns sci.fork + "Host cooperation for forkable SCI runtime values.") + +(defprotocol Forkable + "Values with an application-defined realization in a forked SCI world. + + `fork-value` is called at most once for each identical value during one + fork. Return an independent realization to isolate it, return `this` to + share an external resource deliberately, or throw to prohibit the fork." + (fork-value [this] + "Return this value's realization in the child world.")) + +#?(:clj + (defn- memoized-forker [fallback] + (let [memo (java.util.IdentityHashMap.) + ;; Direct protocol implementations cover the normal deftype and + ;; defrecord cases without paying satisfies?'s extension lookup for + ;; every Var root. Preserve extend-type support when it is in use. + extended? (boolean (seq (extenders Forkable)))] + (fn [value] + (if (or (instance? sci.fork.Forkable value) + (and extended? (satisfies? Forkable value))) + (if (.containsKey memo value) + (.get memo value) + (let [forked (fork-value value)] + (.put memo value forked) + forked)) + (if fallback (fallback value) value))))) + :cljs + (defn- memoized-forker [fallback] + (let [memo (js/Map.)] + (fn [value] + (if (satisfies? Forkable value) + (if (.has memo value) + (.get memo value) + (let [forked (fork-value value)] + (.set memo value forked) + forked)) + (if fallback (fallback value) value))))) + :cljd + (defn- memoized-forker [fallback] + ;; ClojureDart has no portable identity-map abstraction. Forkable host + ;; resources are expected to be few, so keep a small identity alist. + (let [memo (volatile! []) + missing (Object.)] + (fn [value] + (if (satisfies? Forkable value) + (let [cached (reduce (fn [_ [source forked]] + (if (identical? source value) + (reduced forked) + missing)) + missing + @memo)] + (if (identical? missing cached) + (let [forked (fork-value value)] + (vswap! memo conj [value forked]) + forked) + cached)) + (if fallback (fallback value) value)))))) + +(defn ^:no-doc value-forker + "Create the value transformer for one SCI fork." + [fallback] + (memoized-forker fallback)) diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 5c4085cd..69ba2823 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -7,11 +7,24 @@ [sci.copy-ns-test-ns] [sci.copy-var-inlined-clash-ns] [sci.core :as sci] + [sci.fork :as fork] [sci.test-utils :as tu] #?(:cljd [sci.test-utils.macros :refer [thrown-with-data?]]))) #?(:cljs (def Exception js/Error)) +(defrecord ForkableState [state copies] + fork/Forkable + (fork-value [_] + (swap! copies inc) + (ForkableState. (atom @state) copies))) + +(defrecord ProhibitedState [resource] + fork/Forkable + (fork-value [_] + (throw (ex-info "Resource prohibits SCI world forking" + {:resource resource})))) + #?(:cljs (defn testing-vars-str "Returns a string representation of the current test. Renders names @@ -1484,6 +1497,47 @@ (is (= [4 7 11 true] (sci/eval-string* child "(state)"))) (is (= [2 5 9 true] (sci/eval-string* grandchild "(state)"))))))) +(deftest forkable-host-value-test + (let [user-ns (sci/create-ns 'user) + copies (atom 0) + fallback-saw-resource? (atom false) + resource (->ForkableState (atom 0) copies) + state-var (sci/new-var 'state resource {:ns user-ns}) + alias-var (sci/new-var 'state-alias resource {:ns user-ns}) + parent (sci/init + {:namespaces {'user {'state state-var + 'state-alias alias-var}} + :fork-fn (fn [value] + (when (identical? value resource) + (reset! fallback-saw-resource? true)) + value)}) + child (sci/fork parent)] + (testing "Forkable values take precedence over the legacy callback" + (is (false? @fallback-saw-resource?))) + (testing "identical roots are copied once and preserve aliases" + (is (= 1 @copies)) + (is (= [true 1] + (sci/eval-string* + child + "[(identical? state state-alias) (swap! (:state state) inc)]")))) + (testing "the protocol-provided state realization is isolated" + (is (= 0 (sci/eval-string* parent "@(:state state)"))) + (is (= 1 (sci/eval-string* child "@(:state state-alias)")))))) + +(deftest prohibited-host-value-test + (let [user-ns (sci/create-ns 'user) + resource (->ProhibitedState :socket) + resource-var (sci/new-var 'resource resource {:ns user-ns}) + parent (sci/init {:namespaces {'user {'resource resource-var}}}) + result (try + (sci/fork parent) + ::not-thrown + (catch #?(:cljd cljd.core/ExceptionInfo + :clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) e + (:resource (ex-data e))))] + (is (= :socket result)))) + #?(:clj (deftest fork-host-value-cooperation-test (let [user-ns (sci/create-ns 'user) From f692d3a2ac415da071790eb5a8f32f18ed4aae94 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 01:59:00 -0700 Subject: [PATCH 05/31] Document forkable runtime state audit --- doc/fork-state-audit.md | 262 ++++++++++++++++++++++++++++++++++++++++ doc/forking.md | 4 + 2 files changed, 266 insertions(+) create mode 100644 doc/fork-state-audit.md diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md new file mode 100644 index 00000000..71a295cc --- /dev/null +++ b/doc/fork-state-audit.md @@ -0,0 +1,262 @@ +# Forkable runtime state audit + +This audit describes the experimental fork implementation as of `09f1174`. +It distinguishes heap/world state from dynamic control state and external +resources. A value being reachable through an SCI Var does not by itself make +all of its internal state fork-local. + +## Current state model + +An SCI context currently has three relevant layers: + +1. The context environment is an atom containing persistent namespace maps. + `sci/fork` creates a new atom with the same map value. +2. A lineage registry maps stable handles to dense slots. Var roots and + metadata use two slots; SCI-created atoms and volatiles use one value slot. +3. Dynamic binding frames are control state outside the world. On the JVM they + live in a `ThreadLocal`; on CLJS and ClojureDart they live in a process-local + volatile. + +A Var read therefore has this precedence: + +```text +binding frame contains Var? ── yes ──> mutable TBox value + │ + no + ↓ +primary evaluation? ── yes ──> direct Var root + │ + no + ↓ +forked world's resolved dense slot +``` + +The environment and dense world are forked. The binding frame and host object +internals generally are not. + +## Dynamic bindings + +SCI closely follows Clojure's `Var.java` representation: + +- A `Frame` contains a complete persistent map from Var identity to `TBox` and + a pointer to the previous frame. +- `push-thread-bindings` starts with the current complete map, associates a new + box for each rebound Var, and pushes the new frame. `pop-thread-bindings` is + O(1). +- A `TBox` contains the creating JVM thread and a mutable value. `set!` mutates + the box only on that thread. Setting a conveyed binding from a future is + rejected, matching Clojure. +- A Var has a shared `thread-bound` fast-path bit. Once any binding has existed, + reads check the current frame before reading a root. +- `bound-fn*` captures binding values and creates fresh boxes when invoked. + `binding-conveyor-fn`, used by SCI futures, clones the current frame header + and shares its boxes, like Clojure's conveyor behavior. + +### Present fork semantics + +`sci/fork` is a world snapshot, not an execution or continuation snapshot. It +does not capture a dynamic frame. It also cannot be called from inside an +active evaluation of the source world, because the evaluation holds that +world's read permit and the fork requires its write permit. + +Binding frames are keyed only by stable Var identity, not by world identity. +Consequently a binding active on one thread overrides that Var while the thread +performs a nested evaluation in another world from the same lineage. This is +coherent with ordinary Clojure, which has one root world, but interacts badly +with fork-local metadata: a Var made `^:dynamic` only in a child can be bound in +the child and the binding is then observable by a nested parent evaluation, +even though the parent still considers the Var non-dynamic. The roots remain +isolated after the binding exits. + +There is a separate async correctness gap. SCI's future wrapper conveys the +dynamic frame and the captured context, but it does not install the context's +`ReadWorld` thread-local or take the world's evaluation permit. In an observed +child future, the dynamic binding was conveyed correctly while `swap!` changed +the parent atom realization: parent `1`, child `0`. + +CLJS and ClojureDart use one volatile binding-frame stack rather than an +async-local facility. Interleaved asynchronous evaluations can therefore +replace one another's frames even without forking. + +### Recommended control-state model + +Keep two APIs and make their distinction explicit: + +- `fork` remains a quiescent heap/world snapshot and captures no running + bindings. +- A future `fork-execution` operates only at a suspension point and snapshots + `(world, binding-frame, continuation, resource capabilities)`. + +Dynamic frames should belong to an evaluation/fiber token rather than an +unqualified process thread. A practical persistent representation is a small +frame header containing a full persistent `Var -> value` map plus the previous +frame. `set!` replaces the current header's map with an `assoc`; a fiber fork +can share the immutable map in O(1). An ownership/conveyance flag can retain +Clojure's rule that a binding conveyed to another thread cannot be assigned. + +Before changing representation, we must choose whether an explicit host +binding is lineage-wide or world-specific. SCI `(binding ...)` should at least +be evaluation/world-specific so child-only dynamic metadata cannot affect a +nested parent evaluation accidentally. + +## Primitive and runtime-state inventory + +| Facility | Current fork behavior | Required classification or change | +|---|---|---| +| Var root and metadata | Dense world-local slots | Implemented | +| Namespace maps, aliases, imports | Persistent map in a new environment atom | Implemented; contained handles remain shared intentionally | +| Global hierarchy value | Immutable map held in a world-local Var root | Implemented | +| SCI-created atom value | Stable host handle, world-local value slot | Implemented | +| SCI-created volatile value | Stable host handle, world-local value slot | Implemented | +| Atom validator, watches, metadata | Stored on shared host atom | Partial: registrations and metadata leak across worlds | +| Var watches | Stored in the shared Var handle | Partial: registrations leak across worlds | +| Namespace metadata | Mutable field on shared Namespace handle | Shared unintentionally | +| Type metadata and mutable deftype fields | Mutable fields on shared Type/SciType handles | Shared unintentionally | +| `*loaded-libs*` | Built-in Var root points to one host Ref/atom | Shared unintentionally despite fork-local namespace maps | +| Delay | One host Delay object and realization cache | Shared; forcing in one world suppresses computation in another | +| Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | +| `memoize` cache | Host function closes over an untracked atom | Shared; a child cache hit can suppress parent computation | +| Promise | One host delivery cell | Shared; child delivery is immediately visible in parent | +| Future / async task | Running host resource | Not copyable; current child world routing is incorrect | +| Transient collection | Same affine host object | Shared; mutation in child is visible in parent | +| Array / JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | +| Multimethod tables and caches | Mutable internals of one MultiFn root | Shared; a child `defmethod` changes parent dispatch | +| Protocol/type extension registries | Mutable Type/protocol realization objects | Shared in several host-specific paths | +| Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | +| Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | +| RNG, `gensym`, clock, UUID | Host/global nondeterministic source | External capability; not reproducibly forked | +| Readers, writers, streams, iterators, regex matchers | Mutable/consuming host resource | Affine or explicitly shared; never generically copied | +| Files, sockets, executors, locks | External host resource | Explicitly shared, virtualized, or prohibited | + +The table concerns state created or exposed by SCI itself. Application-owned +containers remain responsible for their nested graph through +`sci.fork/Forkable`; only direct world-cell values are inspected by that +protocol. + +## Reproduced cross-world effects + +A JVM probe against the current implementation produced these results: + +- forcing a child delay returned its value in the parent without running the + delayed body in the parent; +- delivering a child promise delivered the parent promise; +- mutating a child transient or array changed the object seen by the parent; +- using a memoized function in the child populated the cache used by parent; +- a child `defmethod` installed the method in parent; +- child changes to namespace metadata and atom metadata appeared in parent; +- a watch installed in child fired for a parent atom mutation; +- a child-only dynamic binding was visible in a nested parent evaluation; +- a future launched in child mutated the parent atom realization. + +These are realization leaks, not failures of the dense value slots themselves. +They arise because a world-local slot often contains a stable object whose own +mutable internals have not yet been decomposed into world state. + +## Dense-registry liveness + +The lineage registry currently holds strong keys for every registered Var, +atom, and volatile, and `:next-slot` only increases. This has two consequences: + +1. A local `(atom ...)` remains strongly reachable for the lifetime of the + lineage even after user code drops every reference to it. +2. Vars or refs created only in a discarded child reserve slots in the shared + lineage registry. Later allocation in a parent can expand across those + branch-local holes, increasing all subsequent copy-on-fork costs. + +Dense slots therefore need a liveness strategy. The main choices are: + +- custom SCI state handles carrying their lineage/slot descriptor, with weak + lineage bookkeeping for enumeration at fork; +- weak identity registration plus slot generations and a free list; +- branch-local registry overlays whose descriptors are promoted only when + values escape or branches join; +- safepoint compaction that rewrites descriptors and dense arrays while all + worlds in a lineage are quiescent. + +Self-describing handles are attractive for SCI-owned atoms, promises, delays, +and multimethods because they also remove descriptor-map lookup from their hot +paths. Host values still require the capability protocol or an identity side +table. + +## State-machine designs beyond Vars + +### Atom and volatile + +Keep stable identity but move all logical state into the world realization: +value, metadata, validator, and watch map. Validators can normally be shared +functions; their registration is world-local. Watch callbacks are effects, so +copying the watch map preserves Clojure behavior inside each branch but still +requires the callback's external capabilities to be honest. + +### Delay + +Represent a delay as a handle to a world-local state machine: + +```text +pending(thunk) -> running(owner) -> success(value) + \-> failure(exception) +``` + +A quiescent world fork copies `pending`, `success`, or `failure`. `running` +should be impossible for an evaluation-owned delay because fork waits for the +active form; a delay running in an unmanaged host task is an external resource +and must block or reject the fork. + +### Promise + +`delivered(value)` can be copied. A pending promise also owns a waiter set, +which is control/resource state rather than a plain heap value. A world-only +fork should either create independent pending cells with no inherited waiters +or reject pending promises. An execution fork may duplicate suspended waiter +continuations only after they are represented inside the managed interpreter. + +### Future and asynchronous computation + +A running host Future cannot be copied honestly. The immediate correction is +to convey the selected SCI world and hold its evaluation permit whenever the +future body runs. Fork policy can then choose among explicit sharing, waiting +for completion and copying the result, restartable computation, cancellation, +or rejection. Full continuation forking requires managed CPS/fiber state. + +### Multimethod + +Keep the MultiFn identity stable and move method/preference tables to world +slots. Dispatch caches are derived state and can be copied or discarded on +fork. The hierarchy is already reached through a fork-local Var root. This is +a relatively contained next primitive and exercises multi-slot handles well. + +### Memoization and lazy computation + +SCI should provide a world-aware memoize implementation whose cache is a +tracked state handle. Lazy sequences are harder: their realization cache is a +small continuation, and arbitrary lazy bodies may perform effects. They belong +with the future execution/fiber model rather than a generic object copier. + +### Transients and mutable aggregates + +Transients are affine. Sharing them violates isolation, while copying them +silently violates owner and invalidation semantics. They should reject a fork +when reachable from a world cell unless an application wrapper defines a safe +policy. Arrays, mutable deftype fields, and application collections may be +duplicable, but need self-describing SCI handles or `Forkable` cooperation. + +## Recommended implementation order + +1. Fix asynchronous world conveyance and add tests for child futures and + callbacks before expanding the primitive set. +2. Decide and specify world-versus-fiber dynamic-binding semantics, including + nested cross-world evaluation and CLJS async-local behavior. +3. Address lineage-registry liveness so adding more tracked handles does not + create an unbounded retention problem. +4. Finish split identity/state already present: atom/Var watches, atom + metadata/validators, namespace/type metadata, and `*loaded-libs*`. +5. Make multimethod tables and memoization caches world-local. +6. Add managed Delay and choose a pending-Promise policy. +7. Reject or explicitly classify transients, running futures, streams, and + other affine/external resources. +8. Introduce execution/fiber snapshots for lazy continuations and the future + lambda-join/Simmis runtime. + +Content addressing, if added later, should identify immutable analyzed code, +definition revisions, and causal namespace history. It does not replace any of +the mutable state-machine or resource decisions in this audit. diff --git a/doc/forking.md b/doc/forking.md index 335280be..50b7ab0a 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -79,3 +79,7 @@ slot reads and writes are constant time. This intentionally favors the common case where reads and mutations greatly outnumber forks. A page-level copy-on-write representation remains a possible next step if workloads with large worlds and frequent forks justify its extra read/write indirection. + +See [Forkable runtime state audit](fork-state-audit.md) for the dynamic-binding +model, stateful primitive inventory, observed isolation gaps, and proposed +implementation order. From 61d063d7873a825fb9fd43ff4675604484b9d020 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 02:09:16 -0700 Subject: [PATCH 06/31] Convey fork worlds into async tasks --- doc/fork-state-audit.md | 21 ++++++++++++--------- src/sci/impl/vars.cljc | 29 ++++++++++++++++------------- test/sci/vars_test.cljc | 38 +++++++++++++++++++++++++++++++++++++- 3 files changed, 65 insertions(+), 23 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 71a295cc..5e01d929 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -68,11 +68,13 @@ the child and the binding is then observable by a nested parent evaluation, even though the parent still considers the Var non-dynamic. The roots remain isolated after the binding exits. -There is a separate async correctness gap. SCI's future wrapper conveys the -dynamic frame and the captured context, but it does not install the context's -`ReadWorld` thread-local or take the world's evaluation permit. In an observed -child future, the dynamic binding was conveyed correctly while `swap!` changed -the parent atom realization: parent `1`, child `0`. +The audit also found an async correctness gap: SCI's future wrapper conveyed +the dynamic frame, but did not install the captured context's `ReadWorld` or +take the world's evaluation permit. In the original probe, the dynamic binding +was conveyed correctly while `swap!` changed the parent atom realization: +parent `1`, child `0`. `binding-conveyor-fn` now captures the SCI context and +runs the callback with that world installed and permitted. A running Future is +still a non-copyable host resource. CLJS and ClojureDart use one volatile binding-frame stack rather than an async-local facility. Interleaved asynchronous evaluations can therefore @@ -117,7 +119,7 @@ nested parent evaluation accidentally. | Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | | `memoize` cache | Host function closes over an untracked atom | Shared; a child cache hit can suppress parent computation | | Promise | One host delivery cell | Shared; child delivery is immediately visible in parent | -| Future / async task | Running host resource | Not copyable; current child world routing is incorrect | +| Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | | Transient collection | Same affine host object | Shared; mutation in child is visible in parent | | Array / JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | | Multimethod tables and caches | Mutable internals of one MultiFn root | Shared; a child `defmethod` changes parent dispatch | @@ -146,7 +148,8 @@ A JVM probe against the current implementation produced these results: - child changes to namespace metadata and atom metadata appeared in parent; - a watch installed in child fired for a parent atom mutation; - a child-only dynamic binding was visible in a nested parent evaluation; -- a future launched in child mutated the parent atom realization. +- before the conveyor correction, a future launched in child mutated the + parent atom realization. These are realization leaks, not failures of the dense value slots themselves. They arise because a world-local slot often contains a stable object whose own @@ -242,8 +245,8 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. ## Recommended implementation order -1. Fix asynchronous world conveyance and add tests for child futures and - callbacks before expanding the primitive set. +1. Preserve the corrected asynchronous world conveyance and extend it to any + new managed callback boundary before expanding the primitive set. 2. Decide and specify world-versus-fiber dynamic-binding semantics, including nested cross-world evaluation and CLJS async-local behavior. 3. Address lineage-registry liveness so adding more tracked handles does not diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index dac7f840..0af54886 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -11,9 +11,10 @@ var-get var-set bound-fn*]) - (:require [sci.ctx-store] + (:require [sci.ctx-store :as store] [sci.impl.macros :as macros] - [sci.impl.types :as t]) + [sci.impl.types :as t] + [sci.impl.world :as world]) #?(:cljs (:require-macros [sci.impl.vars :refer [with-bindings with-writeable-namespace with-writeable-var @@ -168,23 +169,25 @@ (defn binding-conveyor-fn [f] - (let [frame (clone-thread-binding-frame)] + (let [frame (clone-thread-binding-frame) + ctx store/*ctx* + invoke (fn [args] + (reset-thread-binding-frame frame) + (if (:sci.impl/world ctx) + (store/with-ctx ctx + (world/with-active-world ctx #(apply f args))) + (apply f args)))] (fn ([] - (reset-thread-binding-frame frame) - (f)) + (invoke nil)) ([x] - (reset-thread-binding-frame frame) - (f x)) + (invoke [x])) ([x y] - (reset-thread-binding-frame frame) - (f x y)) + (invoke [x y])) ([x y z] - (reset-thread-binding-frame frame) - (f x y z)) + (invoke [x y z])) ([x y z & args] - (reset-thread-binding-frame frame) - (apply f x y z args))))) + (invoke (list* x y z args)))))) (defn throw-unbound-call-exception [the-var] (throw #?(:cljd (ex-info (str "Attempting to call unbound fn: " the-var) {}) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index 822bf4f5..e39309e4 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -112,7 +112,43 @@ (is (= 13 (tu/eval* "(def ^:dynamic x 10) (binding [x (inc x)] @(future (binding [x (inc x)] @(future (binding [x (inc x)] x)))))" - (addons/future {}))))))) + (addons/future {}))))) + + (deftest forked-future-uses-child-world-test + (let [parent (sci/init (addons/future {}))] + (sci/eval-string* + parent + "(def state (atom 0)) + (def ^:dynamic *scope* :root)") + (let [child (sci/fork parent)] + (is (= [:bound 1] + (sci/eval-string* + child + "(binding [*scope* :bound] + @(future [*scope* (swap! state inc)]))"))) + (is (= [:root 0] + (sci/eval-string* parent "[*scope* @state]"))) + (is (= [:root 1] + (sci/eval-string* child "[*scope* @state]")))))) + + (deftest forked-future-participates-in-world-quiescence-test + (let [entered (promise) + release (promise) + parent (sci/init + (addons/future + {:bindings {'block! (fn [] + (deliver entered true) + @release)}})) + child (sci/fork parent) + task (sci/eval-string* child "(future (block!))")] + (is (= true (deref entered 1000 ::timeout))) + (let [forking (future (sci/fork child))] + (try + (is (= ::waiting (deref forking 50 ::waiting))) + (finally + (deliver release true))) + (is (= true (deref task 1000 ::timeout))) + (is (map? (deref forking 1000 ::timeout)))))))) #?(:cljd nil :clj From abfcb82fb29e9220525b215fbe5ad5fbdc91bbc3 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 03:08:38 -0700 Subject: [PATCH 07/31] Scope dynamic bindings to SCI worlds --- doc/fork-state-audit.md | 63 +++++++++++-------- src/sci/impl/analyzer.cljc | 2 +- src/sci/impl/execution.cljc | 101 ++++++++++++++++++++++++++++++ src/sci/impl/namespaces.cljc | 17 +++++- src/sci/impl/vars.cljc | 115 +++++++++++++++++++++-------------- src/sci/impl/world.cljc | 40 ++++++------ test/sci/vars_test.cljc | 46 +++++++++++++- 7 files changed, 288 insertions(+), 96 deletions(-) create mode 100644 src/sci/impl/execution.cljc diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 5e01d929..0bead76c 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -13,8 +13,9 @@ An SCI context currently has three relevant layers: `sci/fork` creates a new atom with the same map value. 2. A lineage registry maps stable handles to dense slots. Var roots and metadata use two slots; SCI-created atoms and volatiles use one value slot. -3. Dynamic binding frames are control state outside the world. On the JVM they - live in a `ThreadLocal`; on CLJS and ClojureDart they live in a process-local +3. Dynamic binding frames are control state outside the world. Active world, + binding scope, and frame are consolidated in one execution-state cell. On + the JVM it is a `ThreadLocal`; on CLJS and ClojureDart it is a process-local volatile. A Var read therefore has this precedence: @@ -38,8 +39,12 @@ internals generally are not. SCI closely follows Clojure's `Var.java` representation: -- A `Frame` contains a complete persistent map from Var identity to `TBox` and - a pointer to the previous frame. +- A `Frame` contains a complete persistent map from Var identity to `TBox`, a + pointer to the previous frame, and the world in which it was pushed. A nil + world denotes an explicit host API binding. +- The execution state caches the effective binding map for its active world. + World entry selects or merges the persistent host/world maps once, leaving a + dynamic Var read with one execution-state lookup and one map lookup. - `push-thread-bindings` starts with the current complete map, associates a new box for each rebound Var, and pushes the new frame. `pop-thread-bindings` is O(1). @@ -49,8 +54,14 @@ SCI closely follows Clojure's `Var.java` representation: - A Var has a shared `thread-bound` fast-path bit. Once any binding has existed, reads check the current frame before reading a root. - `bound-fn*` captures binding values and creates fresh boxes when invoked. - `binding-conveyor-fn`, used by SCI futures, clones the current frame header - and shares its boxes, like Clojure's conveyor behavior. + `binding-conveyor-fn`, used by SCI futures, shares the captured boxes, like + Clojure's conveyor behavior. Both also capture and reinstall the SCI world. + +A focused local JVM benchmark of ten million dynamic-binding reads took a +median 94.6 ms with the consolidated execution cell, versus 123.8 ms before +world scoping. This is not a portable performance guarantee, but it validates +the important shape of the implementation: scope selection happens on world +entry rather than on every Var dereference. ### Present fork semantics @@ -59,14 +70,12 @@ does not capture a dynamic frame. It also cannot be called from inside an active evaluation of the source world, because the evaluation holds that world's read permit and the fork requires its write permit. -Binding frames are keyed only by stable Var identity, not by world identity. -Consequently a binding active on one thread overrides that Var while the thread -performs a nested evaluation in another world from the same lineage. This is -coherent with ordinary Clojure, which has one root world, but interacts badly -with fork-local metadata: a Var made `^:dynamic` only in a child can be bound in -the child and the binding is then observable by a nested parent evaluation, -even though the parent still considers the Var non-dynamic. The roots remain -isolated after the binding exits. +Binding frames are scoped to the world in which they are pushed. A nested +evaluation of another world skips those frames, so a Var made `^:dynamic` only +in a child can no longer override a nested parent evaluation. Bindings +established explicitly through the host API outside an evaluation have nil +scope and deliberately enter any subsequently evaluated world, retaining the +useful behavior of `sci/with-bindings`. The audit also found an async correctness gap: SCI's future wrapper conveyed the dynamic frame, but did not install the captured context's `ReadWorld` or @@ -89,17 +98,16 @@ Keep two APIs and make their distinction explicit: - A future `fork-execution` operates only at a suspension point and snapshots `(world, binding-frame, continuation, resource capabilities)`. -Dynamic frames should belong to an evaluation/fiber token rather than an -unqualified process thread. A practical persistent representation is a small -frame header containing a full persistent `Var -> value` map plus the previous -frame. `set!` replaces the current header's map with an `assoc`; a fiber fork -can share the immutable map in O(1). An ownership/conveyance flag can retain -Clojure's rule that a binding conveyed to another thread cannot be assigned. +Dynamic frames should eventually belong to an evaluation/fiber token rather +than an unqualified process thread. The execution-state cell is the first step: +its frame headers and maps are persistent, so a suspended fiber can share them +in O(1), while `TBox` retains Clojure's mutable `set!` and conveyed-thread +ownership behavior. A later execution fork can replace boxes with immutable +values or copy them at the suspension boundary. -Before changing representation, we must choose whether an explicit host -binding is lineage-wide or world-specific. SCI `(binding ...)` should at least -be evaluation/world-specific so child-only dynamic metadata cannot affect a -nested parent evaluation accidentally. +Explicit host bindings are intentionally unscoped and enter subsequently +evaluated worlds. SCI `(binding ...)` inside evaluation is world-specific, so +child-only dynamic metadata cannot affect a nested parent evaluation. ## Primitive and runtime-state inventory @@ -147,7 +155,8 @@ A JVM probe against the current implementation produced these results: - a child `defmethod` installed the method in parent; - child changes to namespace metadata and atom metadata appeared in parent; - a watch installed in child fired for a parent atom mutation; -- a child-only dynamic binding was visible in a nested parent evaluation; +- before world-scoped frames, a child-only dynamic binding was visible in a + nested parent evaluation; - before the conveyor correction, a future launched in child mutated the parent atom realization. @@ -247,8 +256,8 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. 1. Preserve the corrected asynchronous world conveyance and extend it to any new managed callback boundary before expanding the primitive set. -2. Decide and specify world-versus-fiber dynamic-binding semantics, including - nested cross-world evaluation and CLJS async-local behavior. +2. Evolve the new world-scoped frames into managed fiber-local frames for CLJS + async suspension and eventual execution snapshots. 3. Address lineage-registry liveness so adding more tracked handles does not create an unbounded retention problem. 4. Finish split identity/state already present: atom/Var watches, atom diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index 16f9b261..9a64b080 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -61,7 +61,7 @@ sci.impl.types/Eval (eval [_ _ctx _bindings] (let [^sci.impl.world.ReadWorld active - (.get ^ThreadLocal world/active-world)] + (world/active-world-state)] (if (or (nil? active) (.-primary? active)) (.getDirectRoot v) (let [^sci.impl.world.DenseWorld world (.-world active) diff --git a/src/sci/impl/execution.cljc b/src/sci/impl/execution.cljc new file mode 100644 index 00000000..82a174a5 --- /dev/null +++ b/src/sci/impl/execution.cljc @@ -0,0 +1,101 @@ +(ns sci.impl.execution + "The execution-local state shared by world selection and dynamic bindings.") + +(def ^:const active-world-index 0) +(def ^:const binding-frame-index 1) +(def ^:const binding-scope-index 2) +(def ^:const active-bindings-index 3) +(def ^:const scope-bindings-index 4) + +(defn- new-state [] + #?(:cljd (#/(List/filled dynamic) 5 nil) + :default (object-array 5))) + +#?(:clj + (def ^ThreadLocal current + (proxy [ThreadLocal] [] + (initialValue [] (new-state)))) + :default + (def current (volatile! (new-state)))) + +(defn current-state [] + #?(:clj (.get ^ThreadLocal current) + :default @current)) + +(defn active-world + ([] (active-world (current-state))) + ([state] + #?(:cljd (aget ^List state active-world-index) + :clj (aget ^objects state active-world-index) + :cljs (aget state active-world-index)))) + +(defn binding-frame + ([] (binding-frame (current-state))) + ([state] + #?(:cljd (aget ^List state binding-frame-index) + :clj (aget ^objects state binding-frame-index) + :cljs (aget state binding-frame-index)))) + +(defn binding-scope + ([] (binding-scope (current-state))) + ([state] + #?(:cljd (aget ^List state binding-scope-index) + :clj (aget ^objects state binding-scope-index) + :cljs (aget state binding-scope-index)))) + +(defn active-bindings + ([] (active-bindings (current-state))) + ([state] + (or #?(:cljd (aget ^List state active-bindings-index) + :clj (aget ^objects state active-bindings-index) + :cljs (aget state active-bindings-index)) + {}))) + +(defn scope-bindings + ([] (scope-bindings (current-state))) + ([state] + (or #?(:cljd (aget ^List state scope-bindings-index) + :clj (aget ^objects state scope-bindings-index) + :cljs (aget state scope-bindings-index)) + {}))) + +(defn set-active-world! [state value] + #?(:cljd (aset ^List state active-world-index value) + :clj (aset ^objects state active-world-index value) + :cljs (aset state active-world-index value)) + value) + +(defn set-binding-frame! [state value] + #?(:cljd (aset ^List state binding-frame-index value) + :clj (aset ^objects state binding-frame-index value) + :cljs (aset state binding-frame-index value)) + value) + +(defn set-binding-scope! [state value] + #?(:cljd (aset ^List state binding-scope-index value) + :clj (aset ^objects state binding-scope-index value) + :cljs (aset state binding-scope-index value)) + value) + +(defn set-active-bindings! [state value] + #?(:cljd (aset ^List state active-bindings-index value) + :clj (aset ^objects state active-bindings-index value) + :cljs (aset state active-bindings-index value)) + value) + +(defn set-scope-bindings! [state value] + #?(:cljd (aset ^List state scope-bindings-index value) + :clj (aset ^objects state scope-bindings-index value) + :cljs (aset state scope-bindings-index value)) + value) + +(defn refresh-active-bindings! [state] + (let [scope (binding-scope state) + scopes (scope-bindings state) + host (get scopes nil {}) + scoped (if (nil? scope) {} (get scopes scope {})) + effective (cond + (empty? host) scoped + (empty? scoped) host + :else (merge host scoped))] + (set-active-bindings! state effective))) diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index c22393f3..dd4596f3 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -775,9 +775,22 @@ arguments. This may be used to define a helper function which runs on a different thread, but needs the same bindings in place." [f] - (let [bindings (sci.impl.vars/get-thread-bindings)] + (let [bindings (vars/get-thread-bindings) + ctx store/*ctx*] (fn [& args] - (apply with-bindings* bindings f args)))) + (let [previous (vars/get-thread-binding-frame) + invoke #(apply with-bindings* bindings f args)] + (try + ;; A pooled worker may retain a conveyor frame from prior SCI work. + ;; bound-fn installs fresh boxes over a clean execution binding set, + ;; then restores whatever the caller had. + (vars/reset-thread-binding-frame nil) + (if (:sci.impl/world ctx) + (store/with-ctx ctx + (world/with-active-world ctx invoke)) + (invoke)) + (finally + (vars/reset-thread-binding-frame previous))))))) (defn sci-bound-fn "Returns a function defined by the given fntail, which will install the diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index 0af54886..525252d7 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -12,6 +12,7 @@ var-set bound-fn*]) (:require [sci.ctx-store :as store] + [sci.impl.execution :as execution] [sci.impl.macros :as macros] [sci.impl.types :as t] [sci.impl.world :as world]) @@ -33,17 +34,9 @@ (throw (ex-info (str "Built-in namespace " name# " is read-only.") {:ns ns-obj#}))))))) -(deftype Frame [bindings prev]) +(deftype Frame [bindings prev scope prior-bindings]) -(def top-frame (Frame. {} nil)) - -#?(:cljd - (def dvals (volatile! top-frame)) - :clj - (def ^ThreadLocal dvals (proxy [ThreadLocal] [] - (initialValue [] top-frame))) - :cljs - (def dvals (volatile! top-frame))) +(def top-frame (Frame. {} nil nil nil)) #?(:cljs (def var-epoch @@ -74,9 +67,7 @@ v#))))) (defn get-thread-binding-frame ^Frame [] - #?(:cljd @dvals - :clj (.get dvals) - :cljs @dvals)) + (or (execution/binding-frame) top-frame)) (deftype TBox #?(:cljd [thread ^:mutable val] :clj [thread ^:volatile-mutable val] @@ -87,15 +78,31 @@ (getVal [_this] val)) (defn clone-thread-binding-frame ^Frame [] - (let [^Frame f #?(:cljd @dvals - :clj (.get dvals) - :cljs @dvals)] - (Frame. (.-bindings f) nil))) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state))] + (Frame. (execution/active-bindings state) + nil + (execution/binding-scope state) + nil))) (defn reset-thread-binding-frame [frame] - #?(:cljd (vreset! dvals frame) - :clj (.set dvals frame) - :cljs (vreset! dvals frame))) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + scopes (loop [^Frame current frame + seen #{} + ret {}] + (if (nil? current) + ret + (let [scope (.-scope current)] + (if (contains? seen scope) + (recur (.-prev current) seen ret) + (recur (.-prev current) + (conj seen scope) + (assoc ret scope (.-bindings current)))))))] + (execution/set-binding-frame! state frame) + (execution/set-scope-bindings! state scopes) + (execution/refresh-active-bindings! state) + frame)) (defprotocol IVar (bindRoot [this v]) @@ -117,8 +124,13 @@ (dynamic? [_] false)) (defn push-thread-bindings [bindings] - (let [^Frame frame (get-thread-binding-frame) - bmap (.-bindings frame) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + ^Frame frame (or (execution/binding-frame state) top-frame) + scope (execution/binding-scope state) + scopes (execution/scope-bindings state) + prior-bindings (get scopes scope) + bmap (or prior-bindings {}) bmap (reduce (fn [acc [var* val*]] (when (not (dynamic? var*)) (throw #?(:cljd (ex-info (str "Can't dynamically bind non-dynamic var " var*) {}) @@ -133,39 +145,48 @@ bmap bindings)] #?(:cljs (bump-var-epoch!)) - (reset-thread-binding-frame (Frame. bmap frame)))) + (let [new-frame (Frame. bmap frame scope prior-bindings)] + (execution/set-binding-frame! state new-frame) + (execution/set-scope-bindings! state (assoc scopes scope bmap)) + (execution/refresh-active-bindings! state) + new-frame))) (defn pop-thread-bindings [] #?(:cljs (bump-var-epoch!)) ;; type hint needed to satisfy CLJS compiler / shadow - (if-let [f (.-prev ^Frame (get-thread-binding-frame))] - (if (identical? top-frame f) - #?(:cljd (vreset! dvals top-frame) - :clj (.remove dvals) - :cljs (vreset! dvals top-frame)) - (reset-thread-binding-frame f)) - (throw (new #?(:cljd Exception :clj Exception :cljs js/Error) "No frame to pop.")))) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + ^Frame frame (or (execution/binding-frame state) top-frame)] + (if-let [previous (.-prev frame)] + (let [scope (.-scope frame) + prior-bindings (.-prior-bindings frame) + scopes (execution/scope-bindings state) + scopes (if (nil? prior-bindings) + (dissoc scopes scope) + (assoc scopes scope prior-bindings))] + (execution/set-binding-frame! state + (when-not (identical? top-frame previous) + previous)) + (execution/set-scope-bindings! state scopes) + (execution/refresh-active-bindings! state) + nil) + (throw (new #?(:cljd Exception :clj Exception :cljs js/Error) "No frame to pop."))))) (defn get-thread-bindings [] - (let [;; type hint added to prevent shadow-cljs warning, although fn has return tag - ^Frame f (get-thread-binding-frame)] - (loop [ret {} - kvs (seq (.-bindings f))] - (if kvs - (let [[var* ^TBox tbox] (first kvs) - tbox-val (t/getVal tbox)] - (recur (assoc ret var* tbox-val) - (next kvs))) - ret)))) + (let [bmap (execution/active-bindings)] + (reduce-kv (fn [ret var* tbox] + (assoc ret var* (t/getVal tbox))) + {} + bmap))) (defn get-thread-binding #?(:cljd [sci-var] :clj ^TBox [sci-var] :cljs ^TBox [sci-var]) - (when-let [;; type hint added to prevent shadow-cljs warning, although fn has return tag - ^Frame f #?(:cljd @dvals - :clj (.get dvals) - :cljs @dvals)] - #?(:cljd (get (.-bindings f) sci-var) - :clj (.get ^java.util.Map (.-bindings f) sci-var) - :cljs (.get (.-bindings f) sci-var)))) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + bmap #?(:clj (or (aget ^objects state execution/active-bindings-index) {}) + :default (execution/active-bindings state))] + #?(:cljd (get bmap sci-var) + :clj (.get ^java.util.Map bmap sci-var) + :cljs (.get bmap sci-var)))) (defn binding-conveyor-fn [f] diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 8b2e2983..33674731 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -5,7 +5,8 @@ stores slot values densely and a frozen fork copies that array while the source world is quiescent. Mutable primitives CAS only their own slot, so unrelated atoms never contend on a shared world root." - (:require [sci.ctx-store :as store]) + (:require [sci.ctx-store :as store] + [sci.impl.execution :as execution]) #?(:clj (:import [java.util.concurrent.atomic AtomicReferenceArray] [java.util.concurrent.locks ReentrantReadWriteLock]))) @@ -83,29 +84,26 @@ #?(:clj (ReentrantReadWriteLock.) :default nil) (volatile! false))) -#?(:clj - (def ^ThreadLocal active-world - (proxy [ThreadLocal] [] - (initialValue [] nil))) - :default - (def active-world (volatile! nil))) - -(defn- active-world-state [] - #?(:clj (.get ^ThreadLocal active-world) - :default @active-world)) +(defn active-world-state [] + #?(:clj (let [state (.get ^ThreadLocal execution/current)] + (aget ^objects state execution/active-world-index)) + :default (execution/active-world))) (defn- call-with-active-world [ctx f] - (let [previous (active-world-state) + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + previous (execution/active-world state) + previous-scope (execution/binding-scope state) active (:sci.impl/read-world ctx)] - #?(:clj (.set ^ThreadLocal active-world active) - :default (vreset! active-world active)) + (execution/set-active-world! state active) + (execution/set-binding-scope! state (:sci.impl/world ctx)) + (execution/refresh-active-bindings! state) (try (f) (finally - #?(:clj (if (nil? previous) - (.remove ^ThreadLocal active-world) - (.set ^ThreadLocal active-world previous)) - :default (vreset! active-world previous)))))) + (execution/set-active-world! state previous) + (execution/set-binding-scope! state previous-scope) + (execution/refresh-active-bindings! state))))) (defn with-active-world "Run `f` with the context's world installed. On the JVM evaluations take a @@ -125,6 +123,12 @@ (defn current-world [] (:sci.impl/world store/*ctx*)) +(defn binding-scope + "Return the currently executing world for dynamic-binding isolation. Nil + denotes a host binding established outside managed SCI evaluation." + [] + (execution/binding-scope)) + (defn- descriptor [^DenseWorld world handle] (get-in @(.-registry world) [:descriptors handle])) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index e39309e4..032152ad 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -171,7 +171,24 @@ (binding [*some-var* :hello] (.start (java.lang.Thread. (bound-fn [] (f))))) @state" - {:classes {'java.lang.Thread java.lang.Thread}})))))) + {:classes {'java.lang.Thread java.lang.Thread}})))) + + (deftest forked-bound-fn-uses-child-world-test + (let [parent (sci/init {})] + (sci/eval-string* + parent + "(def state (atom 0)) + (def ^:dynamic *scope* :root)") + (let [child (sci/fork parent) + f (sci/eval-string* + child + "(binding [*scope* :bound] + (bound-fn [] [*scope* (swap! state inc)]))") + result (promise)] + (.start (Thread. #(deliver result (f)))) + (is (= [:bound 1] (deref result 1000 ::timeout))) + (is (= 0 (sci/eval-string* parent "@state"))) + (is (= 1 (sci/eval-string* child "@state")))))))) #?(:cljd nil :clj @@ -198,6 +215,33 @@ (is (= 1 (sci/binding [x 1] (sci/eval-string "*x*" {:bindings {'*x* x}}))))))) +(deftest world-scoped-dynamic-binding-test + (let [parent-holder (atom nil) + parent (sci/init + {:bindings + {'read-parent #(sci/eval-string* @parent-holder "late")}})] + (reset! parent-holder parent) + (sci/eval-string* parent + "(def late 0) (def ^:dynamic shared 0)") + (let [child (sci/fork parent)] + (sci/eval-string* child + "(alter-meta! #'late assoc :dynamic true)") + (testing "a child binding does not override a nested parent evaluation" + (is (= [9 0 9] + (sci/eval-string* + child + "(binding [late 9] [late (read-parent) late])")))) + (testing "host API bindings deliberately enter either world" + (let [shared (sci/eval-string* parent "#'shared")] + (is (= [7 7] + (sci/with-bindings + {shared 7} + [(sci/eval-string* parent "shared") + (sci/eval-string* child "shared")]))))) + (is (= [0 0] + [(sci/eval-string* parent "late") + (sci/eval-string* child "late")]))))) + #_(deftest with-redefs-api-test (when-not tu/native? (let [x (sci/new-dynamic-var 'x)] From 88e62a22de48d8d9273c298a2b10f15d9e9708c2 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 03:45:36 -0700 Subject: [PATCH 08/31] Add fork-local SCI atoms and async continuations --- doc/fork-state-audit.md | 59 ++++-- doc/forking.md | 31 +-- src/sci/impl/core_protocols.cljc | 255 +++++++++++++++--------- src/sci/impl/namespaces.cljc | 74 +++---- src/sci/impl/refs.cljc | 325 +++++++++++++++++++++++++++++++ src/sci/impl/vars.cljc | 34 +++- src/sci/impl/world.cljc | 118 ++++++++++- test/sci/async_await_test.cljs | 19 ++ test/sci/core_test.cljc | 37 ++++ 9 files changed, 787 insertions(+), 165 deletions(-) create mode 100644 src/sci/impl/refs.cljc diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 0bead76c..58ef4259 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -1,6 +1,7 @@ # Forkable runtime state audit -This audit describes the experimental fork implementation as of `09f1174`. +This audit describes the experimental fork implementation on the current +branch. It distinguishes heap/world state from dynamic control state and external resources. A value being reachable through an SCI Var does not by itself make all of its internal state fork-local. @@ -12,7 +13,9 @@ An SCI context currently has three relevant layers: 1. The context environment is an atom containing persistent namespace maps. `sci/fork` creates a new atom with the same map value. 2. A lineage registry maps stable handles to dense slots. Var roots and - metadata use two slots; SCI-created atoms and volatiles use one value slot. + metadata use two slots. A self-describing SCI atom carries a hot value slot + plus a cold control slot for metadata, validator, and watches. Volatiles + currently use one registry-routed value slot. 3. Dynamic binding frames are control state outside the world. Active world, binding scope, and frame are consolidated in one execution-state cell. On the JVM it is a `ThreadLocal`; on CLJS and ClojureDart it is a process-local @@ -81,13 +84,20 @@ The audit also found an async correctness gap: SCI's future wrapper conveyed the dynamic frame, but did not install the captured context's `ReadWorld` or take the world's evaluation permit. In the original probe, the dynamic binding was conveyed correctly while `swap!` changed the parent atom realization: -parent `1`, child `0`. `binding-conveyor-fn` now captures the SCI context and -runs the callback with that world installed and permitted. A running Future is -still a non-copyable host resource. - -CLJS and ClojureDart use one volatile binding-frame stack rather than an -async-local facility. Interleaved asynchronous evaluations can therefore -replace one another's frames even without forking. +parent `1`, child `0`. `binding-conveyor-fn` now captures the SCI context, runs +the callback with that world installed and permitted, and restores the +worker's prior execution state. The CLJS async transform uses a related +continuation wrapper for Promise `then`, `catch`, and `finally`: unlike an +independent task's shallow frame, it retains the persistent parent chain so a +continuation can leave a `binding` scope entered before `await`. Both the world +and dynamic bindings therefore survive suspension. A running Future is still +a non-copyable host resource. + +CLJS and ClojureDart still use one volatile execution-state cell rather than a +general async-local facility. Managed Promise continuations install and +restore their captured state synchronously, but arbitrary host callbacks must +be conveyed explicitly and ClojureDart has no equivalent async integration +yet. ### Recommended control-state model @@ -116,9 +126,8 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Var root and metadata | Dense world-local slots | Implemented | | Namespace maps, aliases, imports | Persistent map in a new environment atom | Implemented; contained handles remain shared intentionally | | Global hierarchy value | Immutable map held in a world-local Var root | Implemented | -| SCI-created atom value | Stable host handle, world-local value slot | Implemented | +| SCI-created atom value and control state | Self-describing stable handle; world-local value and metadata/validator/watch slots | Implemented; watch callback effects remain the user's responsibility | | SCI-created volatile value | Stable host handle, world-local value slot | Implemented | -| Atom validator, watches, metadata | Stored on shared host atom | Partial: registrations and metadata leak across worlds | | Var watches | Stored in the shared Var handle | Partial: registrations leak across worlds | | Namespace metadata | Mutable field on shared Namespace handle | Shared unintentionally | | Type metadata and mutable deftype fields | Mutable fields on shared Type/SciType handles | Shared unintentionally | @@ -153,8 +162,9 @@ A JVM probe against the current implementation produced these results: - mutating a child transient or array changed the object seen by the parent; - using a memoized function in the child populated the cache used by parent; - a child `defmethod` installed the method in parent; -- child changes to namespace metadata and atom metadata appeared in parent; -- a watch installed in child fired for a parent atom mutation; +- before self-describing atoms, child atom metadata changes appeared in the + parent and a watch installed in the child fired for a parent mutation; +- namespace metadata still leaks across worlds; - before world-scoped frames, a child-only dynamic binding was visible in a nested parent evaluation; - before the conveyor correction, a future launched in child mutated the @@ -166,11 +176,14 @@ mutable internals have not yet been decomposed into world state. ## Dense-registry liveness -The lineage registry currently holds strong keys for every registered Var, -atom, and volatile, and `:next-slot` only increases. This has two consequences: +The lineage registry currently holds strong keys for every registered Var and +volatile, and `:next-slot` only increases. Self-describing atoms no longer add +their object as a registry key, but their anonymous descriptors and slot +values are still retained. This has two consequences: -1. A local `(atom ...)` remains strongly reachable for the lifetime of the - lineage even after user code drops every reference to it. +1. A local `(atom ...)` object can be collected, but its last value and control + record remain reachable from every world that realized its slots. Registry- + routed refs also retain their handle. 2. Vars or refs created only in a discarded child reserve slots in the shared lineage registry. Later allocation in a parent can expand across those branch-local holes, increasing all subsequent copy-on-fork costs. @@ -200,6 +213,14 @@ functions; their registration is world-local. Watch callbacks are effects, so copying the watch map preserves Clojure behavior inside each branch but still requires the callback's external capabilities to be honest. +This is now implemented by a two-slot `SciAtom`. Its direct slot descriptor +avoids the lineage handle lookup on dereference and mutation. A focused local +JVM comparison measured five million child-world reads at roughly 72 ms versus +243 ms through the former registry route, and 500,000 swaps at 36 ms versus 67 +ms. A host atom in the same probe took roughly 27 ms and 5.5 ms respectively; +the remaining cost buys world selection and fork-local control state. These +figures describe one local microbenchmark, not a portable guarantee. + ### Delay Represent a delay as a handle to a world-local state machine: @@ -260,8 +281,8 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. async suspension and eventual execution snapshots. 3. Address lineage-registry liveness so adding more tracked handles does not create an unbounded retention problem. -4. Finish split identity/state already present: atom/Var watches, atom - metadata/validators, namespace/type metadata, and `*loaded-libs*`. +4. Finish split identity/state for Var watches, namespace/type metadata, + volatiles, and `*loaded-libs*`. 5. Make multimethod tables and memoization caches world-local. 6. Add managed Delay and choose a pending-Promise policy. 7. Reject or explicitly classify transients, running futures, streams, and diff --git a/doc/forking.md b/doc/forking.md index 50b7ab0a..466e2307 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -1,10 +1,10 @@ # Forkable SCI worlds `sci/fork` creates a branch of an interpreter's runtime state. Namespace maps, -SCI Var roots and metadata, and values of SCI-created atoms and volatiles are -part of that state. Existing Vars, refs, aliases, and interpreted functions -keep their identity; their meaning is selected by the world in which code is -evaluated. +SCI Var roots and metadata, SCI-created atom state, and values of SCI-created +volatiles are part of that state. Existing Vars, refs, aliases, and interpreted +functions keep their identity; their meaning is selected by the world in which +code is evaluated. This is deliberately a value/realization split. Stable handles receive dense, lineage-local integer slots. Each world realizes those slots in an array; a @@ -30,6 +30,8 @@ This shape combines four useful precedents: lineage. - Dynamic binding frames remain thread/evaluation scoped. A fork snapshots root bindings; it does not capture a running continuation or binding frame. +- Interpreter bindings are scoped to their world. Managed asynchronous + callbacks convey and restore both the selected world and binding frame. - Writes before the first fork have ordinary SCI/Clojure mutable behavior. The first fork materializes the primary values into dense slots; later writes update the selected world's slots. @@ -66,13 +68,20 @@ application's responsibility, for example with an identity-keyed memo table. ## Current boundary -This first implementation makes Var roots/metadata and the values of -SCI-created atoms and volatiles fork-local. Atom validator and watch -registrations still live on the shared stable host handle. Promises, delays, -futures, transients, mutable host objects, mutable deftype fields, and effects -outside SCI remain shared unless the embedding application models or copies -them. A complete effect inventory and an explicit fork protocol are the next -step before describing an interpreter as fully forkable. +Var roots/metadata, all logical SCI atom state, and SCI-created volatile values +are fork-local. Atom metadata, validator, and watch maps are inherited by a +fork and can subsequently diverge; effects performed by a watch are ordinary +user capabilities and are not made reversible automatically. Promises, +delays, futures, transients, mutable host objects, mutable deftype fields, and +effects outside SCI remain shared unless the embedding application models or +copies them. + +On the JVM and CLJS an SCI-created atom is now a dedicated `SciAtom`, not the +host's concrete `clojure.lang.Atom`/`cljs.core.Atom` class. It implements the +normal dereference, atom, metadata, validator, and watch protocols, but code +that tests the host concrete class observes this intentional representation +difference. The split is necessary for one stable identity to select different +state in different worlds. Forking is O(number of allocated slots), including spare array capacity, while slot reads and writes are constant time. This intentionally favors the common diff --git a/src/sci/impl/core_protocols.cljc b/src/sci/impl/core_protocols.cljc index be582290..7a3a525e 100644 --- a/src/sci/impl/core_protocols.cljc +++ b/src/sci/impl/core_protocols.cljc @@ -6,6 +6,7 @@ #?(:cljd [sci.impl.multimethods :as mm]) #?(:cljs [sci.impl.copy-vars :as copy-vars]) [sci.impl.records] + [sci.impl.refs :as refs] [sci.impl.types :as types] [sci.impl.utils :as utils] [sci.impl.world :as world] @@ -48,18 +49,22 @@ ;; world-relative routing before falling back to cljs.core/deref. #?(:cljd (defn deref* [x] - (if (and (world/primary-world?) (satisfies? IDeref x)) + (if (refs/sci-atom? x) + (clojure.core/deref x) + (if (and (world/primary-world?) (satisfies? IDeref x)) (clojure.core/deref x) (let [v (tracked-value x)] (if-not (identical? untracked-value v) v (if (satisfies? IDeref x) (clojure.core/deref x) - (-deref x)))))) + (-deref x))))))) :clj (defn deref* ([x] - (if (and (world/primary-world?) + (if (refs/sci-atom? x) + (clojure.core/deref x) + (if (and (world/primary-world?) (instance? clojure.lang.IDeref x)) (clojure.core/deref x) (let [v (tracked-value x)] @@ -67,26 +72,25 @@ v (if (instance? clojure.lang.IDeref x) (clojure.core/deref x) - (deref x)))))) + (deref x))))))) ([x & args] (apply clojure.core/deref x args))) :cljs (defn deref* [x] - (if (world/primary-world?) + (if (refs/sci-atom? x) + (clojure.core/deref x) + (if (world/primary-world?) (clojure.core/deref x) (let [v (tracked-value x)] (if-not (identical? untracked-value v) v - (clojure.core/deref x)))))) + (clojure.core/deref x))))))) (defn atom* - "Creates an atom whose state is owned by the active SCI world. The host atom - is retained as a stable handle and as the carrier for metadata, validators, - and watches." + "Creates an atom whose value and control state are owned by the active SCI + world." [x & options] - (let [a (apply clojure.core/atom x options)] - (world/register! a x) - a)) + (apply refs/atom x options)) (defn volatile!* "Creates a volatile whose value is owned by the active SCI world." @@ -299,106 +303,168 @@ #?(:clj (defn swap!* [ref f & args] - (if (and (world/mutable-primary-world?) - (instance? clojure.lang.IAtom ref)) + (cond + (refs/sci-atom? ref) + (apply clojure.core/swap! ref f args) + + (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) + (apply clojure.core/swap! ref f args) + + (world/tracked? ref) + (swap-tracked! ref f args) + + (instance? clojure.lang.IAtom ref) (apply clojure.core/swap! ref f args) - (if (world/tracked? ref) - (swap-tracked! ref f args) - (if (instance? clojure.lang.IAtom ref) - (if args - (apply clojure.core/swap! ref f args) - (clojure.core/swap! ref f)) - (if args - (apply swap ref f args) - (swap ref f)))))) + + :else + (apply swap ref f args))) :cljs (defn swap!* [ref f & args] - (if (world/mutable-primary-world?) + (cond + (refs/sci-atom? ref) + (apply clojure.core/swap! ref f args) + + (world/mutable-primary-world?) (apply clojure.core/swap! ref f args) - (if (world/tracked? ref) - (swap-tracked! ref f args) - (if args - (apply clojure.core/swap! ref f args) - (clojure.core/swap! ref f)))))) + + (world/tracked? ref) + (swap-tracked! ref f args) + + :else + (apply clojure.core/swap! ref f args)))) #?(:cljd (defn swap!* [ref f & args] - (if (and (world/mutable-primary-world?) - (instance? cljd.core/Atom ref)) + (cond + (refs/sci-atom? ref) + (apply clojure.core/swap! ref f args) + + (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) (apply clojure.core/swap! ref f args) - (if (world/tracked? ref) - (swap-tracked! ref f args) - (if (or (instance? cljd.core/Atom ref) - (satisfies? ISwap ref)) - (if args - (apply clojure.core/swap! ref f args) - (clojure.core/swap! ref f)) - (if args - (apply -swap! ref f args) - (-swap! ref f))))))) + + (world/tracked? ref) + (swap-tracked! ref f args) + + (or (instance? cljd.core/Atom ref) + (satisfies? ISwap ref)) + (apply clojure.core/swap! ref f args) + + :else + (apply -swap! ref f args)))) #?(:cljd (defn reset!* [ref v] - (if (and (world/mutable-primary-world?) - (instance? cljd.core/Atom ref)) + (cond + (refs/sci-atom? ref) + (clojure.core/reset! ref v) + + (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) + (clojure.core/reset! ref v) + + (world/tracked? ref) + (reset-tracked! ref v) + + (or (instance? cljd.core/Atom ref) + (satisfies? IReset ref)) (clojure.core/reset! ref v) - (if (world/tracked? ref) - (reset-tracked! ref v) - (if (or (instance? cljd.core/Atom ref) - (satisfies? IReset ref)) - (clojure.core/reset! ref v) - (-reset! ref v))))) + + :else + (-reset! ref v))) :clj (defn reset!* [ref v] - (if (and (world/mutable-primary-world?) - (instance? clojure.lang.IAtom ref)) + (cond + (refs/sci-atom? ref) + (clojure.core/reset! ref v) + + (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) (clojure.core/reset! ref v) - (if (world/tracked? ref) - (reset-tracked! ref v) - (if (instance? clojure.lang.IAtom ref) - (clojure.core/reset! ref v) - (reset ref v))))) + + (world/tracked? ref) + (reset-tracked! ref v) + + (instance? clojure.lang.IAtom ref) + (clojure.core/reset! ref v) + + :else + (reset ref v))) :cljs (defn reset!* [ref v] - (if (world/mutable-primary-world?) + (cond + (refs/sci-atom? ref) (clojure.core/reset! ref v) - (if (world/tracked? ref) - (reset-tracked! ref v) - (clojure.core/reset! ref v))))) + + (world/mutable-primary-world?) + (clojure.core/reset! ref v) + + (world/tracked? ref) + (reset-tracked! ref v) + + :else + (clojure.core/reset! ref v)))) #?(:cljd (defn compare-and-set!* [ref old new] - (if (and (world/mutable-primary-world?) - (instance? cljd.core/Atom ref)) + (cond + (refs/sci-atom? ref) (clojure.core/compare-and-set! ref old new) - (if (world/tracked? ref) - (compare-and-set-tracked!* ref old new) - (clojure.core/compare-and-set! ref old new)))) + + (and (world/mutable-primary-world?) + (instance? cljd.core/Atom ref)) + (clojure.core/compare-and-set! ref old new) + + (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + + :else + (clojure.core/compare-and-set! ref old new))) :clj (defn compare-and-set!* [ref old new] - (if (and (world/mutable-primary-world?) - (instance? clojure.lang.IAtom ref)) + (cond + (refs/sci-atom? ref) (clojure.core/compare-and-set! ref old new) - (if (world/tracked? ref) - (compare-and-set-tracked!* ref old new) - (if (instance? clojure.lang.IAtom ref) - ;; fast-path for host IAtoms - (clojure.core/compare-and-set! ref old new) - (compareAndSet ref old new))))) + + (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) + (clojure.core/compare-and-set! ref old new) + + (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + + (instance? clojure.lang.IAtom ref) + (clojure.core/compare-and-set! ref old new) + + :else + (compareAndSet ref old new))) :cljs (defn compare-and-set!* [ref old new] - (if (world/mutable-primary-world?) + (cond + (refs/sci-atom? ref) + (clojure.core/compare-and-set! ref old new) + + (world/mutable-primary-world?) (clojure.core/compare-and-set! ref old new) - (if (world/tracked? ref) - (compare-and-set-tracked!* ref old new) - (clojure.core/compare-and-set! ref old new))))) + + (world/tracked? ref) + (compare-and-set-tracked!* ref old new) + + :else + (clojure.core/compare-and-set! ref old new)))) #?(:clj (defn swap-vals!* [ref f & args] - (if (and (world/mutable-primary-world?) - (instance? clojure.lang.IAtom ref)) + (cond + (refs/sci-atom? ref) + (apply clojure.core/swap-vals! ref f args) + + (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) (apply clojure.core/swap-vals! ref f args) - (if (world/tracked? ref) + + (world/tracked? ref) (if (world/primary-world?) (let [ret (apply clojure.core/swap-vals! ref f args)] (world/reset-value! ref (nth ret 1)) @@ -406,16 +472,24 @@ (let [old (world/value ref nil) new (swap-tracked! ref f args)] [old new])) - (if (instance? clojure.lang.IAtom ref) - (apply clojure.core/swap-vals! ref f args) - (apply swapVals ref f args)))))) + + (instance? clojure.lang.IAtom ref) + (apply clojure.core/swap-vals! ref f args) + + :else + (apply swapVals ref f args)))) #?(:clj (defn reset-vals!* [ref v] - (if (and (world/mutable-primary-world?) - (instance? clojure.lang.IAtom ref)) + (cond + (refs/sci-atom? ref) + (clojure.core/reset-vals! ref v) + + (and (world/mutable-primary-world?) + (instance? clojure.lang.IAtom ref)) (clojure.core/reset-vals! ref v) - (if (world/tracked? ref) + + (world/tracked? ref) (if (world/primary-world?) (let [ret (clojure.core/reset-vals! ref v)] (world/reset-value! ref (nth ret 1)) @@ -423,9 +497,12 @@ (let [old (world/value ref nil) new (reset-tracked! ref v)] [old new])) - (if (instance? clojure.lang.IAtom ref) - (clojure.core/reset-vals! ref v) - (resetVals ref v)))))) + + (instance? clojure.lang.IAtom ref) + (clojure.core/reset-vals! ref v) + + :else + (resetVals ref v)))) ;;;; Protocol vars diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index dd4596f3..f05cbfd2 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -47,6 +47,7 @@ [sci.impl.protocols :as protocols] [sci.impl.read :as read :refer [read read-string]] [sci.impl.records :as records] + [sci.impl.refs :as refs] [sci.impl.reify :as reify] [sci.impl.types :as types] [sci.impl.utils :as utils :refer [eval]] @@ -1081,35 +1082,39 @@ f must be free of side-effects" [iref f & args] - (if (utils/var? iref) - (let [current-meta (meta iref)] - (vars/with-writeable-var iref current-meta - (if (world/current-world) - (let [m (world/alter-var-meta! iref current-meta f args)] - (when (world/primary-world?) - (cljs.core/reset-meta! iref m)) - m) - (apply cljs.core/alter-meta! iref f args)))) - (if (utils/sci-type? iref) - (types/setVal iref (apply f (types/getVal iref) args)) - (let [m (meta iref)] - (if-not (:sci/built-in m) - (apply cljs.core/alter-meta! iref f args) - (throw (ex-info (str "Built-in var " iref " is read-only.") - {:var iref})))))))) - -#?(:cljs - (defn reset-meta! [iref m] - (if (utils/var? iref) - (let [current-meta (meta iref)] - (vars/with-writeable-var iref current-meta - (if (world/current-world) - (do (world/reset-var-meta! iref m) + (if (refs/sci-atom? iref) + (apply refs/alter-meta!* iref f args) + (if (utils/var? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-var iref current-meta + (if (world/current-world) + (let [m (world/alter-var-meta! iref current-meta f args)] (when (world/primary-world?) (cljs.core/reset-meta! iref m)) m) - (cljs.core/reset-meta! iref m)))) - (cljs.core/reset-meta! iref m)))) + (apply cljs.core/alter-meta! iref f args)))) + (if (utils/sci-type? iref) + (types/setVal iref (apply f (types/getVal iref) args)) + (let [m (meta iref)] + (if-not (:sci/built-in m) + (apply cljs.core/alter-meta! iref f args) + (throw (ex-info (str "Built-in var " iref " is read-only.") + {:var iref}))))))))) + +#?(:cljs + (defn reset-meta! [iref m] + (if (refs/sci-atom? iref) + (refs/reset-meta!* iref m) + (if (utils/var? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-var iref current-meta + (if (world/current-world) + (do (world/reset-var-meta! iref m) + (when (world/primary-world?) + (cljs.core/reset-meta! iref m)) + m) + (cljs.core/reset-meta! iref m)))) + (cljs.core/reset-meta! iref m))))) (defn- let** [expr _ bindings & body] (when-not (vector? bindings) @@ -1348,27 +1353,28 @@ (defn promise-then "Chain a callback on a promise. Used by async transformer." [p f] - (.then p f)) + (.then p (vars/binding-continuation-fn f))) (defn promise-catch "Add error handler to a promise. Used by async transformer." [p f] - (.catch p f)) + (.catch p (vars/binding-continuation-fn f))) (defn promise-catch-for-try "Add error handler that unwraps SCI error wrapping before calling handler. SCI's interpreter wraps exceptions with {:type :sci/error} for location tracking, but async catch handlers need the original exception (like sync eval-try uses ex-cause)." [p f] - (.catch p (fn [e] - (f (if (= :sci/error (:type (ex-data e))) - (or (ex-cause e) e) - e))))) + (let [conveyed (vars/binding-continuation-fn f)] + (.catch p (fn [e] + (conveyed (if (= :sci/error (:type (ex-data e))) + (or (ex-cause e) e) + e)))))) (defn promise-finally "Add finally handler to a promise. Used by async transformer." [p f] - (.finally p f)) + (.finally p (vars/binding-continuation-fn f))) (def async-await-namespace (sci.lang/->Namespace 'sci.impl.async-await nil)))) @@ -1711,6 +1717,7 @@ 'get (copy-core-var get) 'get-thread-binding-frame-impl (new-var 'get-thread-binding-frame-impl sci.impl.vars/get-thread-binding-frame) #?@(:clj ['get-thread-bindings (copy-var sci.impl.vars/get-thread-bindings clojure-core-ns {:name 'get-thread-bindings})]) + 'get-validator (copy-var refs/get-validator* clojure-core-ns {:name 'get-validator}) 'get-in (copy-core-var get-in) 'group-by (copy-core-var group-by) 'gensym (copy-core-var gensym) @@ -1911,6 +1918,7 @@ 'str (copy-core-var str) 'second (copy-core-var second) 'set (copy-core-var set) + 'set-validator! (copy-var refs/set-validator!* clojure-core-ns {:name 'set-validator!}) 'seq (copy-core-var seq) 'seq-to-map-for-destructuring (copy-var seq-to-map-for-destructuring clojure-core-ns) 'seq? (copy-core-var seq?) diff --git a/src/sci/impl/refs.cljc b/src/sci/impl/refs.cljc new file mode 100644 index 00000000..ccb5ae85 --- /dev/null +++ b/src/sci/impl/refs.cljc @@ -0,0 +1,325 @@ +(ns sci.impl.refs + "Self-describing mutable references whose state is relative to an SCI world." + (:refer-clojure :exclude [atom]) + (:require [sci.fork :as fork] + [sci.impl.types :as types] + [sci.impl.world :as world])) + +(def ^:private meta-index 0) +(def ^:private validator-index 1) +(def ^:private watches-index 2) + +(declare atom-value atom-reset! atom-reset-vals! atom-swap! atom-swap-vals! + atom-compare-and-set! atom-meta atom-alter-meta! atom-reset-meta! + atom-validator atom-set-validator! atom-watches atom-add-watch! + atom-remove-watch! atom-notify-watches!) + +(deftype SciAtom [home registry value-slot control-slot initial-value initial-control] + fork/Forkable + (fork-value [this] this) + + #?@(:clj + [clojure.lang.IDeref + (deref [this] + (atom-value home registry value-slot initial-value)) + + clojure.lang.IAtom2 + (reset [this new-value] + (atom-reset! this home registry value-slot control-slot + initial-value initial-control new-value)) + (compareAndSet [this old-value new-value] + (atom-compare-and-set! this home registry value-slot control-slot + initial-value initial-control + old-value new-value)) + (swap [this f] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f nil)) + (swap [this f x] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x])) + (swap [this f x y] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x y])) + (swap [this f x y more] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f (list* x y more))) + (resetVals [this new-value] + (atom-reset-vals! this home registry value-slot control-slot + initial-value initial-control new-value)) + (swapVals [this f] + (atom-swap-vals! this home registry value-slot control-slot + initial-value initial-control f nil)) + (swapVals [this f x] + (atom-swap-vals! this home registry value-slot control-slot + initial-value initial-control f [x])) + (swapVals [this f x y] + (atom-swap-vals! this home registry value-slot control-slot + initial-value initial-control f [x y])) + (swapVals [this f x y more] + (atom-swap-vals! this home registry value-slot control-slot + initial-value initial-control f (list* x y more))) + + clojure.lang.IReference + (meta [this] + (atom-meta home registry control-slot initial-control)) + (alterMeta [this f args] + (atom-alter-meta! home registry control-slot initial-control f args)) + (resetMeta [this m] + (atom-reset-meta! home registry control-slot initial-control m)) + + clojure.lang.IRef + (setValidator [this validator] + (atom-set-validator! home registry value-slot control-slot + initial-value initial-control validator)) + (getValidator [this] + (atom-validator home registry control-slot initial-control)) + (getWatches [this] + (atom-watches home registry control-slot initial-control)) + (addWatch [this key f] + (atom-add-watch! home registry control-slot initial-control key f) + this) + (removeWatch [this key] + (atom-remove-watch! home registry control-slot initial-control key) + this)] + + :cljs + [IAtom + IDeref + (-deref [this] + (atom-value home registry value-slot initial-value)) + IReset + (-reset! [this new-value] + (atom-reset! this home registry value-slot control-slot + initial-value initial-control new-value)) + ISwap + (-swap! [this f] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f nil)) + (-swap! [this f x] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x])) + (-swap! [this f x y] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x y])) + (-swap! [this f x y more] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f (list* x y more))) + IMeta + (-meta [this] + (atom-meta home registry control-slot initial-control)) + IWatchable + (-notify-watches [this old-value new-value] + (atom-notify-watches! this home registry control-slot initial-control + old-value new-value)) + (-add-watch [this key f] + (atom-add-watch! home registry control-slot initial-control key f) + this) + (-remove-watch [this key] + (atom-remove-watch! home registry control-slot initial-control key) + this) + IEquiv + (-equiv [this other] (identical? this other)) + IHash + (-hash [this] (goog/getUid this))] + + :cljd + [IDeref + (-deref [this] + (atom-value home registry value-slot initial-value)) + IReset + (-reset! [this new-value] + (atom-reset! this home registry value-slot control-slot + initial-value initial-control new-value)) + ISwap + (-swap! [this f] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f nil)) + (-swap! [this f x] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x])) + (-swap! [this f x y] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f [x y])) + (-swap! [this f x y more] + (atom-swap! this home registry value-slot control-slot + initial-value initial-control f (list* x y more))) + IMeta + (-meta [this] + (atom-meta home registry control-slot initial-control)) + types/IResetMeta + (-reset-meta! [this m] + (atom-reset-meta! home registry control-slot initial-control m)) + IWatchable + (-add-watch [this key f] + (atom-add-watch! home registry control-slot initial-control key f) + this) + (-remove-watch [this key] + (atom-remove-watch! home registry control-slot initial-control key) + this)])) + +(defn sci-atom? [x] + (instance? SciAtom x)) + +(defn- control-value [home registry control-slot initial-control] + (world/managed-value home registry control-slot initial-control)) + +(defn- control-value-in [selected-world control-slot initial-control] + (world/managed-value-in selected-world control-slot initial-control)) + +(defn atom-value [home registry value-slot initial-value] + (world/managed-value home registry value-slot initial-value)) + +(defn atom-meta [home registry control-slot initial-control] + (nth (control-value home registry control-slot initial-control) meta-index)) + +(defn atom-validator [home registry control-slot initial-control] + (nth (control-value home registry control-slot initial-control) + validator-index)) + +(defn atom-watches [home registry control-slot initial-control] + (nth (control-value home registry control-slot initial-control) watches-index)) + +(defn- invalid-state! [] + (throw #?(:cljd (StateError. "Invalid reference state") + :clj (IllegalStateException. "Invalid reference state") + :cljs (js/Error. "Validator rejected reference state")))) + +(defn- validate-in! [selected-world control-slot initial-control value] + (let [control (control-value-in selected-world control-slot initial-control)] + (when-let [validator (nth control validator-index)] + (when-not (validator value) + (invalid-state!))) + control)) + +(defn atom-notify-watches! + ([this control old-value new-value] + (doseq [[key f] (nth control watches-index)] + (f key this old-value new-value)) + nil) + ([this home registry control-slot initial-control old-value new-value] + (atom-notify-watches! + this (control-value home registry control-slot initial-control) + old-value new-value))) + +(defn atom-swap! + [this home registry value-slot control-slot initial-value initial-control f args] + (world/managed-swap! + home registry value-slot initial-value f args + #(validate-in! %1 control-slot initial-control %2) + #(atom-notify-watches! this %2 %3 %4))) + +(defn atom-swap-vals! + [this home registry value-slot control-slot initial-value initial-control f args] + (let [result (volatile! nil)] + (world/managed-swap! + home registry value-slot initial-value + (fn [old] + (let [new (apply f old args)] + (vreset! result [old new]) + new)) + nil + #(validate-in! %1 control-slot initial-control %2) + #(atom-notify-watches! this %2 %3 %4)) + @result)) + +(defn atom-reset! + [this home registry value-slot control-slot initial-value initial-control new-value] + (world/managed-reset! + home registry value-slot initial-value new-value + #(validate-in! %1 control-slot initial-control %2) + #(atom-notify-watches! this %2 %3 %4))) + +(defn atom-reset-vals! + [this home registry value-slot control-slot initial-value initial-control new-value] + (let [result (volatile! nil)] + (world/managed-swap! + home registry value-slot initial-value + (fn [old] + (vreset! result [old new-value]) + new-value) + nil + #(validate-in! %1 control-slot initial-control %2) + #(atom-notify-watches! this %2 %3 %4)) + @result)) + +(defn atom-compare-and-set! + [this home registry value-slot control-slot initial-value initial-control + old-value new-value] + (world/managed-compare-and-set! + home registry value-slot initial-value old-value new-value + #(validate-in! %1 control-slot initial-control %2) + #(atom-notify-watches! this %2 %3 %4))) + +(defn- alter-control! + [home registry control-slot initial-control f] + (world/managed-swap! home registry control-slot initial-control f nil + (fn [_ _] nil) (fn [_ _ _ _] nil))) + +(defn atom-alter-meta! [home registry control-slot initial-control f args] + (nth (alter-control! + home registry control-slot initial-control + #(assoc % meta-index (apply f (nth % meta-index) args))) + meta-index)) + +(defn atom-reset-meta! [home registry control-slot initial-control m] + (nth (alter-control! home registry control-slot initial-control + #(assoc % meta-index m)) + meta-index)) + +(defn atom-set-validator! + [home registry value-slot control-slot initial-value initial-control validator] + (when (and validator + (not (validator (atom-value home registry value-slot initial-value)))) + (invalid-state!)) + (alter-control! home registry control-slot initial-control + #(assoc % validator-index validator)) + nil) + +(defn atom-add-watch! [home registry control-slot initial-control key f] + (alter-control! home registry control-slot initial-control + #(assoc-in % [watches-index key] f))) + +(defn atom-remove-watch! [home registry control-slot initial-control key] + (alter-control! home registry control-slot initial-control + #(update % watches-index dissoc key))) + +(defn atom + "Create an atom whose value and control state fork with its SCI world." + [x & options] + ;; Let the host implementation parse options and enforce its initial + ;; validator semantics; it is only a short-lived construction aid. + (let [template (apply clojure.core/atom x options) + control [(meta template) (get-validator template) {}] + {:keys [home registry slots]} + (world/register-managed! :atom [x control] [0])] + (SciAtom. home registry (nth slots 0) (nth slots 1) x control))) + +(defn get-validator* [ref] + (if (sci-atom? ref) + (let [^SciAtom ref ref] + (atom-validator (.-home ref) (.-registry ref) + (.-control-slot ref) (.-initial-control ref))) + (get-validator ref))) + +(defn set-validator!* [ref validator] + (if (sci-atom? ref) + (let [^SciAtom ref ref] + (atom-set-validator! (.-home ref) (.-registry ref) + (.-value-slot ref) (.-control-slot ref) + (.-initial-value ref) (.-initial-control ref) + validator)) + (set-validator! ref validator))) + +(defn alter-meta!* [ref f & args] + (if (sci-atom? ref) + (let [^SciAtom ref ref] + (atom-alter-meta! (.-home ref) (.-registry ref) + (.-control-slot ref) (.-initial-control ref) f args)) + (apply alter-meta! ref f args))) + +(defn reset-meta!* [ref m] + (if (sci-atom? ref) + (let [^SciAtom ref ref] + (atom-reset-meta! (.-home ref) (.-registry ref) + (.-control-slot ref) (.-initial-control ref) m)) + (reset-meta! ref m))) diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index 525252d7..0dd04a74 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -188,16 +188,17 @@ :clj (.get ^java.util.Map bmap sci-var) :cljs (.get bmap sci-var)))) -(defn binding-conveyor-fn - [f] - (let [frame (clone-thread-binding-frame) - ctx store/*ctx* - invoke (fn [args] - (reset-thread-binding-frame frame) - (if (:sci.impl/world ctx) - (store/with-ctx ctx - (world/with-active-world ctx #(apply f args))) - (apply f args)))] +(defn- binding-frame-fn [frame ctx f] + (let [invoke (fn [args] + (let [previous (get-thread-binding-frame)] + (try + (reset-thread-binding-frame frame) + (if (:sci.impl/world ctx) + (store/with-ctx ctx + (world/with-active-world ctx #(apply f args))) + (apply f args)) + (finally + (reset-thread-binding-frame previous)))))] (fn ([] (invoke nil)) @@ -210,6 +211,19 @@ ([x y z & args] (invoke (list* x y z args)))))) +(defn binding-conveyor-fn + "Convey the current binding values to an independent task. The shallow + frame deliberately cannot pop scopes owned by the submitting execution." + [f] + (binding-frame-fn (clone-thread-binding-frame) store/*ctx* f)) + +(defn binding-continuation-fn + "Convey the persistent binding frame chain to a continuation of the current + execution. Unlike an independent task, the continuation may leave scopes + entered before suspension." + [f] + (binding-frame-fn (get-thread-binding-frame) store/*ctx* f)) + (defn throw-unbound-call-exception [the-var] (throw #?(:cljd (ex-info (str "Attempting to call unbound fn: " the-var) {}) :clj (new IllegalStateException (str "Attempting to call unbound fn: " the-var)) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 33674731..8f8069bf 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -80,7 +80,7 @@ (defn new-world [] (DenseWorld. (volatile! (new-cells 64)) - (atom {:next-slot 0 :descriptors {}}) + (atom {:next-slot 0 :descriptors {} :managed-descriptors []}) #?(:clj (ReentrantReadWriteLock.) :default nil) (volatile! false))) @@ -223,6 +223,110 @@ (assoc-in [:descriptors handle] desc)))) desc)))))) +(defn register-managed! + "Allocate dense slots whose owner carries the returned descriptor directly. + Managed descriptors contain no owner reference, so an unreachable SCI ref is + not retained by the lineage registry. `fork-indexes` names values that need + host `Forkable`/`:fork-fn` processing when a child world is copied." + [kind values fork-indexes] + (let [^DenseWorld world (current-world)] + (when-not world + (throw (ex-info "Managed SCI state must be created inside an SCI context." + {:kind kind}))) + (let [registry (.-registry world) + desc (with-registry-lock + registry + (fn [] + (let [start (:next-slot @registry) + slots (mapv #(+ start %) (range (count values))) + fork-slots (mapv #(nth slots %) fork-indexes) + desc {:kind kind + :slots slots + :fork-slots fork-slots}] + (swap! registry + (fn [r] + (-> r + (assoc :next-slot (+ start (count values))) + (update :managed-descriptors conj desc)))) + desc)))] + (ensure-capacity! world (:next-slot @registry)) + (doseq [[slot value] (map vector (:slots desc) values)] + (cells-set! (current-cells world) slot value)) + (assoc desc :home world :registry registry)))) + +(defn- selected-managed-world [^DenseWorld home registry] + (let [active (active-world-state)] + (if (and active + (identical? registry + (.-registry ^DenseWorld (.-world ^ReadWorld active)))) + (.-world ^ReadWorld active) + home))) + +(defn managed-value + "Read a self-described managed slot in the active related world, falling + back to the owner's creation world outside managed evaluation." + [home registry slot fallback] + (slot-value (selected-managed-world home registry) slot fallback)) + +(defn managed-value-in + "Read a managed slot from an already selected world." + [world slot fallback] + (slot-value world slot fallback)) + +(defn- call-with-managed-mutation [^DenseWorld home registry f] + (let [active (active-world-state) + related? (and active + (identical? registry + (.-registry ^DenseWorld + (.-world ^ReadWorld active)))) + ^DenseWorld world (if related? (.-world ^ReadWorld active) home)] + #?(:clj + (if related? + (f world) + (let [lock (.readLock ^ReentrantReadWriteLock (.-gate world))] + (.lock lock) + (try (f world) (finally (.unlock lock))))) + :default + (f world)))) + +(defn managed-swap! + "CAS a directly described slot. The logical fallback represents a slot + allocated in another branch but not yet realized in the selected world." + [home registry slot fallback f args validate! notify!] + (call-with-managed-mutation + home registry + (fn [^DenseWorld world] + (ensure-capacity! world (inc slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells slot) + old (if (identical? absent raw-old) fallback raw-old) + new (apply f old args) + validation (validate! world new)] + (if (cells-cas! cells slot raw-old new) + (do (notify! world validation old new) new) + (recur))))))) + +(defn managed-reset! [home registry slot fallback new validate! notify!] + (managed-swap! home registry slot fallback (constantly new) nil + validate! notify!)) + +(defn managed-compare-and-set! + [home registry slot fallback expected new validate! notify!] + (call-with-managed-mutation + home registry + (fn [^DenseWorld world] + (ensure-capacity! world (inc slot)) + (let [cells (current-cells world) + raw-old (cells-get cells slot) + old (if (identical? absent raw-old) fallback raw-old)] + (if-not (identical? expected old) + false + (let [validation (validate! world new)] + (if (cells-cas! cells slot raw-old new) + (do (notify! world validation old new) true) + false))))))) + (defn register! [handle value] (when-let [^DenseWorld world (current-world)] (let [{:keys [value-slot]} (allocate-descriptor! world handle :ref true)] @@ -332,7 +436,9 @@ n (cells-length source) target (new-cells n) registry (.-registry world) - descriptors (:descriptors @registry) + registry-state @registry + descriptors (:descriptors registry-state) + managed-descriptors (:managed-descriptors registry-state) handles (set (keys descriptors))] (dotimes [i n] (cells-set! target i (cells-get source i))) @@ -343,7 +449,13 @@ :let [v (cells-get target value-slot)] :when (not (identical? absent v))] (cells-set! target value-slot - (if (contains? handles v) v (fork-value v))))) + (if (contains? handles v) v (fork-value v)))) + (doseq [{:keys [fork-slots]} managed-descriptors + slot fork-slots + :when (< slot n) + :let [v (cells-get target slot)] + :when (not (identical? absent v))] + (cells-set! target slot (fork-value v)))) (DenseWorld. (volatile! target) registry diff --git a/test/sci/async_await_test.cljs b/test/sci/async_await_test.cljs index c5f0675b..42306682 100644 --- a/test/sci/async_await_test.cljs +++ b/test/sci/async_await_test.cljs @@ -555,3 +555,22 @@ (is (= :ok docstring))) (p/catch (fn [e] (is false (str "threw: " (.-message e))))) (p/finally done))))) + +(deftest async-dynamic-binding-and-world-test + (testing "await continuations retain their SCI world and binding frame" + (async done + (-> (p/let [ctx (sci/init {:classes {'js js/globalThis :allow :all}}) + v (sci/eval-string* + ctx + "(def ^:dynamic *scope* :root) + (defn ^:async retained-state [] + (binding [*scope* :bound] + (let [before *scope* + awaited (await (js/Promise.resolve :ready)) + state (atom awaited)] + [before *scope* @state]))) + (retained-state)")] + (is (= [:bound :bound :ready] v)) + (is (= :root (sci/eval-string* ctx "*scope*")))) + (p/catch (fn [e] (is false (str "threw: " (.-message e))))) + (p/finally done))))) diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 69ba2823..caea2a1a 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1497,6 +1497,43 @@ (is (= [4 7 11 true] (sci/eval-string* child "(state)"))) (is (= [2 5 9 true] (sci/eval-string* grandchild "(state)"))))))) +(deftest forked-atom-control-state-test + (let [parent (sci/init nil) + a (sci/eval-string* + parent + "(def events (atom [])) + (def a (atom 2 :meta {:branch :parent} :validator even?)) + (add-watch a :inherited + (fn [key _ old new] + (swap! events conj [key old new]))) + a") + child (sci/fork parent)] + (testing "value, metadata, validators, and watches are child-local" + (is (= [6 [[:inherited 2 4] [:child 4 6]] + {:branch :child} true] + (sci/eval-string* + child + "(reset! a 4) + (remove-watch a :inherited) + (add-watch a :child + (fn [key _ old new] + (swap! events conj [key old new]))) + (alter-meta! a assoc :branch :child) + (set-validator! a #(>= % 4)) + (compare-and-set! a 4 6) + [@a @events (meta a) ((get-validator a) 5)]"))) + (is (= [2 [] {:branch :parent} true] + (sci/eval-string* + parent + "[@a @events (meta a) (= even? (get-validator a))]")))) + (testing "a stable handle outside evaluation uses its creation world" + (is (= 2 @a)) + (is (= 8 (reset! a 8))) + (is (= [8 [[:inherited 2 8]]] + (sci/eval-string* parent "[@a @events]"))) + (is (= [6 [[:inherited 2 4] [:child 4 6]]] + (sci/eval-string* child "[@a @events]")))))) + (deftest forkable-host-value-test (let [user-ns (sci/create-ns 'user) copies (atom 0) From 8b04ce8e5e36f35de09fa9bc41d0feeb17926605 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 04:03:29 -0700 Subject: [PATCH 09/31] Release unreachable managed atom state before forks --- doc/fork-state-audit.md | 41 +++++--- doc/forking.md | 9 ++ src/sci/impl/refs.cljc | 211 ++++++++++++++++++---------------------- src/sci/impl/world.cljc | 71 +++++++++++--- 4 files changed, 190 insertions(+), 142 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 58ef4259..dda3578e 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -176,18 +176,27 @@ mutable internals have not yet been decomposed into world state. ## Dense-registry liveness -The lineage registry currently holds strong keys for every registered Var and -volatile, and `:next-slot` only increases. Self-describing atoms no longer add -their object as a registry key, but their anonymous descriptors and slot -values are still retained. This has two consequences: - -1. A local `(atom ...)` object can be collected, but its last value and control - record remain reachable from every world that realized its slots. Registry- - routed refs also retain their handle. -2. Vars or refs created only in a discarded child reserve slots in the shared +The lineage registry still holds strong keys for every registered Var and +registry-routed volatile, and `:next-slot` only increases. Self-describing +atoms do not add their object as a registry key. Their anonymous descriptor +holds a weak owner reference on JVM and CLJS, and a fork first clears the +source world's slots for dead owners. This releases the atom's value and +control payload before copying them into another world. + +This is a partial liveness solution with three remaining consequences: + +1. Anonymous descriptors, slot numbers, and dense-array capacity are not + reclaimed, so short-lived atoms can still increase later fork traversal. +2. Other dormant worlds retain a dead owner's payload until that world is next + used as a fork source. A payload or watch that points back to the atom also + creates a cycle that the weak-owner test cannot break. +3. Vars or refs created only in a discarded child reserve slots in the shared lineage registry. Later allocation in a parent can expand across those branch-local holes, increasing all subsequent copy-on-fork costs. +ClojureDart currently has no portable weak-owner implementation, so its +descriptor is non-owning but its payload sweep is disabled. + Dense slots therefore need a liveness strategy. The main choices are: - custom SCI state handles carrying their lineage/slot descriptor, with weak @@ -214,12 +223,14 @@ copying the watch map preserves Clojure behavior inside each branch but still requires the callback's external capabilities to be honest. This is now implemented by a two-slot `SciAtom`. Its direct slot descriptor -avoids the lineage handle lookup on dereference and mutation. A focused local -JVM comparison measured five million child-world reads at roughly 72 ms versus -243 ms through the former registry route, and 500,000 swaps at 36 ms versus 67 -ms. A host atom in the same probe took roughly 27 ms and 5.5 ms respectively; -the remaining cost buys world selection and fork-local control state. These -figures describe one local microbenchmark, not a portable guarantee. +avoids the lineage handle lookup on dereference and mutation. In a same-machine +powersave-profile JVM comparison, five million child-world reads took a median +269 ms versus 661 ms through the former registry route (about 2.46 times +faster), and 500,000 swaps took 107 ms versus 192 ms (about 1.79 times faster). +The corresponding host-atom medians were 80 ms and 16 ms. Absolute timings +move substantially with CPU power policy; the old and new implementations +were measured together under the same policy, and these figures remain a local +microbenchmark rather than a portable guarantee. ### Delay diff --git a/doc/forking.md b/doc/forking.md index 466e2307..6ae0e287 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -89,6 +89,15 @@ case where reads and mutations greatly outnumber forks. A page-level copy-on-write representation remains a possible next step if workloads with large worlds and frequent forks justify its extra read/write indirection. +Self-describing SCI state handles are held weakly by the lineage registry. A +fork sweeps the source world's slots for handles that have become unreachable, +so an abandoned local atom does not retain its last value, metadata, validator, +or watches indefinitely. Slot numbers and array capacity are not currently +reclaimed; sweep bounds retained payloads but does not yet reduce the cost of +forking a lineage that allocated many short-lived handles. A value or watch +that refers back to its own atom also forms a world-to-value ownership cycle +and cannot be discovered by the weak-handle sweep alone. + See [Forkable runtime state audit](fork-state-audit.md) for the dynamic-binding model, stateful primitive inventory, observed isolation gaps, and proposed implementation order. diff --git a/src/sci/impl/refs.cljc b/src/sci/impl/refs.cljc index ccb5ae85..4732e608 100644 --- a/src/sci/impl/refs.cljc +++ b/src/sci/impl/refs.cljc @@ -14,108 +14,94 @@ atom-validator atom-set-validator! atom-watches atom-add-watch! atom-remove-watch! atom-notify-watches!) -(deftype SciAtom [home registry value-slot control-slot initial-value initial-control] +(deftype SciAtom [home registry value-slot control-slot] fork/Forkable (fork-value [this] this) #?@(:clj [clojure.lang.IDeref (deref [this] - (atom-value home registry value-slot initial-value)) + (atom-value home registry value-slot)) clojure.lang.IAtom2 (reset [this new-value] - (atom-reset! this home registry value-slot control-slot - initial-value initial-control new-value)) + (atom-reset! this home registry value-slot control-slot new-value)) (compareAndSet [this old-value new-value] (atom-compare-and-set! this home registry value-slot control-slot - initial-value initial-control old-value new-value)) (swap [this f] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f nil)) + (atom-swap! this home registry value-slot control-slot f nil)) (swap [this f x] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x])) + (atom-swap! this home registry value-slot control-slot f [x])) (swap [this f x y] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x y])) + (atom-swap! this home registry value-slot control-slot f [x y])) (swap [this f x y more] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f (list* x y more))) + (atom-swap! this home registry value-slot control-slot f + (list* x y more))) (resetVals [this new-value] - (atom-reset-vals! this home registry value-slot control-slot - initial-value initial-control new-value)) + (atom-reset-vals! this home registry value-slot control-slot new-value)) (swapVals [this f] - (atom-swap-vals! this home registry value-slot control-slot - initial-value initial-control f nil)) + (atom-swap-vals! this home registry value-slot control-slot f nil)) (swapVals [this f x] - (atom-swap-vals! this home registry value-slot control-slot - initial-value initial-control f [x])) + (atom-swap-vals! this home registry value-slot control-slot f [x])) (swapVals [this f x y] - (atom-swap-vals! this home registry value-slot control-slot - initial-value initial-control f [x y])) + (atom-swap-vals! this home registry value-slot control-slot f [x y])) (swapVals [this f x y more] - (atom-swap-vals! this home registry value-slot control-slot - initial-value initial-control f (list* x y more))) + (atom-swap-vals! this home registry value-slot control-slot f + (list* x y more))) clojure.lang.IReference (meta [this] - (atom-meta home registry control-slot initial-control)) + (atom-meta home registry control-slot)) (alterMeta [this f args] - (atom-alter-meta! home registry control-slot initial-control f args)) + (atom-alter-meta! home registry control-slot f args)) (resetMeta [this m] - (atom-reset-meta! home registry control-slot initial-control m)) + (atom-reset-meta! home registry control-slot m)) clojure.lang.IRef (setValidator [this validator] - (atom-set-validator! home registry value-slot control-slot - initial-value initial-control validator)) + (atom-set-validator! home registry value-slot control-slot validator)) (getValidator [this] - (atom-validator home registry control-slot initial-control)) + (atom-validator home registry control-slot)) (getWatches [this] - (atom-watches home registry control-slot initial-control)) + (atom-watches home registry control-slot)) (addWatch [this key f] - (atom-add-watch! home registry control-slot initial-control key f) + (atom-add-watch! home registry control-slot key f) this) (removeWatch [this key] - (atom-remove-watch! home registry control-slot initial-control key) + (atom-remove-watch! home registry control-slot key) this)] :cljs [IAtom IDeref (-deref [this] - (atom-value home registry value-slot initial-value)) + (atom-value home registry value-slot)) IReset (-reset! [this new-value] - (atom-reset! this home registry value-slot control-slot - initial-value initial-control new-value)) + (atom-reset! this home registry value-slot control-slot new-value)) ISwap (-swap! [this f] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f nil)) + (atom-swap! this home registry value-slot control-slot f nil)) (-swap! [this f x] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x])) + (atom-swap! this home registry value-slot control-slot f [x])) (-swap! [this f x y] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x y])) + (atom-swap! this home registry value-slot control-slot f [x y])) (-swap! [this f x y more] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f (list* x y more))) + (atom-swap! this home registry value-slot control-slot f + (list* x y more))) IMeta (-meta [this] - (atom-meta home registry control-slot initial-control)) + (atom-meta home registry control-slot)) IWatchable (-notify-watches [this old-value new-value] - (atom-notify-watches! this home registry control-slot initial-control + (atom-notify-watches! this home registry control-slot old-value new-value)) (-add-watch [this key f] - (atom-add-watch! home registry control-slot initial-control key f) + (atom-add-watch! home registry control-slot key f) this) (-remove-watch [this key] - (atom-remove-watch! home registry control-slot initial-control key) + (atom-remove-watch! home registry control-slot key) this) IEquiv (-equiv [this other] (identical? this other)) @@ -123,69 +109,64 @@ (-hash [this] (goog/getUid this))] :cljd - [IDeref + [IDeref (-deref [this] - (atom-value home registry value-slot initial-value)) + (atom-value home registry value-slot)) IReset (-reset! [this new-value] - (atom-reset! this home registry value-slot control-slot - initial-value initial-control new-value)) + (atom-reset! this home registry value-slot control-slot new-value)) ISwap (-swap! [this f] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f nil)) + (atom-swap! this home registry value-slot control-slot f nil)) (-swap! [this f x] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x])) + (atom-swap! this home registry value-slot control-slot f [x])) (-swap! [this f x y] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f [x y])) + (atom-swap! this home registry value-slot control-slot f [x y])) (-swap! [this f x y more] - (atom-swap! this home registry value-slot control-slot - initial-value initial-control f (list* x y more))) + (atom-swap! this home registry value-slot control-slot f + (list* x y more))) IMeta (-meta [this] - (atom-meta home registry control-slot initial-control)) + (atom-meta home registry control-slot)) types/IResetMeta (-reset-meta! [this m] - (atom-reset-meta! home registry control-slot initial-control m)) + (atom-reset-meta! home registry control-slot m)) IWatchable (-add-watch [this key f] - (atom-add-watch! home registry control-slot initial-control key f) + (atom-add-watch! home registry control-slot key f) this) (-remove-watch [this key] - (atom-remove-watch! home registry control-slot initial-control key) + (atom-remove-watch! home registry control-slot key) this)])) (defn sci-atom? [x] (instance? SciAtom x)) -(defn- control-value [home registry control-slot initial-control] - (world/managed-value home registry control-slot initial-control)) +(defn- control-value [home registry control-slot] + (world/managed-value home registry control-slot)) -(defn- control-value-in [selected-world control-slot initial-control] - (world/managed-value-in selected-world control-slot initial-control)) +(defn- control-value-in [selected-world home control-slot] + (world/managed-value-in selected-world home control-slot)) -(defn atom-value [home registry value-slot initial-value] - (world/managed-value home registry value-slot initial-value)) +(defn atom-value [home registry value-slot] + (world/managed-value home registry value-slot)) -(defn atom-meta [home registry control-slot initial-control] - (nth (control-value home registry control-slot initial-control) meta-index)) +(defn atom-meta [home registry control-slot] + (nth (control-value home registry control-slot) meta-index)) -(defn atom-validator [home registry control-slot initial-control] - (nth (control-value home registry control-slot initial-control) - validator-index)) +(defn atom-validator [home registry control-slot] + (nth (control-value home registry control-slot) validator-index)) -(defn atom-watches [home registry control-slot initial-control] - (nth (control-value home registry control-slot initial-control) watches-index)) +(defn atom-watches [home registry control-slot] + (nth (control-value home registry control-slot) watches-index)) (defn- invalid-state! [] (throw #?(:cljd (StateError. "Invalid reference state") :clj (IllegalStateException. "Invalid reference state") :cljs (js/Error. "Validator rejected reference state")))) -(defn- validate-in! [selected-world control-slot initial-control value] - (let [control (control-value-in selected-world control-slot initial-control)] +(defn- validate-in! [selected-world home control-slot value] + (let [control (control-value-in selected-world home control-slot)] (when-let [validator (nth control validator-index)] (when-not (validator value) (invalid-state!))) @@ -196,91 +177,90 @@ (doseq [[key f] (nth control watches-index)] (f key this old-value new-value)) nil) - ([this home registry control-slot initial-control old-value new-value] + ([this home registry control-slot old-value new-value] (atom-notify-watches! - this (control-value home registry control-slot initial-control) + this (control-value home registry control-slot) old-value new-value))) (defn atom-swap! - [this home registry value-slot control-slot initial-value initial-control f args] + [this home registry value-slot control-slot f args] (world/managed-swap! - home registry value-slot initial-value f args - #(validate-in! %1 control-slot initial-control %2) + home registry value-slot f args + #(validate-in! %1 home control-slot %2) #(atom-notify-watches! this %2 %3 %4))) (defn atom-swap-vals! - [this home registry value-slot control-slot initial-value initial-control f args] + [this home registry value-slot control-slot f args] (let [result (volatile! nil)] (world/managed-swap! - home registry value-slot initial-value + home registry value-slot (fn [old] (let [new (apply f old args)] (vreset! result [old new]) new)) nil - #(validate-in! %1 control-slot initial-control %2) + #(validate-in! %1 home control-slot %2) #(atom-notify-watches! this %2 %3 %4)) @result)) (defn atom-reset! - [this home registry value-slot control-slot initial-value initial-control new-value] + [this home registry value-slot control-slot new-value] (world/managed-reset! - home registry value-slot initial-value new-value - #(validate-in! %1 control-slot initial-control %2) + home registry value-slot new-value + #(validate-in! %1 home control-slot %2) #(atom-notify-watches! this %2 %3 %4))) (defn atom-reset-vals! - [this home registry value-slot control-slot initial-value initial-control new-value] + [this home registry value-slot control-slot new-value] (let [result (volatile! nil)] (world/managed-swap! - home registry value-slot initial-value + home registry value-slot (fn [old] (vreset! result [old new-value]) new-value) nil - #(validate-in! %1 control-slot initial-control %2) + #(validate-in! %1 home control-slot %2) #(atom-notify-watches! this %2 %3 %4)) @result)) (defn atom-compare-and-set! - [this home registry value-slot control-slot initial-value initial-control - old-value new-value] + [this home registry value-slot control-slot old-value new-value] (world/managed-compare-and-set! - home registry value-slot initial-value old-value new-value - #(validate-in! %1 control-slot initial-control %2) + home registry value-slot old-value new-value + #(validate-in! %1 home control-slot %2) #(atom-notify-watches! this %2 %3 %4))) (defn- alter-control! - [home registry control-slot initial-control f] - (world/managed-swap! home registry control-slot initial-control f nil + [home registry control-slot f] + (world/managed-swap! home registry control-slot f nil (fn [_ _] nil) (fn [_ _ _ _] nil))) -(defn atom-alter-meta! [home registry control-slot initial-control f args] +(defn atom-alter-meta! [home registry control-slot f args] (nth (alter-control! - home registry control-slot initial-control + home registry control-slot #(assoc % meta-index (apply f (nth % meta-index) args))) meta-index)) -(defn atom-reset-meta! [home registry control-slot initial-control m] - (nth (alter-control! home registry control-slot initial-control +(defn atom-reset-meta! [home registry control-slot m] + (nth (alter-control! home registry control-slot #(assoc % meta-index m)) meta-index)) (defn atom-set-validator! - [home registry value-slot control-slot initial-value initial-control validator] + [home registry value-slot control-slot validator] (when (and validator - (not (validator (atom-value home registry value-slot initial-value)))) + (not (validator (atom-value home registry value-slot)))) (invalid-state!)) - (alter-control! home registry control-slot initial-control + (alter-control! home registry control-slot #(assoc % validator-index validator)) nil) -(defn atom-add-watch! [home registry control-slot initial-control key f] - (alter-control! home registry control-slot initial-control +(defn atom-add-watch! [home registry control-slot key f] + (alter-control! home registry control-slot #(assoc-in % [watches-index key] f))) -(defn atom-remove-watch! [home registry control-slot initial-control key] - (alter-control! home registry control-slot initial-control +(defn atom-remove-watch! [home registry control-slot key] + (alter-control! home registry control-slot #(update % watches-index dissoc key))) (defn atom @@ -290,15 +270,17 @@ ;; validator semantics; it is only a short-lived construction aid. (let [template (apply clojure.core/atom x options) control [(meta template) (get-validator template) {}] - {:keys [home registry slots]} + {:keys [home registry slots managed-index]} (world/register-managed! :atom [x control] [0])] - (SciAtom. home registry (nth slots 0) (nth slots 1) x control))) + (world/attach-managed-owner! + registry managed-index + (SciAtom. home registry (nth slots 0) (nth slots 1))))) (defn get-validator* [ref] (if (sci-atom? ref) (let [^SciAtom ref ref] (atom-validator (.-home ref) (.-registry ref) - (.-control-slot ref) (.-initial-control ref))) + (.-control-slot ref))) (get-validator ref))) (defn set-validator!* [ref validator] @@ -306,7 +288,6 @@ (let [^SciAtom ref ref] (atom-set-validator! (.-home ref) (.-registry ref) (.-value-slot ref) (.-control-slot ref) - (.-initial-value ref) (.-initial-control ref) validator)) (set-validator! ref validator))) @@ -314,12 +295,12 @@ (if (sci-atom? ref) (let [^SciAtom ref ref] (atom-alter-meta! (.-home ref) (.-registry ref) - (.-control-slot ref) (.-initial-control ref) f args)) + (.-control-slot ref) f args)) (apply alter-meta! ref f args))) (defn reset-meta!* [ref m] (if (sci-atom? ref) (let [^SciAtom ref ref] (atom-reset-meta! (.-home ref) (.-registry ref) - (.-control-slot ref) (.-initial-control ref) m)) + (.-control-slot ref) m)) (reset-meta! ref m))) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 8f8069bf..8979d431 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -7,7 +7,8 @@ unrelated atoms never contend on a shared world root." (:require [sci.ctx-store :as store] [sci.impl.execution :as execution]) - #?(:clj (:import [java.util.concurrent.atomic AtomicReferenceArray] + #?(:clj (:import [java.lang.ref WeakReference] + [java.util.concurrent.atomic AtomicReferenceArray] [java.util.concurrent.locks ReentrantReadWriteLock]))) (def absent #?(:cljd (Object.) :clj (Object.) :cljs (js/Object.))) @@ -240,9 +241,12 @@ (let [start (:next-slot @registry) slots (mapv #(+ start %) (range (count values))) fork-slots (mapv #(nth slots %) fork-indexes) + managed-index (count (:managed-descriptors @registry)) desc {:kind kind + :managed-index managed-index :slots slots - :fork-slots fork-slots}] + :fork-slots fork-slots + :owner-ref nil}] (swap! registry (fn [r] (-> r @@ -254,6 +258,39 @@ (cells-set! (current-cells world) slot value)) (assoc desc :home world :registry registry)))) +(defn attach-managed-owner! + "Attach weak ownership after constructing a self-described handle. The + owner is never retained strongly by the lineage registry." + [registry managed-index owner] + (let [owner-ref #?(:clj (WeakReference. owner) + :cljs (when (exists? js/WeakRef) (js/WeakRef. owner)) + ;; Dart weak-reference availability varies with the host + ;; SDK. The descriptor remains non-owning until a + ;; portable implementation is available. + :cljd nil)] + (when owner-ref + (with-registry-lock + registry + #(swap! registry assoc-in + [:managed-descriptors managed-index :owner-ref] + owner-ref))) + owner)) + +(defn- live-managed-owner? [owner-ref] + (or (nil? owner-ref) + #?(:clj (some? (.get ^WeakReference owner-ref)) + :cljs (some? (.deref owner-ref)) + :cljd true))) + +(defn- sweep-managed! [^DenseWorld world] + (let [cells (current-cells world)] + (doseq [{:keys [owner-ref slots]} + (:managed-descriptors @(.-registry world)) + :when (not (live-managed-owner? owner-ref)) + slot slots + :when (< slot (cells-length cells))] + (cells-set! cells slot absent)))) + (defn- selected-managed-world [^DenseWorld home registry] (let [active (active-world-state)] (if (and active @@ -265,13 +302,18 @@ (defn managed-value "Read a self-described managed slot in the active related world, falling back to the owner's creation world outside managed evaluation." - [home registry slot fallback] - (slot-value (selected-managed-world home registry) slot fallback)) + [home registry slot] + (let [selected (selected-managed-world home registry)] + (if (identical? selected home) + (slot-value selected slot absent) + (slot-value selected slot (slot-value home slot absent))))) (defn managed-value-in "Read a managed slot from an already selected world." - [world slot fallback] - (slot-value world slot fallback)) + [world home slot] + (if (identical? world home) + (slot-value world slot absent) + (slot-value world slot (slot-value home slot absent)))) (defn- call-with-managed-mutation [^DenseWorld home registry f] (let [active (active-world-state) @@ -292,7 +334,7 @@ (defn managed-swap! "CAS a directly described slot. The logical fallback represents a slot allocated in another branch but not yet realized in the selected world." - [home registry slot fallback f args validate! notify!] + [home registry slot f args validate! notify!] (call-with-managed-mutation home registry (fn [^DenseWorld world] @@ -300,26 +342,30 @@ (loop [] (let [cells (current-cells world) raw-old (cells-get cells slot) - old (if (identical? absent raw-old) fallback raw-old) + old (if (identical? absent raw-old) + (slot-value home slot absent) + raw-old) new (apply f old args) validation (validate! world new)] (if (cells-cas! cells slot raw-old new) (do (notify! world validation old new) new) (recur))))))) -(defn managed-reset! [home registry slot fallback new validate! notify!] - (managed-swap! home registry slot fallback (constantly new) nil +(defn managed-reset! [home registry slot new validate! notify!] + (managed-swap! home registry slot (constantly new) nil validate! notify!)) (defn managed-compare-and-set! - [home registry slot fallback expected new validate! notify!] + [home registry slot expected new validate! notify!] (call-with-managed-mutation home registry (fn [^DenseWorld world] (ensure-capacity! world (inc slot)) (let [cells (current-cells world) raw-old (cells-get cells slot) - old (if (identical? absent raw-old) fallback raw-old)] + old (if (identical? absent raw-old) + (slot-value home slot absent) + raw-old)] (if-not (identical? expected old) false (let [validation (validate! world new)] @@ -432,6 +478,7 @@ world) (defn- copy-world [^DenseWorld world fork-value] + (sweep-managed! world) (let [source (current-cells world) n (cells-length source) target (new-cells n) From 58963d1b35e910f95678c265187fb6e891f114f2 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 04:39:33 -0700 Subject: [PATCH 10/31] Make SCI multimethods fork-local --- doc/fork-state-audit.md | 24 ++- doc/forking.md | 22 ++- src/sci/impl/multimethods.cljc | 277 ++++++++++++++++++++++++++++---- src/sci/impl/namespaces.cljc | 23 +-- src/sci/impl/protocols.cljc | 29 ++-- src/sci/impl/world.cljc | 10 +- test/sci/multimethods_test.cljc | 41 +++++ 7 files changed, 360 insertions(+), 66 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index dda3578e..0380a74a 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -139,7 +139,8 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | | Transient collection | Same affine host object | Shared; mutation in child is visible in parent | | Array / JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | -| Multimethod tables and caches | Mutable internals of one MultiFn root | Shared; a child `defmethod` changes parent dispatch | +| JVM/CLJS SCI multimethod tables, preferences, and caches | Stable `SciMultiFn` handle with a fork-local host dispatch engine | Implemented; method mutations use copy-on-write and caches are rebuilt per fork | +| ClojureDart SCI multimethod tables | Mutable atom inside one `SciMultiFn` root | Shared; managed representation remains to be ported | | Protocol/type extension registries | Mutable Type/protocol realization objects | Shared in several host-specific paths | | Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | | Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | @@ -225,9 +226,9 @@ requires the callback's external capabilities to be honest. This is now implemented by a two-slot `SciAtom`. Its direct slot descriptor avoids the lineage handle lookup on dereference and mutation. In a same-machine powersave-profile JVM comparison, five million child-world reads took a median -269 ms versus 661 ms through the former registry route (about 2.46 times -faster), and 500,000 swaps took 107 ms versus 192 ms (about 1.79 times faster). -The corresponding host-atom medians were 80 ms and 16 ms. Absolute timings +201 ms versus 661 ms through the former registry route (about 3.29 times +faster), and 500,000 swaps took 110 ms versus 192 ms (about 1.75 times faster). +The corresponding host-atom medians were 78 ms and 16 ms. Absolute timings move substantially with CPU power policy; the old and new implementations were measured together under the same policy, and these figures remain a local microbenchmark rather than a portable guarantee. @@ -269,6 +270,18 @@ slots. Dispatch caches are derived state and can be copied or discarded on fork. The hierarchy is already reached through a fork-local Var root. This is a relatively contained next primitive and exercises multi-slot handles well. +This is implemented on JVM and CLJS with one managed state slot. Its value owns +a native host dispatch engine, preserving the host's hierarchy, preference, +ambiguity, and cache behavior. A method-table mutation clones the logical +engine and installs it with a slot CAS; a fork clones it with an empty derived +cache. Thus a fork cannot race with an in-place method-table update, while the +common dispatch path pays only world selection and a direct slot read before +using the native cache. In a deliberately harsh direct-host-call benchmark +that added roughly 15--18 percent over the previous shared host `MultiFn`; in +an interpreted million-call loop, repeated runs ranged from approximately +noise to nine percent. ClojureDart retains its earlier shared table pending a +portable managed implementation and test runtime. + ### Memoization and lazy computation SCI should provide a world-aware memoize implementation whose cache is a @@ -294,7 +307,8 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. create an unbounded retention problem. 4. Finish split identity/state for Var watches, namespace/type metadata, volatiles, and `*loaded-libs*`. -5. Make multimethod tables and memoization caches world-local. +5. Finish the ClojureDart multimethod port and make memoization caches + world-local. JVM/CLJS multimethod state is implemented. 6. Add managed Delay and choose a pending-Promise policy. 7. Reject or explicitly classify transients, running futures, streams, and other affine/external resources. diff --git a/doc/forking.md b/doc/forking.md index 6ae0e287..bbf7fee2 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -68,13 +68,14 @@ application's responsibility, for example with an identity-keyed memo table. ## Current boundary -Var roots/metadata, all logical SCI atom state, and SCI-created volatile values -are fork-local. Atom metadata, validator, and watch maps are inherited by a -fork and can subsequently diverge; effects performed by a watch are ordinary -user capabilities and are not made reversible automatically. Promises, -delays, futures, transients, mutable host objects, mutable deftype fields, and -effects outside SCI remain shared unless the embedding application models or -copies them. +Var roots/metadata, all logical SCI atom state, SCI-created volatile values, +and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are +fork-local. Atom metadata, validator, and watch maps are inherited by a fork +and can subsequently diverge; effects performed by a watch are ordinary user +capabilities and are not made reversible automatically. Promises, delays, +futures, transients, mutable host objects, mutable deftype fields, and effects +outside SCI remain shared unless the embedding application models or copies +them. On the JVM and CLJS an SCI-created atom is now a dedicated `SciAtom`, not the host's concrete `clojure.lang.Atom`/`cljs.core.Atom` class. It implements the @@ -83,6 +84,13 @@ that tests the host concrete class observes this intentional representation difference. The split is necessary for one stable identity to select different state in different worlds. +SCI-created multimethods use the same representation tradeoff on JVM and CLJS: +the stable `SciMultiFn` handle selects a fork-local host dispatch engine. SCI's +`methods`, `get-method`, `prefers`, `prefer-method`, `remove-method`, and +`remove-all-methods` accept both SCI and native host multimethods, while host +code that tests specifically for the concrete host `MultiFn` class can observe +the difference. + Forking is O(number of allocated slots), including spare array capacity, while slot reads and writes are constant time. This intentionally favors the common case where reads and mutations greatly outnumber forks. A page-level diff --git a/src/sci/impl/multimethods.cljc b/src/sci/impl/multimethods.cljc index 08f4933c..066d9c50 100644 --- a/src/sci/impl/multimethods.cljc +++ b/src/sci/impl/multimethods.cljc @@ -4,6 +4,8 @@ (:require #?(:clj [clojure.string :as str]) [sci.ctx-store :as store] + [sci.fork :as fork] + [sci.impl.world :as world] ;; no hierarchies on cljd, like the host #?@(:cljd [] :default [[sci.impl.hierarchies :refer [global-hierarchy]]]))) @@ -13,6 +15,185 @@ (defn- no-method [mm-name dv] (throw (ex-info (str "No method in multimethod '" mm-name "' for dispatch value: " dv) {})))) +#?(:cljd nil + :default + (do + (declare clone-multifn-state) + + (deftype MultiFnState [mm-name dispatch-fn default-dispatch-val hierarchy delegate] + fork/Forkable + (fork-value [this] + (clone-multifn-state this))) + + (defn- new-host-multifn [mm-name dispatch-fn default hierarchy] + #?(:clj (new clojure.lang.MultiFn mm-name dispatch-fn default hierarchy) + :cljs (new cljs.core/MultiFn + mm-name dispatch-fn default hierarchy + (atom {}) (atom {}) (atom {}) (atom nil)))) + + (defn- host-methods [multifn] + #?(:clj (.getMethodTable ^clojure.lang.MultiFn multifn) + :cljs (-methods multifn))) + + (defn- host-prefers [multifn] + #?(:clj (.getPreferTable ^clojure.lang.MultiFn multifn) + :cljs (-prefers multifn))) + + (defn- host-add-method! [multifn dispatch-val method] + #?(:clj (.addMethod ^clojure.lang.MultiFn multifn dispatch-val method) + :cljs (-add-method multifn dispatch-val method))) + + (defn- host-remove-method! [multifn dispatch-val] + #?(:clj (.removeMethod ^clojure.lang.MultiFn multifn dispatch-val) + :cljs (-remove-method multifn dispatch-val))) + + (defn- host-prefer-method! [multifn x y] + #?(:clj (.preferMethod ^clojure.lang.MultiFn multifn x y) + :cljs (-prefer-method multifn x y))) + + (defn- host-reset! [multifn] + #?(:clj (.reset ^clojure.lang.MultiFn multifn) + :cljs (-reset multifn))) + + (defn- host-get-method [multifn dispatch-val] + #?(:clj (.getMethod ^clojure.lang.MultiFn multifn dispatch-val) + :cljs (-get-method multifn dispatch-val))) + + (defn- clone-multifn-state [^MultiFnState state] + (let [source (.-delegate state) + target (new-host-multifn + (.-mm-name state) (.-dispatch-fn state) + (.-default-dispatch-val state) (.-hierarchy state))] + (doseq [[dispatch-val method] (host-methods source)] + (host-add-method! target dispatch-val method)) + (doseq [[x ys] (host-prefers source) + y ys] + (host-prefer-method! target x y)) + (MultiFnState. (.-mm-name state) (.-dispatch-fn state) + (.-default-dispatch-val state) (.-hierarchy state) target))) + + (defn- initial-multifn-state [mm-name dispatch-fn default hierarchy] + (MultiFnState. mm-name dispatch-fn default hierarchy + (new-host-multifn mm-name dispatch-fn default hierarchy))) + + (defn- state-delegate [^MultiFnState state] + (.-delegate state)) + + (defn- mutate-state [^MultiFnState state mutation] + (let [^MultiFnState copy (clone-multifn-state state)] + (mutation (.-delegate copy)) + copy)) + + (declare sci-multifn-state mutate-sci-multifn!) + + #?(:clj + (deftype SciMultiFn [home registry state-slot] + fork/Forkable + (fork-value [this] this) + + clojure.lang.IFn + (invoke [_] ((state-delegate (world/managed-value home registry state-slot)))) + (invoke [_ a] ((state-delegate (world/managed-value home registry state-slot)) a)) + (invoke [_ a b] ((state-delegate (world/managed-value home registry state-slot)) a b)) + (invoke [_ a b c] ((state-delegate (world/managed-value home registry state-slot)) a b c)) + (invoke [_ a b c d] ((state-delegate (world/managed-value home registry state-slot)) a b c d)) + (invoke [_ a b c d e] ((state-delegate (world/managed-value home registry state-slot)) a b c d e)) + (invoke [_ a b c d e f] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f)) + (invoke [_ a b c d e f g] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g)) + (invoke [_ a b c d e f g h] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h)) + (invoke [_ a b c d e f g h i] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i)) + (invoke [_ a b c d e f g h i j] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j)) + (invoke [_ a b c d e f g h i j k] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k)) + (invoke [_ a b c d e f g h i j k l] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l)) + (invoke [_ a b c d e f g h i j k l m] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m)) + (invoke [_ a b c d e f g h i j k l m n] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n)) + (invoke [_ a b c d e f g h i j k l m n o] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o)) + (invoke [_ a b c d e f g h i j k l m n o p] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p)) + (invoke [_ a b c d e f g h i j k l m n o p q] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q)) + (invoke [_ a b c d e f g h i j k l m n o p q r] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r)) + (invoke [_ a b c d e f g h i j k l m n o p q r s] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r s)) + (invoke [_ a b c d e f g h i j k l m n o p q r s t] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r s t)) + (applyTo [_ args] + (apply (state-delegate (world/managed-value home registry state-slot)) args))) + + :cljs + (deftype SciMultiFn [home registry state-slot] + fork/Forkable + (fork-value [this] this) + + IFn + (-invoke [_] ((state-delegate (world/managed-value home registry state-slot)))) + (-invoke [_ a] ((state-delegate (world/managed-value home registry state-slot)) a)) + (-invoke [_ a b] ((state-delegate (world/managed-value home registry state-slot)) a b)) + (-invoke [_ a b c] ((state-delegate (world/managed-value home registry state-slot)) a b c)) + (-invoke [_ a b c d] ((state-delegate (world/managed-value home registry state-slot)) a b c d)) + (-invoke [_ a b c d e] ((state-delegate (world/managed-value home registry state-slot)) a b c d e)) + (-invoke [_ a b c d e f] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f)) + (-invoke [_ a b c d e f g] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g)) + (-invoke [_ a b c d e f g h] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h)) + (-invoke [_ a b c d e f g h i] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i)) + (-invoke [_ a b c d e f g h i j] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j)) + (-invoke [_ a b c d e f g h i j k] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k)) + (-invoke [_ a b c d e f g h i j k l] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l)) + (-invoke [_ a b c d e f g h i j k l m] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m)) + (-invoke [_ a b c d e f g h i j k l m n] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n)) + (-invoke [_ a b c d e f g h i j k l m n o] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o)) + (-invoke [_ a b c d e f g h i j k l m n o p] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p)) + (-invoke [_ a b c d e f g h i j k l m n o p q] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q)) + (-invoke [_ a b c d e f g h i j k l m n o p q r] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r s)) + (-invoke [_ a b c d e f g h i j k l m n o p q r s t] ((state-delegate (world/managed-value home registry state-slot)) a b c d e f g h i j k l m n o p q r s t)) + + IMultiFn + (-reset [this] + (mutate-sci-multifn! this host-reset!)) + (-add-method [this dispatch-val method] + (mutate-sci-multifn! + this #(host-add-method! % dispatch-val method))) + (-remove-method [this dispatch-val] + (mutate-sci-multifn! + this #(host-remove-method! % dispatch-val))) + (-prefer-method [this x y] + (mutate-sci-multifn! + this #(host-prefer-method! % x y))) + (-get-method [this dispatch-val] + (host-get-method (state-delegate (sci-multifn-state this)) + dispatch-val)) + (-methods [this] + (host-methods (state-delegate (sci-multifn-state this)))) + (-prefers [this] + (host-prefers (state-delegate (sci-multifn-state this)))) + (-default-dispatch-val [this] + (.-default-dispatch-val ^MultiFnState (sci-multifn-state this))) + (-dispatch-fn [this] + (.-dispatch-fn ^MultiFnState (sci-multifn-state this))) + + IEquiv + (-equiv [this other] (identical? this other)) + IHash + (-hash [this] (goog/getUid this)))) + + (defn- sci-multifn-state [^SciMultiFn multifn] + (world/managed-value (.-home multifn) (.-registry multifn) + (.-state-slot multifn))) + + (defn- mutate-sci-multifn! [^SciMultiFn multifn mutation] + (world/managed-swap! + (.-home multifn) (.-registry multifn) (.-state-slot multifn) + #(mutate-state % mutation) nil + (fn [_ _] nil) (fn [_ _ _ _] nil)) + multifn) + + (defn- managed-multifn [mm-name dispatch-fn default hierarchy] + (let [{:keys [home registry slots managed-index]} + (world/register-managed! + :multifn + [(initial-multifn-state mm-name dispatch-fn default hierarchy)] + [0])] + (world/attach-managed-owner! + registry managed-index + (SciMultiFn. home registry (nth slots 0))))))) + ;; no hierarchies on cljd, dispatch is exact match with a default fallback #?(:cljd (deftype SciMultiFn [mm-name dispatch-fn default method-table] @@ -67,16 +248,7 @@ (if (and (map? dispatch-val) (fn? (:instance? dispatch-val))) (or (:class dispatch-val) (throw (ex-info "Class cannot be used as a dispatch value" {}))) - dispatch-val)) - (defn get-method-impl [^SciMultiFn multifn dispatch-val] - (let [mt @(.-method-table multifn) - dispatch-val (normalize-dispatch-val dispatch-val)] - (or (get mt dispatch-val) (get mt (.-default multifn))))) - (defn methods-impl [^SciMultiFn multifn] - @(.-method-table multifn)) - (defn remove-method-impl [^SciMultiFn multifn dispatch-val] - (swap! (.-method-table multifn) dissoc (normalize-dispatch-val dispatch-val)) - multifn))) + dispatch-val)))) (defn ^:private check-valid-options "Throws an exception if the given option map contains keys not listed @@ -152,34 +324,85 @@ (def ~mm-name (clojure.core/multi-fn-impl ~(name mm-name) ~dispatch-fn ~default ~hierarchy)))) :cljs `(defonce ~(with-meta mm-name m) - (let [method-table# (atom {}) - prefer-table# (atom {}) - method-cache# (atom {}) - cached-hierarchy# (atom {})] - (clojure.core/multi-fn-impl ~(symbol (name mm-name)) ~dispatch-fn ~default ~hierarchy - method-table# prefer-table# method-cache# cached-hierarchy#))))))) + (clojure.core/multi-fn-impl + ~(symbol (name mm-name)) ~dispatch-fn ~default ~hierarchy)))))) (defn multi-fn?-impl [x] #?(:cljd (instance? SciMultiFn x) - :clj (instance? clojure.lang.MultiFn x) - :cljs (instance? cljs.core/MultiFn x))) + :clj (or (instance? SciMultiFn x) + (instance? clojure.lang.MultiFn x)) + :cljs (or (instance? SciMultiFn x) + (instance? cljs.core/MultiFn x)))) -(defn multi-fn-impl #?(:cljd [name dispatch-fn default hierarchy] - :clj [name dispatch-fn default hierarchy] - :cljs [name dispatch-fn default hierarchy - method-table prefer-table method-cache cached-hierarchy]) +(defn multi-fn-impl [name dispatch-fn default hierarchy] #?(:cljd (SciMultiFn. name dispatch-fn default (atom {})) - :clj (new clojure.lang.MultiFn name dispatch-fn default hierarchy) - :cljs (new cljs.core/MultiFn name dispatch-fn default hierarchy - method-table prefer-table method-cache cached-hierarchy))) + :default (managed-multifn name dispatch-fn default hierarchy))) (defn multi-fn-add-method-impl [multifn dispatch-val f] #?(:cljd (do (swap! (.-method-table ^SciMultiFn multifn) assoc (normalize-dispatch-val dispatch-val) f) multifn) - :clj (.addMethod ^clojure.lang.MultiFn multifn dispatch-val f) - :cljs (-add-method multifn dispatch-val f))) + :default + (if (instance? SciMultiFn multifn) + (mutate-sci-multifn! + multifn #(host-add-method! % dispatch-val f)) + (host-add-method! multifn dispatch-val f)))) + +(defn get-method-impl [multifn dispatch-val] + #?(:cljd + (let [mt @(.-method-table ^SciMultiFn multifn) + dispatch-val (normalize-dispatch-val dispatch-val)] + (or (get mt dispatch-val) (get mt (.-default ^SciMultiFn multifn)))) + :default + (host-get-method + (if (instance? SciMultiFn multifn) + (state-delegate (sci-multifn-state multifn)) + multifn) + dispatch-val))) + +(defn methods-impl [multifn] + #?(:cljd @(.-method-table ^SciMultiFn multifn) + :default + (host-methods + (if (instance? SciMultiFn multifn) + (state-delegate (sci-multifn-state multifn)) + multifn)))) + +(defn prefers-impl [multifn] + #?(:cljd {} + :default + (host-prefers + (if (instance? SciMultiFn multifn) + (state-delegate (sci-multifn-state multifn)) + multifn)))) + +(defn remove-method-impl [multifn dispatch-val] + #?(:cljd + (do (swap! (.-method-table ^SciMultiFn multifn) + dissoc (normalize-dispatch-val dispatch-val)) + multifn) + :default + (if (instance? SciMultiFn multifn) + (mutate-sci-multifn! + multifn #(host-remove-method! % dispatch-val)) + (host-remove-method! multifn dispatch-val)))) + +(defn remove-all-methods-impl [multifn] + #?(:cljd + (do (reset! (.-method-table ^SciMultiFn multifn) {}) multifn) + :default + (if (instance? SciMultiFn multifn) + (mutate-sci-multifn! multifn host-reset!) + (host-reset! multifn)))) + +(defn prefer-method-impl [multifn x y] + #?(:cljd multifn + :default + (if (instance? SciMultiFn multifn) + (mutate-sci-multifn! + multifn #(host-prefer-method! % x y)) + (host-prefer-method! multifn x y)))) (defn defmethod "Creates and installs a new method of multimethod associated with dispatch-value. " diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index f05cbfd2..818ad923 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -1448,18 +1448,23 @@ ;; multimethods 'defmulti (macrofy 'defmulti sci.impl.multimethods/defmulti clojure-core-ns) 'defmethod (macrofy 'defmethod sci.impl.multimethods/defmethod) - #?@(:cljd ['get-method (new-var 'get-method sci.impl.multimethods/get-method-impl clojure-core-ns)] - :default ['get-method (copy-core-var get-method)]) - #?@(:cljd ['methods (new-var 'methods sci.impl.multimethods/methods-impl clojure-core-ns)] - :default ['methods (copy-core-var methods)]) + 'get-method (copy-var sci.impl.multimethods/get-method-impl clojure-core-ns + {:copy-meta-from 'clojure.core/get-method}) + 'methods (copy-var sci.impl.multimethods/methods-impl clojure-core-ns + {:copy-meta-from 'clojure.core/methods}) 'multi-fn-add-method-impl (copy-var sci.impl.multimethods/multi-fn-add-method-impl clojure-core-ns) 'multi-fn?-impl (copy-var sci.impl.multimethods/multi-fn?-impl clojure-core-ns) 'multi-fn-impl (copy-var sci.impl.multimethods/multi-fn-impl clojure-core-ns) - #?@(:cljd [] :default ['prefer-method (copy-core-var prefer-method)]) - #?@(:cljd [] :default ['prefers (copy-core-var prefers)]) - #?@(:cljd ['remove-method (new-var 'remove-method sci.impl.multimethods/remove-method-impl clojure-core-ns)] - :default ['remove-method (copy-core-var remove-method)]) - #?@(:cljd [] :default ['remove-all-methods (copy-core-var remove-all-methods)]) + #?@(:cljd [] :default + ['prefer-method (copy-var sci.impl.multimethods/prefer-method-impl clojure-core-ns + {:copy-meta-from 'clojure.core/prefer-method})]) + #?@(:cljd [] :default + ['prefers (copy-var sci.impl.multimethods/prefers-impl clojure-core-ns + {:copy-meta-from 'clojure.core/prefers})]) + 'remove-method (copy-var sci.impl.multimethods/remove-method-impl clojure-core-ns + {:copy-meta-from 'clojure.core/remove-method}) + 'remove-all-methods (copy-var sci.impl.multimethods/remove-all-methods-impl clojure-core-ns + {:copy-meta-from 'clojure.core/remove-all-methods}) ;; end multimethods ;; protocols 'defprotocol (macrofy 'defprotocol sci.impl.protocols/defprotocol diff --git a/src/sci/impl/protocols.cljc b/src/sci/impl/protocols.cljc index 635fcc84..3921ace5 100644 --- a/src/sci/impl/protocols.cljc +++ b/src/sci/impl/protocols.cljc @@ -320,21 +320,17 @@ (contains? sats "nil")) (when-let [t (types/type-impl obj)] (contains? sats (type->str t))))) - ;; built-in protocol :methods are host multifns on cljd, only - ;; sci-created SciMultiFns are inspectable - #?(:cljd - (boolean (some #(when (instance? mms/SciMultiFn %) - (when-let [m (mms/get-method-impl % (types/type-impl obj))] - (let [ms (mms/methods-impl %) - default (get ms :default)] - (not (identical? m default))))) - (:methods protocol))) - :default - (boolean (some #(when-let [m (get-method % (types/type-impl obj))] - (let [ms (methods %) - default (get ms :default)] - (not (identical? m default)))) - (:methods protocol)))))) + ;; Built-in protocol methods can remain host multimethods while + ;; SCI-created methods are world-aware SciMultiFns. The helpers accept + ;; both representations. + (boolean (some #(when #?(:cljd (instance? mms/SciMultiFn %) + :default true) + (when-let [m (mms/get-method-impl + % (types/type-impl obj))] + (let [ms (mms/methods-impl %) + default (get ms :default)] + (not (identical? m default))))) + (:methods protocol))))) (defn satisfies? [protocol obj] (if-let [protocols (when #?(:cljd (instance? sci.impl.types/Reified obj) @@ -425,4 +421,5 @@ #?(:cljd (boolean (some #(when (instance? mms/SciMultiFn %) (mms/get-method-impl % atype)) (:methods protocol))) - :default (boolean (some #(get-method % atype) (:methods protocol))))) + :default (boolean (some #(mms/get-method-impl % atype) + (:methods protocol))))) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 8979d431..01b0c890 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -306,14 +306,20 @@ (let [selected (selected-managed-world home registry)] (if (identical? selected home) (slot-value selected slot absent) - (slot-value selected slot (slot-value home slot absent))))) + (let [value (slot-value selected slot absent)] + (if (identical? value absent) + (slot-value home slot absent) + value))))) (defn managed-value-in "Read a managed slot from an already selected world." [world home slot] (if (identical? world home) (slot-value world slot absent) - (slot-value world slot (slot-value home slot absent)))) + (let [value (slot-value world slot absent)] + (if (identical? value absent) + (slot-value home slot absent) + value)))) (defn- call-with-managed-mutation [^DenseWorld home registry f] (let [active (active-world-state) diff --git a/test/sci/multimethods_test.cljc b/test/sci/multimethods_test.cljc index 1644a095..f640f987 100644 --- a/test/sci/multimethods_test.cljc +++ b/test/sci/multimethods_test.cljc @@ -1,6 +1,7 @@ (ns sci.multimethods-test (:require [clojure.test :as test :refer [deftest is]] + [sci.core :as sci] [sci.test-utils :as tu])) (defn eval* [expr] @@ -54,3 +55,43 @@ (foo :bar 1 2 3) (foo :bar 1 2 3 4)] ")))) + +(deftest forked-multimethod-state-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(defmulti branch-method identity) + (defmethod branch-method :default [_] :parent-default) + (defmethod branch-method :shared [_] :parent-shared) + (derive ::cat ::animal) + (defmulti animal-method identity) + (defmethod animal-method ::animal [_] :animal) + (defmethod animal-method :default [_] :not-animal) + ;; Populate dispatch caches before the fork. + [(branch-method :child) (animal-method ::cat)]") + (let [child (sci/fork parent)] + (is (= [:child :child-only #{:child :shared} {:left #{:right}}] + (sci/eval-string* + child + "(defmethod branch-method :shared [_] :child) + (defmethod branch-method :child [_] :child-only) + (remove-method branch-method :default) + (prefer-method branch-method :left :right) + (derive ::dog ::animal) + [(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method))) + (prefers branch-method)]"))) + (is (= [:parent-shared :parent-default #{:default :shared} {}] + (sci/eval-string* + parent + "[(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method))) + (prefers branch-method)]"))) + (is (= [:animal :animal] + (sci/eval-string* child + "[(animal-method ::cat) (animal-method ::dog)]"))) + (is (= [:animal :not-animal] + (sci/eval-string* parent + "[(animal-method ::cat) (animal-method ::dog)]")))))) From 9b83592d6f80276a5fbfb68d6483c501917512b7 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 04:43:30 -0700 Subject: [PATCH 11/31] Make SCI memoization caches fork-local --- doc/fork-state-audit.md | 16 +++++++++------- doc/forking.md | 12 ++++++------ src/sci/impl/namespaces.cljc | 3 ++- src/sci/impl/refs.cljc | 13 +++++++++++++ test/sci/core_test.cljc | 26 ++++++++++++++++++++++++++ 5 files changed, 56 insertions(+), 14 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 0380a74a..e5ad9736 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -134,7 +134,7 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | `*loaded-libs*` | Built-in Var root points to one host Ref/atom | Shared unintentionally despite fork-local namespace maps | | Delay | One host Delay object and realization cache | Shared; forcing in one world suppresses computation in another | | Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | -| `memoize` cache | Host function closes over an untracked atom | Shared; a child cache hit can suppress parent computation | +| SCI `memoize` cache | Closure owns a fork-local `SciAtom` cache | Implemented; inherited entries are shared as immutable values and later cache fills diverge | | Promise | One host delivery cell | Shared; child delivery is immediately visible in parent | | Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | | Transient collection | Same affine host object | Shared; mutation in child is visible in parent | @@ -284,10 +284,12 @@ portable managed implementation and test runtime. ### Memoization and lazy computation -SCI should provide a world-aware memoize implementation whose cache is a -tracked state handle. Lazy sequences are harder: their realization cache is a -small continuation, and arbitrary lazy bodies may perform effects. They belong -with the future execution/fiber model rather than a generic object copier. +SCI's `memoize` now closes over a `SciAtom`, so it inherits the parent's cache +at fork and subsequent fills remain world-local. Cached result values retain +their ordinary sharing or explicit `Forkable` policy. Lazy sequences are +harder: their realization cache is a small continuation, and arbitrary lazy +bodies may perform effects. They belong with the future execution/fiber model +rather than a generic object copier. ### Transients and mutable aggregates @@ -307,8 +309,8 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. create an unbounded retention problem. 4. Finish split identity/state for Var watches, namespace/type metadata, volatiles, and `*loaded-libs*`. -5. Finish the ClojureDart multimethod port and make memoization caches - world-local. JVM/CLJS multimethod state is implemented. +5. Finish the ClojureDart multimethod port. JVM/CLJS multimethod state and SCI + memoization caches are implemented. 6. Add managed Delay and choose a pending-Promise policy. 7. Reject or explicitly classify transients, running futures, streams, and other affine/external resources. diff --git a/doc/forking.md b/doc/forking.md index bbf7fee2..cecd13e8 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -70,12 +70,12 @@ application's responsibility, for example with an identity-keyed memo table. Var roots/metadata, all logical SCI atom state, SCI-created volatile values, and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are -fork-local. Atom metadata, validator, and watch maps are inherited by a fork -and can subsequently diverge; effects performed by a watch are ordinary user -capabilities and are not made reversible automatically. Promises, delays, -futures, transients, mutable host objects, mutable deftype fields, and effects -outside SCI remain shared unless the embedding application models or copies -them. +fork-local. SCI's `memoize` uses a fork-local atom for its cache. Atom metadata, +validator, and watch maps are inherited by a fork and can subsequently diverge; +effects performed by a watch are ordinary user capabilities and are not made +reversible automatically. Promises, delays, futures, transients, mutable host +objects, mutable deftype fields, and effects outside SCI remain shared unless +the embedding application models or copies them. On the JVM and CLJS an SCI-created atom is now a dedicated `SciAtom`, not the host's concrete `clojure.lang.Atom`/`cljs.core.Atom` class. It implements the diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 818ad923..a1423405 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -1806,7 +1806,8 @@ 'max-key (copy-core-var max-key) 'meta (copy-core-var meta) 'memfn (copy-var memfn clojure-core-ns {:macro true}) - 'memoize (copy-core-var memoize) + 'memoize (copy-var refs/memoize* clojure-core-ns + {:copy-meta-from 'clojure.core/memoize}) 'merge (copy-core-var merge) 'merge-with (copy-core-var merge-with) 'min (copy-core-var min) diff --git a/src/sci/impl/refs.cljc b/src/sci/impl/refs.cljc index 4732e608..a2d9c064 100644 --- a/src/sci/impl/refs.cljc +++ b/src/sci/impl/refs.cljc @@ -276,6 +276,19 @@ registry managed-index (SciAtom. home registry (nth slots 0) (nth slots 1))))) +(defn memoize* + "Clojure-compatible memoize whose cache follows the active SCI world." + [f] + (if (world/current-world) + (let [mem (atom {})] + (fn [& args] + (if-let [entry (find @mem args)] + (val entry) + (let [ret (apply f args)] + (swap! mem assoc args ret) + ret)))) + (clojure.core/memoize f))) + (defn get-validator* [ref] (if (sci-atom? ref) (let [^SciAtom ref ref] diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index caea2a1a..2eec30b2 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1534,6 +1534,32 @@ (is (= [6 [[:inherited 2 4] [:child 4 6]]] (sci/eval-string* child "[@a @events]")))))) +(deftest forked-memoize-cache-test + (let [parent (sci/init nil)] + (is (= [[:shared 1] [:shared 1] 1] + (sci/eval-string* + parent + "(def calls (atom 0)) + (def measured + (memoize (fn [x] [x (swap! calls inc)]))) + [(measured :shared) (measured :shared) @calls]"))) + (let [child (sci/fork parent)] + (is (= [[:shared 1] [:child 2] [:child 2] 2] + (sci/eval-string* + child + "[(measured :shared) + (measured :child) + (measured :child) + @calls]"))) + (is (= [[:shared 1] [:child 2] [:child 2] 2] + (sci/eval-string* + parent + "[(measured :shared) + (measured :child) + (measured :child) + @calls]"))) + (is (= 2 (sci/eval-string* child "@calls")))))) + (deftest forkable-host-value-test (let [user-ns (sci/create-ns 'user) copies (atom 0) From d018dff1bd8841a5e6e48e1260d6b47d094efb81 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 05:06:21 -0700 Subject: [PATCH 12/31] Make SCI delays and JVM promises fork-local --- doc/fork-state-audit.md | 30 +++++- doc/forking.md | 22 +++- src/sci/impl/namespaces.cljc | 18 ++-- src/sci/impl/refs.cljc | 189 +++++++++++++++++++++++++++++++++++ test/sci/core_test.cljc | 51 +++++++++- test/sci/vars_test.cljc | 39 ++++++++ 6 files changed, 330 insertions(+), 19 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index e5ad9736..06dfbe92 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -132,10 +132,11 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Namespace metadata | Mutable field on shared Namespace handle | Shared unintentionally | | Type metadata and mutable deftype fields | Mutable fields on shared Type/SciType handles | Shared unintentionally | | `*loaded-libs*` | Built-in Var root points to one host Ref/atom | Shared unintentionally despite fork-local namespace maps | -| Delay | One host Delay object and realization cache | Shared; forcing in one world suppresses computation in another | +| Delay | Stable SCI handle with world-local pending/realized state | Implemented; pending realizations split, while cached outcomes are inherited according to host delay semantics | | Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | | SCI `memoize` cache | Closure owns a fork-local `SciAtom` cache | Implemented; inherited entries are shared as immutable values and later cache fills diverge | -| Promise | One host delivery cell | Shared; child delivery is immediately visible in parent | +| JVM Promise | Stable SCI handle with world-local pending/delivered state | Implemented; a pending child has no inherited waiters and delivery is branch-local | +| CLJS Promise | Native asynchronous host value | External async resource; managed continuations convey a world but the Promise itself is not copied | | Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | | Transient collection | Same affine host object | Shared; mutation in child is visible in parent | | Array / JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | @@ -157,9 +158,10 @@ protocol. A JVM probe against the current implementation produced these results: -- forcing a child delay returned its value in the parent without running the - delayed body in the parent; -- delivering a child promise delivered the parent promise; +- before managed delays, forcing a child delay returned its value in the + parent without running the delayed body in the parent; +- before managed JVM promises, delivering a child promise delivered the parent + promise; - mutating a child transient or array changed the object seen by the parent; - using a memoized function in the child populated the cache used by parent; - a child `defmethod` installed the method in parent; @@ -247,6 +249,15 @@ should be impossible for an evaluation-owned delay because fork waits for the active form; a delay running in an unmanaged host task is an external resource and must block or reject the fork. +This is now implemented with a stable `SciDelay` and one managed state slot. +The host delay inside a pending state supplies the normal once-only and +concurrent-force behavior. Forking a still-pending state constructs a fresh +host delay over the same thunk; forking an already realized state records its +value or thrown exception directly. JVM Clojure caches a thrown exception, +while ClojureScript leaves a throwing delay pending and retryable; SCI retains +that platform distinction. Because a fork quiesces managed evaluation, it +cannot observe an evaluation-owned realization halfway through. + ### Promise `delivered(value)` can be copied. A pending promise also owns a waiter set, @@ -255,6 +266,15 @@ fork should either create independent pending cells with no inherited waiters or reject pending promises. An execution fork may duplicate suspended waiter continuations only after they are represented inside the managed interpreter. +The JVM implementation now chooses independent pending cells. `SciPromise` +stores immutable pending or delivered states in one managed world slot. +Delivery atomically replaces pending only in the selected world, preserving +first-delivery-wins semantics. A monitor on the stable handle wakes blocked +threads, but each waiter re-reads its own world's slot, so a delivery in one +branch cannot complete a waiter in another. Managed SCI futures are already +part of world quiescence; arbitrary unmanaged host waiters are deliberately +not copied into a child. + ### Future and asynchronous computation A running host Future cannot be copied honestly. The immediate correction is diff --git a/doc/forking.md b/doc/forking.md index cecd13e8..648003ec 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -69,11 +69,12 @@ application's responsibility, for example with an identity-keyed memo table. ## Current boundary Var roots/metadata, all logical SCI atom state, SCI-created volatile values, -and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are -fork-local. SCI's `memoize` uses a fork-local atom for its cache. Atom metadata, -validator, and watch maps are inherited by a fork and can subsequently diverge; -effects performed by a watch are ordinary user capabilities and are not made -reversible automatically. Promises, delays, futures, transients, mutable host +delays, and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches +are fork-local. On the JVM, SCI-created promises are fork-local as well. SCI's +`memoize` uses a fork-local atom for its cache. Atom metadata, validator, and +watch maps are inherited by a fork and can subsequently diverge; effects +performed by a watch are ordinary user capabilities and are not made +reversible automatically. Futures, lazy sequences, transients, mutable host objects, mutable deftype fields, and effects outside SCI remain shared unless the embedding application models or copies them. @@ -91,6 +92,17 @@ the stable `SciMultiFn` handle selects a fork-local host dispatch engine. SCI's code that tests specifically for the concrete host `MultiFn` class can observe the difference. +SCI delays also have stable interpreter-owned identity. Forking a pending delay +creates an independent pending realization in the child; forking a completed +delay inherits its cached value or exception according to the host's delay +semantics. In particular, JVM Clojure caches a thrown exception while +ClojureScript leaves that delay pending and retryable. The JVM `promise` +follows the same world split: a delivered value is inherited, while a pending +child receives an independent delivery state and no source-world waiters. Its +shared wake-up monitor is only a scheduling signal: a waiter always rechecks +the state of its own world. Host code that tests for the concrete host delay +or promise class can observe these representation differences. + Forking is O(number of allocated slots), including spare array capacity, while slot reads and writes are constant time. This intentionally favors the common case where reads and mutations greatly outnumber forks. A page-level diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index a1423405..5cb52332 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -384,9 +384,7 @@ (defn delay* [_ _ & body] - #?(:cljd `(clojure.core/-delay* (fn [] ~@body)) - :clj `(new clojure.lang.Delay (fn [] ~@body)) - :cljs `(new cljs.core/Delay (fn [] ~@body)))) + `(clojure.core/-delay* (fn [] ~@body))) (defn defn-* [_ _ name & decls] @@ -1658,8 +1656,10 @@ 'deftype (macrofy 'deftype sci.impl.deftype/deftype-macro clojure-core-ns) 'delay (macrofy 'delay delay*) - 'delay? (copy-core-var delay?) - #?@(:clj ['deliver (copy-core-var deliver)]) + 'delay? (copy-var refs/delay?* clojure-core-ns + {:copy-meta-from 'clojure.core/delay?}) + #?@(:clj ['deliver (copy-var refs/deliver* clojure-core-ns + {:copy-meta-from 'clojure.core/deliver})]) #?@(:cljs ['demunge (copy-core-var cljs.core/demunge)]) #?@(:cljd [] :default ['derive (copy-var hierarchies/derive* clojure-core-ns {:name 'derive})]) #?@(:cljd [] :default ['descendants (copy-var hierarchies/descendants* clojure-core-ns {:name 'descendants})]) @@ -1718,7 +1718,8 @@ 'float (copy-core-var float) 'fn? (copy-core-var fn?) 'for (macrofy 'for for-macro/expand-for) - 'force (copy-core-var force) + 'force (copy-var refs/force* clojure-core-ns + {:copy-meta-from 'clojure.core/force}) 'get (copy-core-var get) 'get-thread-binding-frame-impl (new-var 'get-thread-binding-frame-impl sci.impl.vars/get-thread-binding-frame) #?@(:clj ['get-thread-bindings (copy-var sci.impl.vars/get-thread-bindings clojure-core-ns {:name 'get-thread-bindings})]) @@ -1859,7 +1860,8 @@ 'partition-all (copy-core-var partition-all) 'partition-by (copy-core-var partition-by) 'persistent! (copy-core-var persistent!) - #?@(:clj ['promise (copy-core-var promise)]) + #?@(:clj ['promise (copy-var refs/promise* clojure-core-ns + {:copy-meta-from 'clojure.core/promise})]) 'push-thread-bindings (copy-var sci.impl.vars/push-thread-bindings clojure-core-ns {:name 'push-thread-bindings}) 'qualified-ident? (copy-core-var qualified-ident?) 'qualified-symbol? (copy-core-var qualified-symbol?) @@ -2039,8 +2041,8 @@ ;; -write comes from the IWriter protocol-vars entry below 'locking (macrofy 'locking locking*) + '-delay* (new-var '-delay* refs/delay* clojure-core-ns) #?@(:cljd ['-lazy-seq* (new-var '-lazy-seq* (fn [f] (lazy-seq (f))) clojure-core-ns) - '-delay* (new-var '-delay* (fn [f] (delay (f))) clojure-core-ns) ;; no unchecked math on cljd, alias to the checked variants 'unchecked-inc (new-var 'unchecked-inc inc clojure-core-ns) 'unchecked-dec (new-var 'unchecked-dec dec clojure-core-ns) diff --git a/src/sci/impl/refs.cljc b/src/sci/impl/refs.cljc index a2d9c064..696e03d8 100644 --- a/src/sci/impl/refs.cljc +++ b/src/sci/impl/refs.cljc @@ -276,6 +276,195 @@ registry managed-index (SciAtom. home registry (nth slots 0) (nth slots 1))))) +(defprotocol ^:private IDelayState + (-delay-value [state]) + (-delay-realized? [state])) + +(deftype RealizedDelayState [value] + fork/Forkable + (fork-value [this] this) + IDelayState + (-delay-value [_] value) + (-delay-realized? [_] true)) + +(deftype FailedDelayState [error] + fork/Forkable + (fork-value [this] this) + IDelayState + (-delay-value [_] (throw error)) + (-delay-realized? [_] true)) + +(defn- host-delay [thunk] + (clojure.core/delay (thunk))) + +(deftype PendingDelayState [thunk delegate] + fork/Forkable + (fork-value [_] + (if (realized? delegate) + (try + (RealizedDelayState. @delegate) + (catch #?(:cljd Object :clj Throwable :cljs :default) error + (FailedDelayState. error))) + (PendingDelayState. thunk (host-delay thunk)))) + IDelayState + (-delay-value [_] @delegate) + (-delay-realized? [_] (realized? delegate))) + +(declare delay-value delay-realized?) + +(deftype SciDelay [home registry state-slot] + fork/Forkable + (fork-value [this] this) + + #?@(:clj + [clojure.lang.IDeref + (deref [_] (delay-value home registry state-slot)) + clojure.lang.IPending + (isRealized [_] (delay-realized? home registry state-slot))] + :cljs + [IDeref + (-deref [_] (delay-value home registry state-slot)) + IPending + (-realized? [_] (delay-realized? home registry state-slot)) + IEquiv + (-equiv [this other] (identical? this other)) + IHash + (-hash [this] (goog/getUid this))] + :cljd + [IDeref + (-deref [_] (delay-value home registry state-slot)) + IPending + (-realized? [_] (delay-realized? home registry state-slot))])) + +(defn sci-delay? [x] + (instance? SciDelay x)) + +(defn- selected-delay-state [home registry state-slot] + (world/managed-value home registry state-slot)) + +(defn delay-value [home registry state-slot] + (-delay-value (selected-delay-state home registry state-slot))) + +(defn delay-realized? [home registry state-slot] + (-delay-realized? (selected-delay-state home registry state-slot))) + +(defn delay* + "Create a delay whose realization cache follows the active SCI world." + [thunk] + (let [{:keys [home registry slots managed-index]} + (world/register-managed! + :delay [(PendingDelayState. thunk (host-delay thunk))] [0])] + (world/attach-managed-owner! + registry managed-index + (SciDelay. home registry (nth slots 0))))) + +(defn delay?* [x] + (or (sci-delay? x) (delay? x))) + +(defn force* [x] + (if (sci-delay? x) @x (force x))) + +#?(:clj + (do + (deftype PendingPromiseState [] + fork/Forkable + (fork-value [this] this)) + + (deftype DeliveredPromiseState [value] + fork/Forkable + (fork-value [this] this)) + + (declare promise-value promise-value-with-timeout promise-realized?) + + (deftype SciPromise [home registry state-slot signal] + fork/Forkable + (fork-value [this] this) + + clojure.lang.IDeref + (deref [_] + (promise-value home registry state-slot signal)) + + clojure.lang.IBlockingDeref + (deref [_ timeout-ms timeout-val] + (promise-value-with-timeout + home registry state-slot signal timeout-ms timeout-val)) + + clojure.lang.IPending + (isRealized [_] + (promise-realized? home registry state-slot))) + + (defn sci-promise? [x] + (instance? SciPromise x)) + + (defn- selected-promise-state [home registry state-slot] + (world/managed-value home registry state-slot)) + + (defn- delivered-promise-state? [state] + (instance? DeliveredPromiseState state)) + + (defn promise-value [home registry state-slot signal] + (loop [] + (let [state (selected-promise-state home registry state-slot)] + (if (delivered-promise-state? state) + (.-value ^DeliveredPromiseState state) + (do + ;; Re-read while holding the monitor so delivery cannot occur + ;; between observing pending and beginning to wait. + (locking signal + (when-not (delivered-promise-state? + (selected-promise-state + home registry state-slot)) + (.wait ^Object signal))) + (recur)))))) + + (defn promise-value-with-timeout + [home registry state-slot signal timeout-ms timeout-val] + (let [deadline (+ (System/currentTimeMillis) + (max 0 (long timeout-ms)))] + (loop [] + (let [state (selected-promise-state home registry state-slot)] + (if (delivered-promise-state? state) + (.-value ^DeliveredPromiseState state) + (let [remaining (- deadline (System/currentTimeMillis))] + (if-not (pos? remaining) + timeout-val + (do + (locking signal + (when-not (delivered-promise-state? + (selected-promise-state + home registry state-slot)) + (.wait ^Object signal (long remaining)))) + (recur))))))))) + + (defn promise-realized? [home registry state-slot] + (delivered-promise-state? + (selected-promise-state home registry state-slot))) + + (defn promise* + "Create a promise with an independent pending delivery cell per world." + [] + (let [{:keys [home registry slots managed-index]} + (world/register-managed! + :promise [(PendingPromiseState.)] [0])] + (world/attach-managed-owner! + registry managed-index + (SciPromise. home registry (nth slots 0) (Object.))))) + + (defn deliver* [p value] + (if (sci-promise? p) + (let [^SciPromise p p] + (world/managed-swap! + (.-home p) (.-registry p) (.-state-slot p) + (fn [state] + (if (delivered-promise-state? state) + state + (DeliveredPromiseState. value))) + nil (fn [_ _] nil) (fn [_ _ _ _] nil)) + (locking (.-signal p) + (.notifyAll ^Object (.-signal p))) + p) + (deliver p value))))) + (defn memoize* "Clojure-compatible memoize whose cache follows the active SCI world." [f] diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 2eec30b2..8c3842a4 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1186,7 +1186,56 @@ (f 1))"))))) (deftest core-delay-test - (is (= 1 (eval* "@(delay 1)")))) + (is (= 1 (eval* "@(delay 1)"))) + (is (= [true false 1 true true] + (eval* "(let [d (delay 1)] + [(delay? d) (realized? d) (force d) + (realized? d) (= 1 @d)])")))) + +(deftest forked-delay-state-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(def effects (atom [])) + (def pending + (delay (swap! effects conj :pending) (count @effects))) + (def completed + (delay (swap! effects conj :completed) (count @effects))) + (def failed (delay (throw (ex-info \"cached\" {:kind :delay})))) + (force completed)") + (sci/eval-string* + parent + #?(:clj "(try (force failed) (catch Exception _ nil))" + :cljs "(try (force failed) (catch :default _ nil))" + :cljd "(try (force failed) (catch Object _ nil))")) + (let [child (sci/fork parent) + expected [false true #?(:cljs false :default true) + 2 [:completed :pending]]] + (is (= expected + (sci/eval-string* + child + "[(realized? pending) + (realized? completed) + (realized? failed) + (force pending) + @effects]"))) + (is (= expected + (sci/eval-string* + parent + "[(realized? pending) + (realized? completed) + (realized? failed) + (force pending) + @effects]"))) + (is (= :delay + (sci/eval-string* + child + #?(:clj "(try (force failed) + (catch Exception e (:kind (ex-data e))))" + :cljs "(try (force failed) + (catch :default e (:kind (ex-data e))))" + :cljd "(try (force failed) + (catch Object e (:kind (ex-data e))))"))))))) (deftest defn--test (is (= 1 (eval* "(defn- foo [] 1) (foo)"))) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index 032152ad..a9abc57a 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -283,6 +283,45 @@ (deref x 1 :failed))" (addons/future {}))))))) +#?(:cljd nil + :clj + (deftest forked-promise-state-test + (when-not tu/native? + (let [entered (promise) + parent (sci/init + (-> (addons/future {}) + (assoc :bindings + {'mark-entered + #(deliver entered true)})))] + (sci/eval-string* + parent + "(def pending (promise)) + (def blocked (promise)) + (def completed (promise)) + (deliver completed :done)") + (let [child (sci/fork parent)] + (is (= [false true :done :child :child] + (sci/eval-string* + child + "[(realized? pending) + (realized? completed) + @completed + @(deliver pending :child) + @(deliver pending :ignored)]"))) + (is (= [false :timeout] + (sci/eval-string* + parent + "[(realized? pending) (deref pending 1 :timeout)]"))) + (is (= [:parent :child] + [(sci/eval-string* parent "@(deliver pending :parent)") + (sci/eval-string* child "@pending")])) + (let [waiting (sci/eval-string* + child + "(future (mark-entered) @blocked)")] + (is (= true (deref entered 1000 ::timeout))) + (sci/eval-string* child "(deliver blocked :released)") + (is (= :released (deref waiting 1000 ::timeout))))))))) + (deftest def-returns-var-test (is (= "#'user/x" (eval* "(str (def x 1))"))) (is (= "#'user/foo" (eval* "(str (defmacro foo []))")))) From 8e527dbb60914b55c91b675d1eb6583a717b272f Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 05:26:45 -0700 Subject: [PATCH 13/31] Isolate namespace and Var control state across forks --- doc/fork-state-audit.md | 17 +++-- doc/forking.md | 18 ++--- src/sci/core.cljc | 10 +-- src/sci/impl/namespaces.cljc | 52 +++++++++++--- src/sci/impl/opts.cljc | 17 +++-- src/sci/impl/utils.cljc | 16 +++-- src/sci/impl/vars.cljc | 1 + src/sci/impl/world.cljc | 123 ++++++++++++++++++++++++++++++---- src/sci/lang.cljc | 109 ++++++++++++++++++++++++------ test/sci/namespaces_test.cljc | 41 +++++++++++- test/sci/vars_test.cljc | 29 ++++++++ 11 files changed, 358 insertions(+), 75 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 06dfbe92..8d3a994f 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -13,9 +13,11 @@ An SCI context currently has three relevant layers: 1. The context environment is an atom containing persistent namespace maps. `sci/fork` creates a new atom with the same map value. 2. A lineage registry maps stable handles to dense slots. Var roots and - metadata use two slots. A self-describing SCI atom carries a hot value slot - plus a cold control slot for metadata, validator, and watches. Volatiles - currently use one registry-routed value slot. + metadata use two slots, with an optional third slot allocated only when a + Var gains watches. Namespace objects use one metadata slot. A + self-describing SCI atom carries a hot value slot plus a cold control slot + for metadata, validator, and watches. Volatiles currently use one + registry-routed value slot. 3. Dynamic binding frames are control state outside the world. Active world, binding scope, and frame are consolidated in one execution-state cell. On the JVM it is a `ThreadLocal`; on CLJS and ClojureDart it is a process-local @@ -128,10 +130,10 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Global hierarchy value | Immutable map held in a world-local Var root | Implemented | | SCI-created atom value and control state | Self-describing stable handle; world-local value and metadata/validator/watch slots | Implemented; watch callback effects remain the user's responsibility | | SCI-created volatile value | Stable host handle, world-local value slot | Implemented | -| Var watches | Stored in the shared Var handle | Partial: registrations leak across worlds | -| Namespace metadata | Mutable field on shared Namespace handle | Shared unintentionally | +| Var watches | Optional dense world-local slot on a stable Var handle | Implemented; callbacks are inherited but their external effects remain capabilities | +| Namespace metadata | Stable Namespace handle with a dense world-local metadata slot | Implemented | | Type metadata and mutable deftype fields | Mutable fields on shared Type/SciType handles | Shared unintentionally | -| `*loaded-libs*` | Built-in Var root points to one host Ref/atom | Shared unintentionally despite fork-local namespace maps | +| `*loaded-libs*` | Built-in Var root has a per-cell copier for its host Ref/atom | Implemented; keeps the host representation while loaded sets diverge | | Delay | Stable SCI handle with world-local pending/realized state | Implemented; pending realizations split, while cached outcomes are inherited according to host delay semantics | | Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | | SCI `memoize` cache | Closure owns a fork-local `SciAtom` cache | Implemented; inherited entries are shared as immutable values and later cache fills diverge | @@ -167,7 +169,8 @@ A JVM probe against the current implementation produced these results: - a child `defmethod` installed the method in parent; - before self-describing atoms, child atom metadata changes appeared in the parent and a watch installed in the child fired for a parent mutation; -- namespace metadata still leaks across worlds; +- before managed namespace metadata, namespace metadata changes leaked across + worlds; - before world-scoped frames, a child-only dynamic binding was visible in a nested parent evaluation; - before the conveyor correction, a future launched in child mutated the diff --git a/doc/forking.md b/doc/forking.md index 648003ec..f06c7dab 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -68,15 +68,15 @@ application's responsibility, for example with an identity-keyed memo table. ## Current boundary -Var roots/metadata, all logical SCI atom state, SCI-created volatile values, -delays, and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches -are fork-local. On the JVM, SCI-created promises are fork-local as well. SCI's -`memoize` uses a fork-local atom for its cache. Atom metadata, validator, and -watch maps are inherited by a fork and can subsequently diverge; effects -performed by a watch are ordinary user capabilities and are not made -reversible automatically. Futures, lazy sequences, transients, mutable host -objects, mutable deftype fields, and effects outside SCI remain shared unless -the embedding application models or copies them. +Var roots, metadata, and watch maps; namespace metadata and loaded-library +state; all logical SCI atom state; SCI-created volatile values and delays; and +JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are +fork-local. On the JVM, SCI-created promises are fork-local as well. SCI's +`memoize` uses a fork-local atom for its cache. Effects performed by any watch +are ordinary user capabilities and are not made reversible automatically. +Futures, lazy sequences, transients, mutable host objects, mutable deftype +fields, and effects outside SCI remain shared unless the embedding application +models or copies them. On the JVM and CLJS an SCI-created atom is now a dedicated `SciAtom`, not the host's concrete `clojure.lang.Atom`/`cljs.core.Atom` class. It implements the diff --git a/src/sci/core.cljc b/src/sci/core.cljc index be541e3c..bf575526 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -340,9 +340,10 @@ fork-value (fork/value-forker fork-fn) forked-world (world/fork-world (:sci.impl/world ctx) fork-value - #(if (utils/var? %) - (vars/getRawRoot %) - (c/deref %)) + #(cond + (utils/var? %) (vars/getRawRoot %) + (utils/namespace? %) (meta %) + :else (c/deref %)) meta)] (assoc ctx :env (atom @(:env ctx)) @@ -688,7 +689,8 @@ #(doseq [[_ v] ns-map :when (and (utils/var? v) (not (world/registered? (:sci.impl/world ctx) v)))] - (world/register-var! v (vars/getRawRoot v) (meta v))))) + (world/register-var! v (vars/getRawRoot v) (meta v) + (vars/getRawWatches v))))) ctx) (defn find-ns diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 5cb52332..7b19189d 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -1082,7 +1082,19 @@ [iref f & args] (if (refs/sci-atom? iref) (apply refs/alter-meta!* iref f args) - (if (utils/var? iref) + (cond + (utils/namespace? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-namespace iref current-meta + (if (world/current-world) + (let [m (world/alter-namespace-meta! + iref current-meta f args)] + (when (world/primary-world?) + (cljs.core/reset-meta! iref m)) + m) + (apply cljs.core/alter-meta! iref f args)))) + + (utils/var? iref) (let [current-meta (meta iref)] (vars/with-writeable-var iref current-meta (if (world/current-world) @@ -1091,19 +1103,33 @@ (cljs.core/reset-meta! iref m)) m) (apply cljs.core/alter-meta! iref f args)))) - (if (utils/sci-type? iref) - (types/setVal iref (apply f (types/getVal iref) args)) - (let [m (meta iref)] - (if-not (:sci/built-in m) - (apply cljs.core/alter-meta! iref f args) - (throw (ex-info (str "Built-in var " iref " is read-only.") - {:var iref}))))))))) + + (utils/sci-type? iref) + (types/setVal iref (apply f (types/getVal iref) args)) + + :else + (let [m (meta iref)] + (if-not (:sci/built-in m) + (apply cljs.core/alter-meta! iref f args) + (throw (ex-info (str "Built-in var " iref " is read-only.") + {:var iref})))))))) #?(:cljs (defn reset-meta! [iref m] (if (refs/sci-atom? iref) (refs/reset-meta!* iref m) - (if (utils/var? iref) + (cond + (utils/namespace? iref) + (let [current-meta (meta iref)] + (vars/with-writeable-namespace iref current-meta + (if (world/current-world) + (do (world/reset-namespace-meta! iref m) + (when (world/primary-world?) + (cljs.core/reset-meta! iref m)) + m) + (cljs.core/reset-meta! iref m)))) + + (utils/var? iref) (let [current-meta (meta iref)] (vars/with-writeable-var iref current-meta (if (world/current-world) @@ -1112,6 +1138,8 @@ (cljs.core/reset-meta! iref m)) m) (cljs.core/reset-meta! iref m)))) + + :else (cljs.core/reset-meta! iref m))))) (defn- let** [expr _ bindings & body] @@ -1192,6 +1220,9 @@ imap))] `(let* [~ge ~e] (case* ~ge 0 0 ~default ~imap :sparse :hash-equiv nil)))) +(defn- fork-loaded-libs [libs] + (#?(:clj ref :cljs atom :cljd atom) @libs)) + (defn loaded-libs** [syms] (utils/dynamic-var '*loaded-libs* (#?(:cljd atom :clj ref :cljs atom) @@ -1201,7 +1232,8 @@ {:doc "A ref to a sorted set of symbols representing loaded libs" :ns clojure-core-ns :private true - :sci/built-in true})) + :sci/built-in true + :sci.impl/fork-fn fork-loaded-libs})) (defn loaded-libs* [] (-> (store/get-ctx) :env deref :namespaces diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index b3cb6b06..2529b92c 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -16,11 +16,18 @@ (store/with-ctx ctx (world/with-active-world ctx - #(doseq [[_ ns-map] (:namespaces @(:env ctx)) - [_ v] ns-map - :when (and (utils/var? v) - (not (world/registered? (:sci.impl/world ctx) v)))] - (world/register-var! v (vars/getRawRoot v) (meta v)))))) + #(do + (doseq [[_ ns-map] (:namespaces @(:env ctx)) + :let [ns-obj (:obj ns-map)] + :when ns-obj] + (world/register-namespace! ns-obj (meta ns-obj))) + (doseq [[_ ns-map] (:namespaces @(:env ctx)) + [_ v] ns-map + :when (and (utils/var? v) + (not (world/registered? + (:sci.impl/world ctx) v)))] + (world/register-var! v (vars/getRawRoot v) (meta v) + (vars/getRawWatches v))))))) #?(:clj (defrecord Env [namespaces imports load-fn])) diff --git a/src/sci/impl/utils.cljc b/src/sci/impl/utils.cljc index 100d5cfa..20bd8828 100644 --- a/src/sci/impl/utils.cljc +++ b/src/sci/impl/utils.cljc @@ -6,6 +6,7 @@ [sci.impl.macros :as macros] [sci.impl.types :as t] [sci.impl.vars :as vars] + [sci.impl.world :as world] [sci.lang :as lang]) #?(:cljs (:import [goog.string StringBuffer])) #?(:cljs (:require-macros [sci.impl.utils :refer [kw-identical? dotimes+]]))) @@ -211,12 +212,15 @@ adds it to env before returning it." [env ns-sym create? attr-map] (let [env* @env - ns-map (get-in env* [:namespaces ns-sym])] - (or (:obj ns-map) - (when (or ns-map create?) - (let [ns-obj (lang/->Namespace ns-sym attr-map)] - (swap! env assoc-in [:namespaces ns-sym :obj] ns-obj) - ns-obj))))) + ns-map (get-in env* [:namespaces ns-sym]) + ns-obj (or (:obj ns-map) + (when (or ns-map create?) + (let [ns-obj (lang/->Namespace ns-sym attr-map)] + (swap! env assoc-in [:namespaces ns-sym :obj] ns-obj) + ns-obj)))] + (when ns-obj + (world/register-namespace! ns-obj (meta ns-obj))) + ns-obj)) (defn reset-meta!* [x m] #?(:cljd (t/-reset-meta! x m) diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index 0dd04a74..e4db38f4 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -107,6 +107,7 @@ (defprotocol IVar (bindRoot [this v]) (getRawRoot [this]) + (getRawWatches [this]) (getDirectRoot [this]) (selectRoot [this world-value]) (getRootAt [this slot]) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 01b0c890..595af539 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -204,7 +204,24 @@ (let [world (.-world ^ReadWorld active)] (slot-value world (:meta-slot (descriptor world handle)) fallback))))) -(defn- allocate-descriptor! [^DenseWorld world handle kind host-fork?] +(defn namespace-meta [handle fallback] + (let [active (active-world-state)] + (if (or (nil? active) (.-primary? ^ReadWorld active)) + fallback + (let [world (.-world ^ReadWorld active)] + (slot-value world (:value-slot (descriptor world handle)) fallback))))) + +(defn var-watches [handle fallback] + (if-let [^ReadWorld active (active-world-state)] + (let [world (.-world active) + {:keys [watch-slot watch-fallback]} (descriptor world handle)] + (if watch-slot + (slot-value world watch-slot watch-fallback) + fallback)) + fallback)) + +(defn- allocate-descriptor! + [^DenseWorld world handle kind host-fork? value-fork-fn] (let [registry (.-registry world)] (with-registry-lock registry @@ -216,6 +233,7 @@ desc (cond-> {:kind kind :value-slot start :host-fork? host-fork?} + value-fork-fn (assoc :value-fork-fn value-fork-fn) (= :var kind) (assoc :meta-slot (inc start)))] (swap! registry (fn [r] @@ -381,19 +399,58 @@ (defn register! [handle value] (when-let [^DenseWorld world (current-world)] - (let [{:keys [value-slot]} (allocate-descriptor! world handle :ref true)] + (let [{:keys [value-slot]} + (allocate-descriptor! world handle :ref true nil)] (ensure-capacity! world (inc value-slot)) (cells-set! (current-cells world) value-slot value))) handle) -(defn register-var! [handle value m] +(defn- allocate-var-watch-slot! [^DenseWorld world handle fallback] + (let [registry (.-registry world)] + (with-registry-lock + registry + (fn [] + (let [desc (descriptor world handle)] + (if (:watch-slot desc) + desc + (let [slot (:next-slot @registry) + desc (assoc desc + :watch-slot slot + :watch-fallback fallback)] + (swap! registry + (fn [r] + (-> r + (assoc :next-slot (inc slot)) + (assoc-in [:descriptors handle] desc)))) + desc))))))) + +(defn register-var! + ([handle value m] + (register-var! handle value m nil)) + ([handle value m watches] + (when-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot meta-slot]} + (allocate-descriptor! world handle :var (not (:sci/built-in m)) + (:sci.impl/fork-fn m))] + (ensure-capacity! world (inc meta-slot)) + (let [cells (current-cells world)] + (cells-set! cells value-slot value) + (cells-set! cells meta-slot m)) + (when (seq watches) + (let [{:keys [watch-slot]} + (allocate-var-watch-slot! world handle watches)] + (ensure-capacity! world (inc watch-slot)) + (cells-set! (current-cells world) watch-slot watches))))) + handle)) + +(defn register-namespace! [handle m] (when-let [^DenseWorld world (current-world)] - (let [{:keys [value-slot meta-slot]} - (allocate-descriptor! world handle :var (not (:sci/built-in m)))] - (ensure-capacity! world (inc meta-slot)) + (let [{:keys [value-slot]} + (allocate-descriptor! world handle :namespace false nil)] + (ensure-capacity! world (inc value-slot)) (let [cells (current-cells world)] - (cells-set! cells value-slot value) - (cells-set! cells meta-slot m)))) + (when (identical? absent (cells-get cells value-slot)) + (cells-set! cells value-slot m))))) handle) (defn- reset-slot! [^DenseWorld world slot value] @@ -412,15 +469,25 @@ (if-let [^DenseWorld world (current-world)] (let [{:keys [meta-slot]} (or (descriptor world handle) (allocate-descriptor! world handle :var - (not (:sci/built-in m))))] + (not (:sci/built-in m)) + (:sci.impl/fork-fn m)))] (reset-slot! world meta-slot m)) ::no-world)) +(defn reset-namespace-meta! [handle m] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (or (descriptor world handle) + (allocate-descriptor! world handle :namespace false nil))] + (reset-slot! world value-slot m)) + ::no-world)) + (defn alter-var-meta! [handle fallback f args] (if-let [^DenseWorld world (current-world)] (let [{:keys [meta-slot]} (or (descriptor world handle) (allocate-descriptor! world handle :var - (not (:sci/built-in fallback))))] + (not (:sci/built-in fallback)) + (:sci.impl/fork-fn fallback)))] (ensure-capacity! world (inc meta-slot)) (loop [] (let [cells (current-cells world) @@ -430,6 +497,33 @@ (if (cells-cas! cells meta-slot raw-old new) new (recur))))) ::no-world)) +(defn alter-namespace-meta! [handle fallback f args] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (or (descriptor world handle) + (allocate-descriptor! world handle :namespace false nil))] + (ensure-capacity! world (inc value-slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells value-slot) + old (if (identical? absent raw-old) fallback raw-old) + new (apply f old args)] + (if (cells-cas! cells value-slot raw-old new) new (recur))))) + ::no-world)) + +(defn alter-var-watches! [handle fallback f args] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [watch-slot]} + (allocate-var-watch-slot! world handle fallback)] + (ensure-capacity! world (inc watch-slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells watch-slot) + old (if (identical? absent raw-old) fallback raw-old) + new (apply f old args)] + (if (cells-cas! cells watch-slot raw-old new) new (recur))))) + ::no-world)) + (defn swap-value! "Atomically update one tracked slot. Unrelated SCI atoms do not contend and cannot cause `f` to be retried." @@ -496,13 +590,16 @@ (dotimes [i n] (cells-set! target i (cells-get source i))) (when fork-value - (doseq [[_ {:keys [value-slot host-fork?]}] descriptors - :when host-fork? + (doseq [[_ {:keys [value-slot host-fork? value-fork-fn]}] descriptors + :when (or host-fork? value-fork-fn) :when (< value-slot n) :let [v (cells-get target value-slot)] :when (not (identical? absent v))] (cells-set! target value-slot - (if (contains? handles v) v (fork-value v)))) + (cond + (contains? handles v) v + value-fork-fn (value-fork-fn v) + :else (fork-value v)))) (doseq [{:keys [fork-slots]} managed-descriptors slot fork-slots :when (< slot n) diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index c71e198b..fde82afa 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -104,11 +104,12 @@ (when (world/primary-world?) (vars/bumping-set! root v))) (vars/bumping-set! root v))) - (notify-watches this watches old-root v)) + (notify-watches this (world/var-watches this watches) old-root v)) ;; this is the return value for alter-var-root which should be the only place calling bindRoot directly v) (getRawRoot [this] (world/var-value this root)) + (getRawWatches [_] watches) (getDirectRoot [this] (if thread-bound (if-let [tbox (vars/get-thread-binding this)] @@ -254,30 +255,78 @@ (set! meta m))))) IWatchable (-add-watch [this key fn] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (assoc watches key fn))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches assoc [key fn])) + (set! watches (assoc watches key fn))))) this) (-remove-watch [this key] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (dissoc watches key))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches dissoc [key])) + (set! watches (dissoc watches key))))) this)] :clj [clojure.lang.IRef (addWatch [this key fn] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (assoc watches key fn))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches assoc [key fn])) + (set! watches (assoc watches key fn))))) this) (removeWatch [this key] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (dissoc watches key))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches dissoc [key])) + (set! watches (dissoc watches key))))) this)] :cljs [IWatchable (-add-watch [this key fn] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (assoc watches key fn))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches assoc [key fn])) + (set! watches (assoc watches key fn))))) this) (-remove-watch [this key] - (vars/with-writeable-var this (world/var-meta this meta) - (set! watches (dissoc watches key))) + (let [current-meta (world/var-meta this meta)] + (vars/with-writeable-var this current-meta + (if (world/current-world) + (do + (when-not (world/tracked? this) + (world/register-var! + this root current-meta watches)) + (world/alter-var-watches! + this watches dissoc [key])) + (set! watches (dissoc watches key))))) this)]) ;; #?(:cljs Fn) ;; In the real CLJS this is there... why? #?(:cljd IFn :clj clojure.lang.IFn :cljs IFn) @@ -380,15 +429,35 @@ types/HasName (getName [_] name) #?(:cljd IMeta :clj clojure.lang.IMeta :cljs IMeta) - #?(:cljd (-meta [_] meta) :clj (clojure.core/meta [_] meta) :cljs (-meta [_] meta)) + #?(:cljd (-meta [this] (world/namespace-meta this meta)) + :clj (clojure.core/meta [this] (world/namespace-meta this meta)) + :cljs (-meta [this] (world/namespace-meta this meta))) #?@(:cljd [types/IResetMeta (-reset-meta! [this m] - (vars/with-writeable-namespace this meta - (set! meta m)))] + (let [current-meta (world/namespace-meta this meta)] + (vars/with-writeable-namespace this current-meta + (if (world/current-world) + (do (world/reset-namespace-meta! this m) + (when (world/primary-world?) (set! meta m)) + m) + (set! meta m)))))] :clj [clojure.lang.IReference (alterMeta [this f args] - (vars/with-writeable-namespace this meta - (locking this (set! meta (apply f meta args))))) + (let [current-meta (world/namespace-meta this meta)] + (vars/with-writeable-namespace this current-meta + (locking this + (if (world/current-world) + (let [m (world/alter-namespace-meta! + this current-meta f args)] + (when (world/primary-world?) (set! meta m)) + m) + (set! meta (apply f meta args))))))) (resetMeta [this m] - (vars/with-writeable-namespace this meta - (locking this (set! meta m))))])) + (let [current-meta (world/namespace-meta this meta)] + (vars/with-writeable-namespace this current-meta + (locking this + (if (world/current-world) + (do (world/reset-namespace-meta! this m) + (when (world/primary-world?) (set! meta m)) + m) + (set! meta m))))))])) diff --git a/test/sci/namespaces_test.cljc b/test/sci/namespaces_test.cljc index d82a041e..eb4a9d68 100644 --- a/test/sci/namespaces_test.cljc +++ b/test/sci/namespaces_test.cljc @@ -143,6 +143,28 @@ (is (= {:a 1, :b 1} (eval* "(ns ^{:a 1} foo {:b 1}) (meta *ns*) (ns bar) (meta (the-ns 'foo))")))) +(deftest forked-namespace-metadata-test + (let [parent (sci/init nil)] + (sci/eval-string* parent "(ns fork.meta {:branch :parent})") + (let [child (sci/fork parent)] + (is (identical? (sci/find-ns parent 'fork.meta) + (sci/find-ns child 'fork.meta))) + (is (= :child + (sci/eval-string* + child + "(alter-meta! (the-ns 'fork.meta) assoc :branch :child) + (:branch (meta (the-ns 'fork.meta)))"))) + (is (= :parent + (sci/eval-string* + parent "(:branch (meta (the-ns 'fork.meta)))"))) + (sci/eval-string* + parent "(alter-meta! (the-ns 'fork.meta) assoc :side :parent)") + (is (= [nil :parent] + [(sci/eval-string* + child "(:side (meta (the-ns 'fork.meta)))") + (sci/eval-string* + parent "(:side (meta (the-ns 'fork.meta)))")]))))) + (deftest recycle-namespace-objects (when-not tu/native? (is (empty? (set/difference (eval* "(set (all-ns))") (eval* "(set (all-ns))")))))) @@ -403,7 +425,24 @@ bar/bar"} {:load-fn (fn [{:keys [:namespace]}] (when (= 'foo.bar namespace) {:source "(ns foo.bar) (def x :success)" - :file "foo/bar.clj"}))}))))) + :file "foo/bar.clj"}))}))))) + +(deftest forked-loaded-libs-test + (let [parent (sci/init + {:load-fn + (fn [{:keys [:namespace]}] + (when (= 'fork.loaded namespace) + {:source "(ns fork.loaded) (def value :loaded)" + :file "fork/loaded.clj"}))}) + child (sci/fork parent)] + (is (= :loaded + (sci/eval-string* + child "@(requiring-resolve 'fork.loaded/value)"))) + (is (= [false true] + [(sci/eval-string* + parent "(contains? (loaded-libs) 'fork.loaded)") + (sci/eval-string* + child "(contains? (loaded-libs) 'fork.loaded)")])))) (deftest issue-1011 (is (= {:b 1} (sci/eval-string "(ns foo {:a 1}) (ns foo {:b 1}) (in-ns 'foo) (meta *ns*)")))) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index a9abc57a..b5e7d439 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -407,6 +407,35 @@ (sci/with-out-str (sci/eval-string "(def x 1) (add-watch #'x :foo (fn [k r o n] (prn :o o :n n))) (alter-var-root #'x (constantly 5))")) ":o 1 :n 5"))) +(deftest forked-var-watch-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(def effects (atom [])) + (def watched 0) + (add-watch #'watched :inherited + (fn [_ _ old new] + (swap! effects conj [:inherited old new])))") + (let [child (sci/fork parent)] + (sci/eval-string* + child + "(remove-watch #'watched :inherited) + (add-watch #'watched :child + (fn [_ _ old new] + (swap! effects conj [:child old new])))") + (is (= [1 [[:inherited 0 1]]] + (sci/eval-string* + parent + "(alter-var-root #'watched inc) [watched @effects]"))) + (is (= [0 []] + (sci/eval-string* child "[watched @effects]"))) + (is (= [1 [[:child 0 1]]] + (sci/eval-string* + child + "(alter-var-root #'watched inc) [watched @effects]"))) + (is (= [1 [[:inherited 0 1]]] + (sci/eval-string* parent "[watched @effects]")))))) + #?(:cljd nil :clj (deftest thread-binds From 6aa9f1753f8bab090f49a0299c85a468ff291df4 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:06:42 -0700 Subject: [PATCH 14/31] Isolate SCI type state and classify affine resources --- doc/fork-state-audit.md | 52 ++++++---- doc/forking.md | 41 +++++--- src/sci/core.cljc | 1 + src/sci/fork.cljc | 103 ++++++++++++++------ src/sci/impl/deftype.cljc | 31 ++++++ src/sci/impl/multimethods.cljc | 66 +++++++++---- src/sci/impl/namespaces.cljc | 2 + src/sci/impl/opts.cljc | 8 +- src/sci/impl/records.cljc | 19 +++- src/sci/impl/world.cljc | 111 ++++++++++++++++++---- src/sci/lang.cljc | 42 ++++++-- test/sci/core_test.cljc | 68 +++++++++++++ test/sci/defrecords_and_deftype_test.cljc | 34 +++++++ test/sci/native_protocols_test.cljs | 31 ++++++ 14 files changed, 499 insertions(+), 110 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 8d3a994f..31b98691 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -14,10 +14,10 @@ An SCI context currently has three relevant layers: `sci/fork` creates a new atom with the same map value. 2. A lineage registry maps stable handles to dense slots. Var roots and metadata use two slots, with an optional third slot allocated only when a - Var gains watches. Namespace objects use one metadata slot. A - self-describing SCI atom carries a hot value slot plus a cold control slot - for metadata, validator, and watches. Volatiles currently use one - registry-routed value slot. + Var gains watches. Namespace objects use one metadata slot and Type handles + use one descriptor-data slot. A self-describing SCI atom carries a hot value + slot plus a cold control slot for metadata, validator, and watches. + Volatiles currently use one registry-routed value slot. 3. Dynamic binding frames are control state outside the world. Active world, binding scope, and frame are consolidated in one execution-state cell. On the JVM it is a `ThreadLocal`; on CLJS and ClojureDart it is a process-local @@ -132,7 +132,8 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | SCI-created volatile value | Stable host handle, world-local value slot | Implemented | | Var watches | Optional dense world-local slot on a stable Var handle | Implemented; callbacks are inherited but their external effects remain capabilities | | Namespace metadata | Stable Namespace handle with a dense world-local metadata slot | Implemented | -| Type metadata and mutable deftype fields | Mutable fields on shared Type/SciType handles | Shared unintentionally | +| Type descriptor data | Stable Type handle with one dense world-local data slot | Implemented; CLJS native prototypes are cloned before child values are copied | +| SCI deftype instance fields | Directly stored instances implement `Forkable` and are shallow-copied with alias preservation | Implemented at the world-cell boundary; nested host state still requires cooperation | | `*loaded-libs*` | Built-in Var root has a per-cell copier for its host Ref/atom | Implemented; keeps the host representation while loaded sets diverge | | Delay | Stable SCI handle with world-local pending/realized state | Implemented; pending realizations split, while cached outcomes are inherited according to host delay semantics | | Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | @@ -140,11 +141,13 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | JVM Promise | Stable SCI handle with world-local pending/delivered state | Implemented; a pending child has no inherited waiters and delivery is branch-local | | CLJS Promise | Native asynchronous host value | External async resource; managed continuations convey a world but the Promise itself is not copied | | Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | -| Transient collection | Same affine host object | Shared; mutation in child is visible in parent | -| Array / JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | +| Transient collection | Detected as affine when directly stored in a world cell | Fork rejected by default; `:fork-fn` may impose an explicit application policy | +| JVM array / CLJS JavaScript array | Shallow-copied once per source identity | Implemented for direct world-cell values; nested elements retain their own policy | +| Host atom/ref/agent/volatile/native multimethod | Detected as unmanaged mutable state on JVM/CLJS | Fork rejected by default; `Forkable` wrapper or `:fork-fn` must choose copy or sharing | +| Plain JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | | JVM/CLJS SCI multimethod tables, preferences, and caches | Stable `SciMultiFn` handle with a fork-local host dispatch engine | Implemented; method mutations use copy-on-write and caches are rebuilt per fork | -| ClojureDart SCI multimethod tables | Mutable atom inside one `SciMultiFn` root | Shared; managed representation remains to be ported | -| Protocol/type extension registries | Mutable Type/protocol realization objects | Shared in several host-specific paths | +| ClojureDart SCI multimethod tables | Stable `SciMultiFn` with a dense world-local persistent method map | Implemented for interpreter-created exact-dispatch multimethods; built-in runtime tables remain global | +| SCI protocol extension registries | Protocol Vars and method multimethods are world-local | Implemented; CLJS native-protocol prototype mutations use each world's Type data and copied instances | | Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | | Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | | RNG, `gensym`, clock, UUID | Host/global nondeterministic source | External capability; not reproducibly forked | @@ -164,7 +167,8 @@ A JVM probe against the current implementation produced these results: parent without running the delayed body in the parent; - before managed JVM promises, delivering a child promise delivered the parent promise; -- mutating a child transient or array changed the object seen by the parent; +- before affine rejection and built-in array copying, mutating a child + transient or array changed the object seen by the parent; - using a memoized function in the child populated the cache used by parent; - a child `defmethod` installed the method in parent; - before self-describing atoms, child atom metadata changes appeared in the @@ -302,8 +306,9 @@ common dispatch path pays only world selection and a direct slot read before using the native cache. In a deliberately harsh direct-host-call benchmark that added roughly 15--18 percent over the previous shared host `MultiFn`; in an interpreted million-call loop, repeated runs ranged from approximately -noise to nine percent. ClojureDart retains its earlier shared table pending a -portable managed implementation and test runtime. +noise to nine percent. ClojureDart routes its exact-dispatch persistent method +map through an ordinary world slot; the Dart test suite was unavailable in the +current environment, so that port still needs verification on a Dart host. ### Memoization and lazy computation @@ -322,6 +327,14 @@ when reachable from a world cell unless an application wrapper defines a safe policy. Arrays, mutable deftype fields, and application collections may be duplicable, but need self-describing SCI handles or `Forkable` cooperation. +Directly stored host transients are now rejected by the default value forker. +Supplying `:fork-fn` is an explicit override and can deliberately share or +replace them. The check remains shallow, like all host cooperation: a transient +hidden inside an unclassified host container is that container's +responsibility. Directly stored standard `SciType` deftype instances implement +`Forkable`; their field map is shallow-copied once per source identity, so +aliases remain aliases in the child and later field replacements diverge. + ## Recommended implementation order 1. Preserve the corrected asynchronous world conveyance and extend it to any @@ -330,13 +343,14 @@ duplicable, but need self-describing SCI handles or `Forkable` cooperation. async suspension and eventual execution snapshots. 3. Address lineage-registry liveness so adding more tracked handles does not create an unbounded retention problem. -4. Finish split identity/state for Var watches, namespace/type metadata, - volatiles, and `*loaded-libs*`. -5. Finish the ClojureDart multimethod port. JVM/CLJS multimethod state and SCI - memoization caches are implemented. -6. Add managed Delay and choose a pending-Promise policy. -7. Reject or explicitly classify transients, running futures, streams, and - other affine/external resources. +4. Verify and tune the implemented split identity/state paths on every host, + especially ClojureDart multimethods and CLJS native protocol prototypes. +5. Reject or explicitly classify running futures, streams, lazy realizations, + and other affine/external resources; keep nested host graphs cooperative. +6. Define forkable RNG, gensym, clock, and UUID capabilities for reproducible + execution where applications require them. +7. Benchmark fork cost and hot reads against upstream, then consider paged + copy-on-write cells only if workloads with frequent forks justify it. 8. Introduce execution/fiber snapshots for lazy continuations and the future lambda-join/Simmis runtime. diff --git a/doc/forking.md b/doc/forking.md index f06c7dab..937236f6 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -58,25 +58,39 @@ one fork and preserves aliases to its result. Only values directly stored in world cells are inspected. A host container that holds mutable children must implement the protocol and copy its own graph. -Unclassified values retain the compatibility behavior of being shared. +Unclassified values retain the compatibility behavior of being shared, except +for known affine or mutable host primitives that SCI can identify safely. +Direct host atoms, refs, agents, volatiles, multimethods, and transient +collections are rejected unless an explicit policy handles them. `sci/init` and the two-argument `sci/fork` also accept `:fork-fn`, a legacy one-argument fallback applied to unclassified values stored in world cells. It may copy application-owned state and should return immutable values unchanged. -Unlike the protocol path, callback alias preservation remains the -application's responsibility, for example with an identity-keyed memo table. +The per-fork identity memo applies to protocol, callback, and built-in copying, +so identical direct cell values are transformed once and remain aliases in the +child. ## Current boundary Var roots, metadata, and watch maps; namespace metadata and loaded-library -state; all logical SCI atom state; SCI-created volatile values and delays; and -JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are -fork-local. On the JVM, SCI-created promises are fork-local as well. SCI's -`memoize` uses a fork-local atom for its cache. Effects performed by any watch -are ordinary user capabilities and are not made reversible automatically. -Futures, lazy sequences, transients, mutable host objects, mutable deftype -fields, and effects outside SCI remain shared unless the embedding application -models or copies them. +state; all logical SCI atom state; SCI-created volatile values and delays; SCI +type descriptor data; and JVM/CLJS SCI multimethod tables, preferences, and +dispatch caches are fork-local. ClojureDart's exact-dispatch SCI multimethod +tables are fork-local as well. Directly stored SCI deftype instances are +shallow-copied with alias preservation, so their mutable field maps diverge. +On the JVM, SCI-created promises are fork-local as well. SCI's `memoize` uses a +fork-local atom for its cache. Effects performed by any watch are ordinary user +capabilities and are not made reversible automatically. Futures, lazy +sequences, nested mutable host objects, and effects outside SCI remain shared +unless the embedding application models or copies them. CLJS native-protocol +prototypes are cloned with Type data before child deftype/record values are +copied, so later child extensions do not change the parent's instances. A +transient collection directly stored in +world state is rejected as affine by default; an explicit `:fork-fn` can +instead impose an application-specific copy, share, or rejection policy. +Directly stored JVM arrays and CLJS JavaScript arrays are shallow-copied by +default with aliases preserved. Known unmanaged host reference primitives are +also rejected by default, requiring `Forkable` or `:fork-fn` cooperation. On the JVM and CLJS an SCI-created atom is now a dedicated `SciAtom`, not the host's concrete `clojure.lang.Atom`/`cljs.core.Atom` class. It implements the @@ -92,6 +106,11 @@ the stable `SciMultiFn` handle selects a fork-local host dispatch engine. SCI's code that tests specifically for the concrete host `MultiFn` class can observe the difference. +ClojureDart has no host hierarchy/cache engine to clone. Its stable +`SciMultiFn` instead routes the persistent exact-dispatch method map through a +dense world slot; built-in runtime multimethods created outside an SCI world +retain their process-global tables. + SCI delays also have stable interpreter-owned identity. Forking a pending delay creates an independent pending realization in the child; forking a completed delay inherits its cached value or exception according to the host's delay diff --git a/src/sci/core.cljc b/src/sci/core.cljc index bf575526..8ba0219f 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -343,6 +343,7 @@ #(cond (utils/var? %) (vars/getRawRoot %) (utils/namespace? %) (meta %) + (utils/sci-type? %) (t/getVal %) :else (c/deref %)) meta)] (assoc ctx diff --git a/src/sci/fork.cljc b/src/sci/fork.cljc index de3cf4ae..811d3688 100644 --- a/src/sci/fork.cljc +++ b/src/sci/fork.cljc @@ -10,6 +10,46 @@ (fork-value [this] "Return this value's realization in the child world.")) +(defn- transient-value? [value] + #?(:clj (instance? clojure.lang.ITransientCollection value) + :cljs (satisfies? ITransientCollection value) + :cljd (satisfies? ITransientCollection value))) + +(defn- unmanaged-mutable-value? [value] + #?(:clj (or (instance? clojure.lang.Atom value) + (instance? clojure.lang.Ref value) + (instance? clojure.lang.Agent value) + (instance? clojure.lang.Volatile value) + (instance? clojure.lang.MultiFn value)) + :cljs (or (instance? cljs.core/Atom value) + (instance? cljs.core/Volatile value) + (instance? cljs.core/MultiFn value)) + ;; Portable concrete runtime types for these hosts still need auditing. + :cljd false)) + +(defn- default-fork-value [value] + (cond + (transient-value? value) + (throw (ex-info + "Cannot fork a SCI world containing an affine transient collection. Provide :fork-fn to define an explicit policy." + {:type ::affine-resource + :resource value})) + + (unmanaged-mutable-value? value) + (throw (ex-info + "Cannot fork a SCI world containing an unmanaged mutable host value. Implement Forkable or provide :fork-fn to define an explicit policy." + {:type ::unmanaged-mutable-value + :resource value})) + + #?(:clj (and (some? value) (.isArray ^Class (class value))) + :cljs (array? value) + :cljd false) + #?(:clj (aclone value) + :cljs (.slice value) + :cljd value) + + :else value)) + #?(:clj (defn- memoized-forker [fallback] (let [memo (java.util.IdentityHashMap.) @@ -18,25 +58,30 @@ ;; every Var root. Preserve extend-type support when it is in use. extended? (boolean (seq (extenders Forkable)))] (fn [value] - (if (or (instance? sci.fork.Forkable value) - (and extended? (satisfies? Forkable value))) - (if (.containsKey memo value) - (.get memo value) - (let [forked (fork-value value)] - (.put memo value forked) - forked)) - (if fallback (fallback value) value))))) + (if (.containsKey memo value) + (.get memo value) + (let [forked + (if (or (instance? sci.fork.Forkable value) + (and extended? (satisfies? Forkable value))) + (fork-value value) + (if fallback + (fallback value) + (default-fork-value value)))] + (.put memo value forked) + forked))))) :cljs (defn- memoized-forker [fallback] (let [memo (js/Map.)] (fn [value] - (if (satisfies? Forkable value) - (if (.has memo value) - (.get memo value) - (let [forked (fork-value value)] - (.set memo value forked) - forked)) - (if fallback (fallback value) value))))) + (if (.has memo value) + (.get memo value) + (let [forked (if (satisfies? Forkable value) + (fork-value value) + (if fallback + (fallback value) + (default-fork-value value)))] + (.set memo value forked) + forked))))) :cljd (defn- memoized-forker [fallback] ;; ClojureDart has no portable identity-map abstraction. Forkable host @@ -44,19 +89,21 @@ (let [memo (volatile! []) missing (Object.)] (fn [value] - (if (satisfies? Forkable value) - (let [cached (reduce (fn [_ [source forked]] - (if (identical? source value) - (reduced forked) - missing)) - missing - @memo)] - (if (identical? missing cached) - (let [forked (fork-value value)] - (vswap! memo conj [value forked]) - forked) - cached)) - (if fallback (fallback value) value)))))) + (let [cached (reduce (fn [_ [source forked]] + (if (identical? source value) + (reduced forked) + missing)) + missing + @memo)] + (if (identical? missing cached) + (let [forked (if (satisfies? Forkable value) + (fork-value value) + (if fallback + (fallback value) + (default-fork-value value)))] + (vswap! memo conj [value forked]) + forked) + cached)))))) (defn ^:no-doc value-forker "Create the value transformer for one SCI fork." diff --git a/src/sci/impl/deftype.cljc b/src/sci/impl/deftype.cljc index d4621afb..b3f74a4c 100644 --- a/src/sci/impl/deftype.cljc +++ b/src/sci/impl/deftype.cljc @@ -2,6 +2,7 @@ {:no-doc true} (:refer-clojure :exclude [deftype]) (:require + [sci.fork :as fork] [sci.ctx-store :as store] #?(:cljd [sci.impl.multimethods :as mm]) [sci.impl.types :as types] @@ -60,6 +61,8 @@ (defprotocol SciPrintMethod (-sci-print-method [x w])) +#?(:cljs (declare fork-sci-type)) + (clojure.core/deftype SciType [rec-name type @@ -82,6 +85,11 @@ (set! ext-map (assoc ext-map k v)) v) + fork/Forkable + (fork-value [this] + #?(:cljs (fork-sci-type this) + :default (SciType. rec-name type type-meta ext-map))) + #?@(:cljd [IFn (-invoke [this] (types/sci-invoke this)) (-invoke [this a] (types/sci-invoke this a)) @@ -186,6 +194,18 @@ (getProtocols [_] nil) (getFields [_] ext-map)) +#?(:cljs + (defn fork-sci-type [^SciType this] + (let [type (.-type this) + proto (if (instance? lang/Type type) + (:sci.impl/js-prototype (types/getVal type)) + (js/Object.getPrototypeOf this)) + obj (js/Object.create proto)] + (.call SciType obj + (.-rec-name this) type (.-type-meta this) + (types/getVal this)) + obj))) + #?(:cljs (defn new-js-prototype "Fresh prototype chaining to base-class's (SciType or SciRecord), so @@ -194,6 +214,17 @@ ([] (new-js-prototype SciType)) ([base-class] (js/Object.create (.-prototype base-class))))) +#?(:cljs + (defn fork-type-data + "Clone a type's mutable JS prototype for a child SCI world." + [data] + (if-let [source (:sci.impl/js-prototype data)] + (let [target (js/Object.create (js/Object.getPrototypeOf source))] + (js/Object.defineProperties + target (js/Object.getOwnPropertyDescriptors source)) + (assoc data :sci.impl/js-prototype target)) + data))) + #?(:cljs (defn -install-field-accessors! "Installs a JS accessor on the type's prototype for each field, so diff --git a/src/sci/impl/multimethods.cljc b/src/sci/impl/multimethods.cljc index 066d9c50..1a2265d1 100644 --- a/src/sci/impl/multimethods.cljc +++ b/src/sci/impl/multimethods.cljc @@ -15,6 +15,22 @@ (defn- no-method [mm-name dv] (throw (ex-info (str "No method in multimethod '" mm-name "' for dispatch value: " dv) {})))) +#?(:cljd + (do + (def ^:private missing-method-table-value (Object.)) + + (defn- cljd-method-table-value [method-table] + (let [value (world/value method-table missing-method-table-value)] + (if (identical? value missing-method-table-value) + @method-table + value))) + + (defn- cljd-swap-method-table! [method-table f & args] + (if (world/tracked? method-table) + (world/swap-value! method-table f args + (fn [_] nil) (fn [_ _] nil)) + (apply swap! method-table f args))))) + #?(:cljd nil :default (do @@ -197,45 +213,48 @@ ;; no hierarchies on cljd, dispatch is exact match with a default fallback #?(:cljd (deftype SciMultiFn [mm-name dispatch-fn default method-table] + fork/Forkable + (fork-value [this] this) + IFn (-invoke [_] - (let [dv (dispatch-fn) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f) (no-method mm-name dv)))) (-invoke [_ a] - (let [dv (dispatch-fn a) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a) (no-method mm-name dv)))) (-invoke [_ a b] - (let [dv (dispatch-fn a b) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b) (no-method mm-name dv)))) (-invoke [_ a b c] - (let [dv (dispatch-fn a b c) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c) (no-method mm-name dv)))) (-invoke [_ a b c d] - (let [dv (dispatch-fn a b c d) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d) (no-method mm-name dv)))) (-invoke [_ a b c d e] - (let [dv (dispatch-fn a b c d e) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d e) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d e) (no-method mm-name dv)))) (-invoke [_ a b c d e f*] - (let [dv (dispatch-fn a b c d e f*) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d e f*) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d e f*) (no-method mm-name dv)))) (-invoke [_ a b c d e f* g] - (let [dv (dispatch-fn a b c d e f* g) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d e f* g) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d e f* g) (no-method mm-name dv)))) (-invoke [_ a b c d e f* g h] - (let [dv (dispatch-fn a b c d e f* g h) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d e f* g h) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d e f* g h) (no-method mm-name dv)))) (-invoke [_ a b c d e f* g h i] - (let [dv (dispatch-fn a b c d e f* g h i) mt @method-table f (or (get mt dv) (get mt default))] + (let [dv (dispatch-fn a b c d e f* g h i) mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (f a b c d e f* g h i) (no-method mm-name dv)))) (-invoke-more [_ a b c d e f* g h i rest*] (let [dv (apply dispatch-fn a b c d e f* g h i rest*) - mt @method-table + mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (apply f a b c d e f* g h i rest*) (no-method mm-name dv)))) (-apply [this args] (let [dv (apply dispatch-fn args) - mt @method-table + mt (cljd-method-table-value method-table) f (or (get mt dv) (get mt default))] (if f (apply f args) (no-method mm-name dv)))))) @@ -335,13 +354,16 @@ (instance? cljs.core/MultiFn x)))) (defn multi-fn-impl [name dispatch-fn default hierarchy] - #?(:cljd (SciMultiFn. name dispatch-fn default (atom {})) + #?(:cljd (let [method-table (atom {})] + (world/register! method-table {}) + (SciMultiFn. name dispatch-fn default method-table)) :default (managed-multifn name dispatch-fn default hierarchy))) (defn multi-fn-add-method-impl [multifn dispatch-val f] - #?(:cljd (do (swap! (.-method-table ^SciMultiFn multifn) assoc - (normalize-dispatch-val dispatch-val) f) + #?(:cljd (do (cljd-swap-method-table! + (.-method-table ^SciMultiFn multifn) assoc + (normalize-dispatch-val dispatch-val) f) multifn) :default (if (instance? SciMultiFn multifn) @@ -351,7 +373,8 @@ (defn get-method-impl [multifn dispatch-val] #?(:cljd - (let [mt @(.-method-table ^SciMultiFn multifn) + (let [mt (cljd-method-table-value + (.-method-table ^SciMultiFn multifn)) dispatch-val (normalize-dispatch-val dispatch-val)] (or (get mt dispatch-val) (get mt (.-default ^SciMultiFn multifn)))) :default @@ -362,7 +385,7 @@ dispatch-val))) (defn methods-impl [multifn] - #?(:cljd @(.-method-table ^SciMultiFn multifn) + #?(:cljd (cljd-method-table-value (.-method-table ^SciMultiFn multifn)) :default (host-methods (if (instance? SciMultiFn multifn) @@ -379,8 +402,9 @@ (defn remove-method-impl [multifn dispatch-val] #?(:cljd - (do (swap! (.-method-table ^SciMultiFn multifn) - dissoc (normalize-dispatch-val dispatch-val)) + (do (cljd-swap-method-table! + (.-method-table ^SciMultiFn multifn) + dissoc (normalize-dispatch-val dispatch-val)) multifn) :default (if (instance? SciMultiFn multifn) @@ -390,7 +414,9 @@ (defn remove-all-methods-impl [multifn] #?(:cljd - (do (reset! (.-method-table ^SciMultiFn multifn) {}) multifn) + (do (cljd-swap-method-table! + (.-method-table ^SciMultiFn multifn) (constantly {})) + multifn) :default (if (instance? SciMultiFn multifn) (mutate-sci-multifn! multifn host-reset!) diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 7b19189d..14da7adb 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -924,6 +924,8 @@ (do (types/setVal existing data) existing) (sci.lang/->Type data))] + (world/register-type! + t data #?(:cljs sci.impl.deftype/fork-type-data :default nil)) (swap! env (fn [env] (-> env (update-in [:namespaces cnn :types] assoc type-name t) diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index 2529b92c..00e2fa50 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -4,7 +4,7 @@ #?(:cljs [goog.string]) [sci.ctx-store :as store] [sci.impl.namespaces :as namespaces] - [sci.impl.types] + [sci.impl.types :as types] [sci.impl.utils :as utils :refer [strip-core-ns]] [sci.impl.vars :as vars] [sci.impl.world :as world] @@ -21,6 +21,12 @@ :let [ns-obj (:obj ns-map)] :when ns-obj] (world/register-namespace! ns-obj (meta ns-obj))) + (doseq [[_ ns-map] (:namespaces @(:env ctx)) + [_ t] (:types ns-map) + :when (utils/sci-type? t)] + (world/register-type! + t (types/getVal t) + #?(:cljs sci.impl.deftype/fork-type-data :default nil))) (doseq [[_ ns-map] (:namespaces @(:env ctx)) [_ v] ns-map :when (and (utils/var? v) diff --git a/src/sci/impl/records.cljc b/src/sci/impl/records.cljc index a0ebac13..d7a629d4 100644 --- a/src/sci/impl/records.cljc +++ b/src/sci/impl/records.cljc @@ -2,6 +2,7 @@ {:no-doc true} (:refer-clojure :exclude [defrecord record?]) (:require [clojure.string :as str] + [sci.fork :as fork] #?(:cljd [sci.impl.multimethods :as mm]) [sci.impl.types :as types] [sci.impl.utils :as utils] @@ -277,7 +278,7 @@ (applyTo [this args] (types/sci-apply-to this args)))) ;; See https://github.com/clojure/clojurescript/blob/9562ae11422243e0648a12c39e7c990ef3f94260/src/main/clojure/cljs/core.cljc#L1804 -#?(:cljs (declare clone-record*)) +#?(:cljs (declare clone-record* fork-record*)) #?(:cljs (deftype SciRecord [rec-name @@ -291,6 +292,10 @@ (-clone [this] (clone-record* this ext-map my_hash)) + fork/Forkable + (fork-value [this] + (fork-record* this)) + IHash (-hash [_] (let [hq my_hash] @@ -410,6 +415,18 @@ (.-type-meta this) ext-map my-hash) obj))) +#?(:cljs + (defn fork-record* [^SciRecord this] + (let [type (.-type this) + proto (if (instance? lang/Type type) + (:sci.impl/js-prototype (types/getVal type)) + (js/Object.getPrototypeOf this)) + obj (js/Object.create proto)] + (.call SciRecord obj + (.-rec-name this) type (.-basis-fields this) + (.-type-meta this) (.-ext-map this) (.-my_hash this)) + obj))) + #?(:cljd (defn ->record-impl [rec-name type basis-fields type-meta m] (SciRecord. rec-name type basis-fields type-meta m nil)) :clj (defn ->record-impl [rec-name type basis-fields type-meta m] diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 595af539..41199f64 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -211,6 +211,13 @@ (let [world (.-world ^ReadWorld active)] (slot-value world (:value-slot (descriptor world handle)) fallback))))) +(defn type-data [handle fallback] + (let [active (active-world-state)] + (if (or (nil? active) (.-primary? ^ReadWorld active)) + fallback + (let [world (.-world ^ReadWorld active)] + (slot-value world (:value-slot (descriptor world handle)) fallback))))) + (defn var-watches [handle fallback] (if-let [^ReadWorld active (active-world-state)] (let [world (.-world active) @@ -227,7 +234,11 @@ registry (fn [] (if-let [desc (get-in @registry [:descriptors handle])] - desc + (if (and value-fork-fn (nil? (:value-fork-fn desc))) + (let [desc (assoc desc :value-fork-fn value-fork-fn)] + (swap! registry assoc-in [:descriptors handle] desc) + desc) + desc) (let [start (:next-slot @registry) width (if (= :var kind) 2 1) desc (cond-> {:kind kind @@ -453,6 +464,19 @@ (cells-set! cells value-slot m))))) handle) +(defn register-type! + ([handle data] + (register-type! handle data nil)) + ([handle data value-fork-fn] + (when-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (allocate-descriptor! world handle :type false value-fork-fn)] + (ensure-capacity! world (inc value-slot)) + (let [cells (current-cells world)] + (when (identical? absent (cells-get cells value-slot)) + (cells-set! cells value-slot data))))) + handle)) + (defn- reset-slot! [^DenseWorld world slot value] (if (nil? slot) ::no-world @@ -482,6 +506,14 @@ (reset-slot! world value-slot m)) ::no-world)) +(defn reset-type-data! [handle data] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (or (descriptor world handle) + (allocate-descriptor! world handle :type false nil))] + (reset-slot! world value-slot data)) + ::no-world)) + (defn alter-var-meta! [handle fallback f args] (if-let [^DenseWorld world (current-world)] (let [{:keys [meta-slot]} (or (descriptor world handle) @@ -511,6 +543,20 @@ (if (cells-cas! cells value-slot raw-old new) new (recur))))) ::no-world)) +(defn alter-type-data! [handle fallback f args] + (if-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (or (descriptor world handle) + (allocate-descriptor! world handle :type false nil))] + (ensure-capacity! world (inc value-slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells value-slot) + old (if (identical? absent raw-old) fallback raw-old) + new (apply f old args)] + (if (cells-cas! cells value-slot raw-old new) new (recur))))) + ::no-world)) + (defn alter-var-watches! [handle fallback f args] (if-let [^DenseWorld world (current-world)] (let [{:keys [watch-slot]} @@ -577,6 +623,21 @@ (vreset! (.-persistent? world) true)) world) +(defn- call-with-selected-world [^DenseWorld world f] + (let [state #?(:clj (.get ^ThreadLocal execution/current) + :default (execution/current-state)) + previous (execution/active-world state) + previous-scope (execution/binding-scope state)] + (execution/set-active-world! state (ReadWorld. world false)) + (execution/set-binding-scope! state world) + (execution/refresh-active-bindings! state) + (try + (f) + (finally + (execution/set-active-world! state previous) + (execution/set-binding-scope! state previous-scope) + (execution/refresh-active-bindings! state))))) + (defn- copy-world [^DenseWorld world fork-value] (sweep-managed! world) (let [source (current-cells world) @@ -586,31 +647,41 @@ registry-state @registry descriptors (:descriptors registry-state) managed-descriptors (:managed-descriptors registry-state) - handles (set (keys descriptors))] + handles (set (keys descriptors)) + target-world (DenseWorld. + (volatile! target) + registry + #?(:clj (ReentrantReadWriteLock.) :default nil) + (volatile! true))] (dotimes [i n] (cells-set! target i (cells-get source i))) (when fork-value - (doseq [[_ {:keys [value-slot host-fork? value-fork-fn]}] descriptors - :when (or host-fork? value-fork-fn) + ;; Per-cell copiers establish target-local type/control realizations + ;; before general Forkable values inspect the child world. + (doseq [[_ {:keys [value-slot value-fork-fn]}] descriptors + :when value-fork-fn :when (< value-slot n) :let [v (cells-get target value-slot)] :when (not (identical? absent v))] - (cells-set! target value-slot - (cond - (contains? handles v) v - value-fork-fn (value-fork-fn v) - :else (fork-value v)))) - (doseq [{:keys [fork-slots]} managed-descriptors - slot fork-slots - :when (< slot n) - :let [v (cells-get target slot)] - :when (not (identical? absent v))] - (cells-set! target slot (fork-value v)))) - (DenseWorld. - (volatile! target) - registry - #?(:clj (ReentrantReadWriteLock.) :default nil) - (volatile! true)))) + (cells-set! target value-slot (value-fork-fn v))) + (call-with-selected-world + target-world + (fn [] + (doseq [[_ {:keys [value-slot host-fork? value-fork-fn]}] + descriptors + :when (and host-fork? (nil? value-fork-fn)) + :when (< value-slot n) + :let [v (cells-get target value-slot)] + :when (not (identical? absent v))] + (cells-set! target value-slot + (if (contains? handles v) v (fork-value v)))) + (doseq [{:keys [fork-slots]} managed-descriptors + slot fork-slots + :when (< slot n) + :let [v (cells-get target slot)] + :when (not (identical? absent v))] + (cells-set! target slot (fork-value v)))))) + target-world)) (defn fork-world [^DenseWorld world fork-value snapshot-value snapshot-var-meta] #?(:clj diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index fde82afa..5f45f476 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -13,37 +13,59 @@ (deftype ^{:doc "Representation of a SCI custom type, created e.g. with `(defrecord Foo [])`. The fields of this type are implementation detail and should not be accessed directly."} Type [#?(:cljd ^:mutable data :clj ^:volatile-mutable data :cljs ^:volatile-mutable data)] sci.impl.types/IBox - (getVal [_] data) - (setVal [_ v] (set! data v)) + (getVal [this] (world/type-data this data)) + (setVal [this v] + (if (world/current-world) + (do + (world/reset-type-data! this v) + (when (world/primary-world?) (set! data v)) + v) + (set! data v))) Object ;; NOTE: returns "user.Foo" rather than "class user.Foo" (unlike java.lang.Class). ;; Changing this would break downstream libs (e.g. prismatic/schema). - (toString [_] - (str (:sci.impl/type-name data))) + (toString [this] + (str (:sci.impl/type-name (world/type-data this data)))) ;; meta is only supported to get our implementation! keys out #?@(:cljd [IMeta - (-meta [_] data)] + (-meta [this] (world/type-data this data))] :clj [clojure.lang.IMeta - (meta [_] data)] + (meta [this] (world/type-data this data))] :cljs [IMeta - (-meta [_] data)]) + (-meta [this] (world/type-data this data))]) ;; support alter-meta! for storing print-method etc. #?@(:cljd [types/IResetMeta - (-reset-meta! [_ m] (set! data m))] + (-reset-meta! [this m] + (if (world/current-world) + (do + (world/reset-type-data! this m) + (when (world/primary-world?) (set! data m)) + m) + (set! data m)))] :clj [clojure.lang.IReference (alterMeta [this f args] (locking this - (set! data (apply f data args)))) + (if (world/current-world) + (let [m (world/alter-type-data! + this (world/type-data this data) f args)] + (when (world/primary-world?) (set! data m)) + m) + (set! data (apply f data args))))) (resetMeta [this m] (locking this - (set! data m)))]) + (if (world/current-world) + (do + (world/reset-type-data! this m) + (when (world/primary-world?) (set! data m)) + m) + (set! data m))))]) types/HasName (getName [this] (str this))) diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 8c3842a4..1ae14557 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1650,6 +1650,74 @@ (:resource (ex-data e))))] (is (= :socket result)))) +(deftest affine-transient-fork-policy-test + (let [parent (sci/init nil) + transient-value (sci/eval-string* + parent "(def working (transient [])) working")] + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo + :clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) + #"affine transient collection" + (sci/fork parent))) + (let [child (sci/fork parent {:fork-fn identity})] + (is (identical? transient-value + (sci/eval-string* child "working")))))) + +#?(:cljd nil + :default + (deftest forked-array-state-test + (let [parent (sci/init nil) + parent-array (sci/eval-string* + parent + "(def buffer (object-array [1 2])) + (def buffer-alias buffer) + buffer") + child (sci/fork parent) + child-array (sci/eval-string* child "buffer")] + (is (not (identical? parent-array child-array))) + (is (= [true 9] + (sci/eval-string* + child + "(aset buffer 0 9) + [(identical? buffer buffer-alias) (aget buffer 0)]"))) + (is (= [true 1] + (sci/eval-string* + parent + "[(identical? buffer buffer-alias) (aget buffer 0)]")))))) + +#?(:cljd nil + :default + (deftest unmanaged-host-reference-fork-policy-test + (let [user-ns (sci/create-ns 'user) + host-state (atom 0) + copies (atom 0) + state-var (sci/new-var 'host-state host-state {:ns user-ns}) + alias-var (sci/new-var 'host-state-alias host-state {:ns user-ns}) + parent (sci/init + {:namespaces + {'user {'host-state state-var + 'host-state-alias alias-var}}})] + (is (thrown-with-msg? + #?(:clj clojure.lang.ExceptionInfo :cljs ExceptionInfo) + #"unmanaged mutable host value" + (sci/fork parent))) + (let [child + (sci/fork + parent + {:fork-fn + (fn [value] + (if (identical? value host-state) + (do (swap! copies inc) (atom @value)) + value))})] + (is (= 1 @copies)) + (is (= [true 1] + (sci/eval-string* + child + "[(identical? host-state host-state-alias) + (swap! host-state inc)]"))) + (is (= 0 @host-state)))))) + #?(:clj (deftest fork-host-value-cooperation-test (let [user-ns (sci/create-ns 'user) diff --git a/test/sci/defrecords_and_deftype_test.cljc b/test/sci/defrecords_and_deftype_test.cljc index 5a21d0f5..f37e49b9 100644 --- a/test/sci/defrecords_and_deftype_test.cljc +++ b/test/sci/defrecords_and_deftype_test.cljc @@ -279,6 +279,40 @@ (is (= "user.Dude" (tu/eval* "(defrecord Dude []) (str Dude)" {}))) (is (= "user.Dude" (tu/eval* "(deftype Dude []) (str Dude)" {})))) +(deftest forked-deftype-instance-state-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(defprotocol IForkBox (bump! [_]) (box-value [_])) + (deftype ForkBox [^:volatile-mutable value] + IForkBox + (bump! [this] (set! value (inc value)) this) + (box-value [_] value)) + (def box (->ForkBox 1)) + (def box-alias box)") + (let [parent-box (sci/eval-string* parent "box") + child (sci/fork parent) + child-box (sci/eval-string* child "box")] + (is (not (identical? parent-box child-box))) + (is (true? (sci/eval-string* child "(identical? box box-alias)"))) + (is (= 2 (sci/eval-string* child "(box-value (bump! box))"))) + (is (= 1 (sci/eval-string* parent "(box-value box)")))))) + +(deftest forked-type-metadata-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(deftype ForkMeta []) + (alter-meta! ForkMeta assoc :branch :parent)") + (let [child (sci/fork parent)] + (is (= :child + (sci/eval-string* + child + "(alter-meta! ForkMeta assoc :branch :child) + (:branch (meta ForkMeta))"))) + (is (= :parent + (sci/eval-string* parent "(:branch (meta ForkMeta))")))))) + (deftest equiv-test (let [prog "(defrecord Foo [a]) (defrecord Bar [a]) [(= (->Foo 1) (->Foo 1)) (= (->Foo 1) (->Bar 1)) (= (->Foo 1) {:a 1})]"] (is (= [true false false] (tu/eval* prog {}))))) diff --git a/test/sci/native_protocols_test.cljs b/test/sci/native_protocols_test.cljs index 0687fda2..86fd42e2 100644 --- a/test/sci/native_protocols_test.cljs +++ b/test/sci/native_protocols_test.cljs @@ -147,6 +147,37 @@ f")] (-lookup [this k] :extended)) [(get f :a) (satisfies? ILookup f)]"))))) +(deftest forked-native-protocol-extension-test + (let [parent (sci/init opts)] + (sci/eval-string* + parent + "(deftype ForkNative []) + (extend-type ForkNative ICounted (-count [_] 1)) + (def fork-native (->ForkNative))") + (let [child (sci/fork parent)] + (is (= 2 + (sci/eval-string* + child + "(extend-type ForkNative ICounted (-count [_] 2)) + (count fork-native)"))) + (is (= 1 (sci/eval-string* parent "(count fork-native)")))))) + +(deftest forked-record-native-protocol-extension-test + (let [parent (sci/init opts)] + (sci/eval-string* + parent + "(defrecord ForkNativeRecord []) + (extend-type ForkNativeRecord ICounted (-count [_] 1)) + (def fork-native-record (->ForkNativeRecord))") + (let [child (sci/fork parent)] + (is (= 2 + (sci/eval-string* + child + "(extend-type ForkNativeRecord ICounted (-count [_] 2)) + (count fork-native-record)"))) + (is (= 1 + (sci/eval-string* parent "(count fork-native-record)")))))) + (deftest extend-protocol-native-protocol-test (let [v (eval* " (deftype Foo [m]) From d31e31b7874c3001a0960802e4ff692f729b0a4f Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:30:55 -0700 Subject: [PATCH 15/31] Cache active fork world selectors --- doc/fork-state-audit.md | 11 +++++++++ src/sci/impl/analyzer.cljc | 15 +++++++------ src/sci/impl/execution.cljc | 32 ++++++++++++++++++++++++-- src/sci/impl/world.cljc | 45 +++++++++++++++++++++++++------------ 4 files changed, 80 insertions(+), 23 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 31b98691..ab77238d 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -242,6 +242,17 @@ move substantially with CPU power policy; the old and new implementations were measured together under the same policy, and these figures remain a local microbenchmark rather than a portable guarantee. +The execution state now also caches the selected world's stable cell-array +holder and lineage registry. Hot Var nodes and managed-ref reads therefore +avoid repeatedly walking `ReadWorld -> DenseWorld -> holder`; caching the +holder rather than the replaceable raw array remains correct when registration +grows a world. In alternating powersave-profile runs against the immediately +preceding checkpoint, three million interpreted child-world Var reads improved +from 182--187 ms to 133--150 ms (roughly 23 percent at the midpoint), while +five million direct child-world atom reads improved from 193--194 ms to +167--171 ms (roughly 13 percent). These ratios are local diagnostics, not a +cross-machine performance claim. + ### Delay Represent a delay as a handle to a world-local state machine: diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index 9a64b080..6e6c7bbc 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -13,6 +13,7 @@ [sci.ctx-store :as store] #?(:cljs [sci.impl.async-macro :as async-macro]) [sci.impl.deftype] + #?(:clj [sci.impl.execution :as execution]) [sci.impl.evaluator :as eval] [sci.impl.faster :as faster] [sci.impl.fns :as fns] @@ -60,14 +61,14 @@ ^int slot] sci.impl.types/Eval (eval [_ _ctx _bindings] - (let [^sci.impl.world.ReadWorld active - (world/active-world-state)] - (if (or (nil? active) (.-primary? active)) + (let [state (.get ^ThreadLocal execution/current) + ^clojure.lang.Volatile holder + (aget ^objects state execution/active-cells-holder-index) + ^java.util.concurrent.atomic.AtomicReferenceArray cells + (when holder (.deref holder))] + (if (nil? holder) (.getDirectRoot v) - (let [^sci.impl.world.DenseWorld world (.-world active) - ^java.util.concurrent.atomic.AtomicReferenceArray cells - @(.-cells-holder world)] - (.selectRoot v (.get cells slot)))))) + (.selectRoot v (.get cells slot))))) sci.impl.types/Stack (stack [_] nil))) diff --git a/src/sci/impl/execution.cljc b/src/sci/impl/execution.cljc index 82a174a5..0010967f 100644 --- a/src/sci/impl/execution.cljc +++ b/src/sci/impl/execution.cljc @@ -6,10 +6,12 @@ (def ^:const binding-scope-index 2) (def ^:const active-bindings-index 3) (def ^:const scope-bindings-index 4) +(def ^:const active-cells-holder-index 5) +(def ^:const active-registry-index 6) (defn- new-state [] - #?(:cljd (#/(List/filled dynamic) 5 nil) - :default (object-array 5))) + #?(:cljd (#/(List/filled dynamic) 7 nil) + :default (object-array 7))) #?(:clj (def ^ThreadLocal current @@ -59,6 +61,20 @@ :cljs (aget state scope-bindings-index)) {}))) +(defn active-cells-holder + ([] (active-cells-holder (current-state))) + ([state] + #?(:cljd (aget ^List state active-cells-holder-index) + :clj (aget ^objects state active-cells-holder-index) + :cljs (aget state active-cells-holder-index)))) + +(defn active-registry + ([] (active-registry (current-state))) + ([state] + #?(:cljd (aget ^List state active-registry-index) + :clj (aget ^objects state active-registry-index) + :cljs (aget state active-registry-index)))) + (defn set-active-world! [state value] #?(:cljd (aset ^List state active-world-index value) :clj (aset ^objects state active-world-index value) @@ -89,6 +105,18 @@ :cljs (aset state scope-bindings-index value)) value) +(defn set-active-cells-holder! [state value] + #?(:cljd (aset ^List state active-cells-holder-index value) + :clj (aset ^objects state active-cells-holder-index value) + :cljs (aset state active-cells-holder-index value)) + value) + +(defn set-active-registry! [state value] + #?(:cljd (aset ^List state active-registry-index value) + :clj (aset ^objects state active-registry-index value) + :cljs (aset state active-registry-index value)) + value) + (defn refresh-active-bindings! [state] (let [scope (binding-scope state) scopes (scope-bindings state) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 41199f64..1e9dac1a 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -90,19 +90,30 @@ (aget ^objects state execution/active-world-index)) :default (execution/active-world))) +(defn- install-active-world! [state active] + (execution/set-active-world! state active) + (if (and active (not (.-primary? ^ReadWorld active))) + (let [^DenseWorld world (.-world ^ReadWorld active)] + (execution/set-active-cells-holder! state (.-cells-holder world)) + (execution/set-active-registry! state (.-registry world))) + (do + (execution/set-active-cells-holder! state nil) + (execution/set-active-registry! state nil))) + active) + (defn- call-with-active-world [ctx f] (let [state #?(:clj (.get ^ThreadLocal execution/current) :default (execution/current-state)) previous (execution/active-world state) previous-scope (execution/binding-scope state) active (:sci.impl/read-world ctx)] - (execution/set-active-world! state active) + (install-active-world! state active) (execution/set-binding-scope! state (:sci.impl/world ctx)) (execution/refresh-active-bindings! state) (try (f) (finally - (execution/set-active-world! state previous) + (install-active-world! state previous) (execution/set-binding-scope! state previous-scope) (execution/refresh-active-bindings! state))))) @@ -182,10 +193,13 @@ (defn var-value-at "Read a Var through a slot already resolved by the analyzer." [slot fallback] - (let [^ReadWorld active (active-world-state)] - (if (or (nil? active) (.-primary? active)) - fallback - (slot-value (.-world active) slot fallback)))) + (if-let [holder (execution/active-cells-holder)] + (let [cells @holder] + (if (>= slot (cells-length cells)) + fallback + (let [v (cells-get cells slot)] + (if (identical? absent v) fallback v)))) + fallback)) (defn var-value "Primary contexts retain their direct Var realization. Descendants resolve @@ -332,13 +346,16 @@ "Read a self-described managed slot in the active related world, falling back to the owner's creation world outside managed evaluation." [home registry slot] - (let [selected (selected-managed-world home registry)] - (if (identical? selected home) - (slot-value selected slot absent) - (let [value (slot-value selected slot absent)] + (let [state (execution/current-state)] + (if (identical? registry (execution/active-registry state)) + (let [cells @(execution/active-cells-holder state) + value (if (>= slot (cells-length cells)) + absent + (cells-get cells slot))] (if (identical? value absent) (slot-value home slot absent) - value))))) + value)) + (slot-value home slot absent)))) (defn managed-value-in "Read a managed slot from an already selected world." @@ -380,7 +397,7 @@ old (if (identical? absent raw-old) (slot-value home slot absent) raw-old) - new (apply f old args) + new (if (nil? args) (f old) (apply f old args)) validation (validate! world new)] (if (cells-cas! cells slot raw-old new) (do (notify! world validation old new) new) @@ -628,13 +645,13 @@ :default (execution/current-state)) previous (execution/active-world state) previous-scope (execution/binding-scope state)] - (execution/set-active-world! state (ReadWorld. world false)) + (install-active-world! state (ReadWorld. world false)) (execution/set-binding-scope! state world) (execution/refresh-active-bindings! state) (try (f) (finally - (execution/set-active-world! state previous) + (install-active-world! state previous) (execution/set-binding-scope! state previous-scope) (execution/refresh-active-bindings! state))))) From 098aeffdf628d7fe09696238d9693f042b927dce Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:36:49 -0700 Subject: [PATCH 16/31] Reject affine host resources during forks --- doc/fork-state-audit.md | 18 ++++++--- doc/forking.md | 12 ++++-- src/sci/fork.cljc | 84 ++++++++++++++++++++++++++++++++--------- test/sci/core_test.cljc | 56 +++++++++++++++++++++++++++ 4 files changed, 143 insertions(+), 27 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index ab77238d..3ee3bd58 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -136,11 +136,11 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | SCI deftype instance fields | Directly stored instances implement `Forkable` and are shallow-copied with alias preservation | Implemented at the world-cell boundary; nested host state still requires cooperation | | `*loaded-libs*` | Built-in Var root has a per-cell copier for its host Ref/atom | Implemented; keeps the host representation while loaded sets diverge | | Delay | Stable SCI handle with world-local pending/realized state | Implemented; pending realizations split, while cached outcomes are inherited according to host delay semantics | -| Lazy sequence realization | One host lazy cell/cache | Shared and world selection during deferred realization is unreliable | +| Lazy sequence realization | One host lazy cell/cache | Direct world-cell values are rejected as affine; managed lazy continuations remain future work | | SCI `memoize` cache | Closure owns a fork-local `SciAtom` cache | Implemented; inherited entries are shared as immutable values and later cache fills diverge | | JVM Promise | Stable SCI handle with world-local pending/delivered state | Implemented; a pending child has no inherited waiters and delivery is branch-local | -| CLJS Promise | Native asynchronous host value | External async resource; managed continuations convey a world but the Promise itself is not copied | -| Future / async task | Work launched through the binding conveyor runs in its captured world; the host task itself remains shared | Not copyable; needs an explicit fork policy | +| CLJS Promise | Native asynchronous host value | Direct world-cell values are rejected as external; `:fork-fn` must choose deliberate sharing or application virtualization | +| Future / async task | Work launched through the binding conveyor runs in its captured world; a managed fork waits for it | A still-pending direct host Future is rejected; a completed Future may be shared as immutable task outcome state | | Transient collection | Detected as affine when directly stored in a world cell | Fork rejected by default; `:fork-fn` may impose an explicit application policy | | JVM array / CLJS JavaScript array | Shallow-copied once per source identity | Implemented for direct world-cell values; nested elements retain their own policy | | Host atom/ref/agent/volatile/native multimethod | Detected as unmanaged mutable state on JVM/CLJS | Fork rejected by default; `Forkable` wrapper or `:fork-fn` must choose copy or sharing | @@ -151,8 +151,8 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | | Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | | RNG, `gensym`, clock, UUID | Host/global nondeterministic source | External capability; not reproducibly forked | -| Readers, writers, streams, iterators, regex matchers | Mutable/consuming host resource | Affine or explicitly shared; never generically copied | -| Files, sockets, executors, locks | External host resource | Explicitly shared, virtualized, or prohibited | +| Readers, writers, streams, iterators, regex matchers | Mutable/consuming host resource | Known JVM direct values are rejected; explicitly share or virtualize with `Forkable`/`:fork-fn` | +| Files, sockets, executors, locks | External host resource | Known JVM direct values are rejected; explicitly share, virtualize, or prohibit application-specific wrappers | The table concerns state created or exposed by SCI itself. Application-owned containers remain responsible for their nested graph through @@ -301,6 +301,14 @@ future body runs. Fork policy can then choose among explicit sharing, waiting for completion and copying the result, restartable computation, cancellation, or rejection. Full continuation forking requires managed CPS/fiber state. +SCI's managed future conveyor now makes a world fork wait until the body has +released its evaluation permit. At the generic host-value boundary, a pending +`Future` is rejected while an already completed or cancelled Future is shared: +its task lifecycle can no longer diverge, although values reachable from its +result retain their ordinary shallow host policy. CLJS Promises cannot expose a +portable synchronous completion snapshot and are therefore rejected when +stored directly unless the application supplies a policy. + ### Multimethod Keep the MultiFn identity stable and move method/preference tables to world diff --git a/doc/forking.md b/doc/forking.md index 937236f6..396691d8 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -60,8 +60,10 @@ Only values directly stored in world cells are inspected. A host container that holds mutable children must implement the protocol and copy its own graph. Unclassified values retain the compatibility behavior of being shared, except for known affine or mutable host primitives that SCI can identify safely. -Direct host atoms, refs, agents, volatiles, multimethods, and transient -collections are rejected unless an explicit policy handles them. +Direct host atoms, refs, agents, volatiles, multimethods, transient +collections, lazy sequences, pending tasks, Promises, and known consuming or +external resources are rejected unless an explicit policy handles them. A +completed JVM Future may be shared because its task lifecycle is immutable. `sci/init` and the two-argument `sci/fork` also accept `:fork-fn`, a legacy one-argument fallback applied to unclassified values stored in world cells. It @@ -81,8 +83,10 @@ shallow-copied with alias preservation, so their mutable field maps diverge. On the JVM, SCI-created promises are fork-local as well. SCI's `memoize` uses a fork-local atom for its cache. Effects performed by any watch are ordinary user capabilities and are not made reversible automatically. Futures, lazy -sequences, nested mutable host objects, and effects outside SCI remain shared -unless the embedding application models or copies them. CLJS native-protocol +managed lazy continuations, nested mutable host objects, and effects outside +SCI remain future work unless the embedding application models or copies them. +Direct host lazy sequences are rejected rather than silently sharing their +realization cache. CLJS native-protocol prototypes are cloned with Type data before child deftype/record values are copied, so later child extensions do not change the parent's instances. A transient collection directly stored in diff --git a/src/sci/fork.cljc b/src/sci/fork.cljc index 811d3688..b34de223 100644 --- a/src/sci/fork.cljc +++ b/src/sci/fork.cljc @@ -27,28 +27,76 @@ ;; Portable concrete runtime types for these hosts still need auditing. :cljd false)) +(defn- affine-resource-kind [value] + #?(:clj + (cond + (instance? clojure.lang.LazySeq value) :lazy-seq + (instance? java.util.concurrent.Future value) + (when-not (.isDone ^java.util.concurrent.Future value) :pending-future) + (instance? java.io.Closeable value) :closeable + (instance? java.util.Iterator value) :iterator + (instance? java.util.Enumeration value) :enumeration + (instance? java.util.Spliterator value) :spliterator + (instance? java.util.regex.Matcher value) :regex-matcher + (instance? java.util.Random value) :random-generator + (instance? java.nio.Buffer value) :buffer + (instance? java.lang.Thread value) :thread + (instance? java.util.concurrent.Executor value) :executor + (instance? java.util.concurrent.locks.Lock value) :lock + (instance? java.lang.StringBuilder value) :string-builder + (instance? java.lang.StringBuffer value) :string-buffer + (instance? java.util.BitSet value) :bit-set + (instance? java.util.Date value) :date + (instance? java.util.Calendar value) :calendar + (instance? java.util.concurrent.atomic.AtomicReference value) :atomic-reference + (instance? java.util.concurrent.atomic.AtomicBoolean value) :atomic-boolean + (instance? java.util.concurrent.atomic.AtomicInteger value) :atomic-integer + (instance? java.util.concurrent.atomic.AtomicLong value) :atomic-long + :else nil) + :cljs + (cond + (instance? cljs.core/LazySeq value) :lazy-seq + (instance? js/Promise value) :promise + (instance? js/Date value) :date + (instance? js/Map value) :map + (instance? js/Set value) :set + (instance? js/WeakMap value) :weak-map + (instance? js/WeakSet value) :weak-set + (instance? js/RegExp value) :regexp + (instance? js/ArrayBuffer value) :array-buffer + :else nil) + :cljd nil)) + (defn- default-fork-value [value] - (cond - (transient-value? value) - (throw (ex-info - "Cannot fork a SCI world containing an affine transient collection. Provide :fork-fn to define an explicit policy." - {:type ::affine-resource - :resource value})) + (let [affine-kind (affine-resource-kind value)] + (cond + (transient-value? value) + (throw (ex-info + "Cannot fork a SCI world containing an affine transient collection. Provide :fork-fn to define an explicit policy." + {:type ::affine-resource + :resource value})) + + (unmanaged-mutable-value? value) + (throw (ex-info + "Cannot fork a SCI world containing an unmanaged mutable host value. Implement Forkable or provide :fork-fn to define an explicit policy." + {:type ::unmanaged-mutable-value + :resource value})) - (unmanaged-mutable-value? value) - (throw (ex-info - "Cannot fork a SCI world containing an unmanaged mutable host value. Implement Forkable or provide :fork-fn to define an explicit policy." - {:type ::unmanaged-mutable-value - :resource value})) + affine-kind + (throw (ex-info + (str "Cannot fork a SCI world containing an affine or external host resource (" (name affine-kind) "). Implement Forkable or provide :fork-fn to define an explicit policy.") + {:type ::affine-resource + :resource-kind affine-kind + :resource value})) - #?(:clj (and (some? value) (.isArray ^Class (class value))) - :cljs (array? value) - :cljd false) - #?(:clj (aclone value) - :cljs (.slice value) - :cljd value) + #?(:clj (and (some? value) (.isArray ^Class (class value))) + :cljs (array? value) + :cljd false) + #?(:clj (aclone value) + :cljs (.slice value) + :cljd value) - :else value)) + :else value))) #?(:clj (defn- memoized-forker [fallback] diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 1ae14557..8e4ad967 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1718,6 +1718,62 @@ (swap! host-state inc)]"))) (is (= 0 @host-state)))))) +#?(:clj + (deftest affine-host-resource-fork-policy-test + (testing "lazy realization is rejected" + (let [parent (sci/init nil)] + (sci/eval-string* parent "(def pending-xs (map inc [1 2 3]))") + (try + (sci/fork parent) + (is false "expected lazy sequence rejection") + (catch clojure.lang.ExceptionInfo e + (is (= :lazy-seq (:resource-kind (ex-data e)))))))) + (testing "pending tasks and consuming resources are rejected" + (doseq [[resource expected-kind] + [[(java.util.concurrent.FutureTask. (fn [] :done)) + :pending-future] + [(java.io.StringReader. "input") :closeable] + [(java.util.Random. 42) :random-generator]]] + (let [user-ns (sci/create-ns 'user) + parent (sci/init + {:namespaces + {'user {'resource + (sci/new-var 'resource resource + {:ns user-ns})}}})] + (try + (sci/fork parent) + (is false (str "expected " expected-kind " rejection")) + (catch clojure.lang.ExceptionInfo e + (is (= expected-kind + (:resource-kind (ex-data e))))))))) + (testing "a completed Future has immutable task state and may be shared" + (let [task (java.util.concurrent.FutureTask. (fn [] :done)) + _ (.run task) + user-ns (sci/create-ns 'user) + parent (sci/init + {:namespaces + {'user {'task (sci/new-var 'task task {:ns user-ns})}}}) + child (sci/fork parent)] + (is (identical? task (sci/eval-string* child "task"))) + (is (= :done @task)))))) + +#?(:cljs + (deftest affine-js-resource-fork-policy-test + (let [promise (js/Promise.resolve 1) + user-ns (sci/create-ns 'user) + parent (sci/init + {:namespaces + {'user {'promise + (sci/new-var 'promise promise {:ns user-ns})}}})] + (try + (sci/fork parent) + (is false "expected Promise rejection") + (catch ExceptionInfo e + (is (= :promise (:resource-kind (ex-data e)))))) + (is (identical? promise + (sci/eval-string* + (sci/fork parent {:fork-fn identity}) "promise")))))) + #?(:clj (deftest fork-host-value-cooperation-test (let [user-ns (sci/create-ns 'user) From 1eac92a40051ba1a57487defa12fe8685ce1c1ea Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:48:16 -0700 Subject: [PATCH 17/31] Manage mutable deftype fields across forks --- doc/fork-state-audit.md | 21 +++++++-- doc/forking.md | 12 ++--- src/sci/impl/deftype.cljc | 53 +++++++++++++++++------ src/sci/impl/opts.cljc | 3 +- src/sci/impl/world.cljc | 27 ++++++++---- test/sci/defrecords_and_deftype_test.cljc | 23 +++++++++- 6 files changed, 106 insertions(+), 33 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 3ee3bd58..1bd7d4b5 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -133,7 +133,7 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Var watches | Optional dense world-local slot on a stable Var handle | Implemented; callbacks are inherited but their external effects remain capabilities | | Namespace metadata | Stable Namespace handle with a dense world-local metadata slot | Implemented | | Type descriptor data | Stable Type handle with one dense world-local data slot | Implemented; CLJS native prototypes are cloned before child values are copied | -| SCI deftype instance fields | Directly stored instances implement `Forkable` and are shallow-copied with alias preservation | Implemented at the world-cell boundary; nested host state still requires cooperation | +| SCI mutable deftype fields | Stable instance handle with one managed persistent field-map slot | Implemented across closures/containers; CLJS direct roots may also be copied onto the child native-protocol prototype | | `*loaded-libs*` | Built-in Var root has a per-cell copier for its host Ref/atom | Implemented; keeps the host representation while loaded sets diverge | | Delay | Stable SCI handle with world-local pending/realized state | Implemented; pending realizations split, while cached outcomes are inherited according to host delay semantics | | Lazy sequence realization | One host lazy cell/cache | Direct world-cell values are rejected as affine; managed lazy continuations remain future work | @@ -350,9 +350,22 @@ Directly stored host transients are now rejected by the default value forker. Supplying `:fork-fn` is an explicit override and can deliberately share or replace them. The check remains shallow, like all host cooperation: a transient hidden inside an unclassified host container is that container's -responsibility. Directly stored standard `SciType` deftype instances implement -`Forkable`; their field map is shallow-copied once per source identity, so -aliases remain aliases in the child and later field replacements diverge. +responsibility. + +Instances of a type that declares `^:volatile-mutable` or +`^:unsynchronized-mutable` fields allocate one managed persistent field-map +slot. This makes field replacements branch-local even when the stable instance +is captured inside an opaque SCI closure or nested persistent container. Types +with immutable fields retain direct field maps and pay no managed-read cost; +mutable values nested inside those fields remain the embedding application's +responsibility. + +In alternating powersave-profile child-world benchmarks, one million mutable +field reads were roughly 10--22 percent slower than the earlier direct copied +map, and 200,000 writes roughly 22--27 percent slower after adding a dedicated +managed-assoc path. The cost is restricted to types that opt into mutable +fields; the representation fixes a state leak that root-only copying could not +address. ## Recommended implementation order diff --git a/doc/forking.md b/doc/forking.md index 396691d8..00170033 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -78,13 +78,15 @@ Var roots, metadata, and watch maps; namespace metadata and loaded-library state; all logical SCI atom state; SCI-created volatile values and delays; SCI type descriptor data; and JVM/CLJS SCI multimethod tables, preferences, and dispatch caches are fork-local. ClojureDart's exact-dispatch SCI multimethod -tables are fork-local as well. Directly stored SCI deftype instances are -shallow-copied with alias preservation, so their mutable field maps diverge. +tables are fork-local as well. SCI deftypes that declare mutable fields route +their persistent field map through a managed world slot, so state diverges +even when an instance is captured by a closure or nested in a persistent +container. Immutable-field types retain direct storage. On the JVM, SCI-created promises are fork-local as well. SCI's `memoize` uses a fork-local atom for its cache. Effects performed by any watch are ordinary user -capabilities and are not made reversible automatically. Futures, lazy -managed lazy continuations, nested mutable host objects, and effects outside -SCI remain future work unless the embedding application models or copies them. +capabilities and are not made reversible automatically. Managed lazy +continuations, nested mutable host objects, and effects outside SCI remain +future work unless the embedding application models or copies them. Direct host lazy sequences are rejected rather than silently sharing their realization cache. CLJS native-protocol prototypes are cloned with Type data before child deftype/record values are diff --git a/src/sci/impl/deftype.cljc b/src/sci/impl/deftype.cljc index b3f74a4c..15ab66cf 100644 --- a/src/sci/impl/deftype.cljc +++ b/src/sci/impl/deftype.cljc @@ -8,6 +8,7 @@ [sci.impl.types :as types] [sci.impl.utils :as utils] [sci.impl.vars :as vars] + [sci.impl.world :as world] [sci.lang :as lang])) #?(:cljd nil :clj (set! *warn-on-reflection* true)) @@ -68,7 +69,8 @@ type type-meta #?(:cljd ^:mutable ext-map :clj ^:volatile-mutable ext-map - :cljs ^:mutable ext-map)] + :cljs ^:mutable ext-map) + home registry value-slot] Object (toString [this] (to-string this)) @@ -81,14 +83,18 @@ sci.impl.types/SciTypeInstance (-get-type [_] type) - (-mutate [_ k v] - (set! ext-map (assoc ext-map k v)) + (-mutate [this k v] + (if home + (world/managed-assoc! home registry value-slot k v) + (set! ext-map (assoc ext-map k v))) v) fork/Forkable (fork-value [this] #?(:cljs (fork-sci-type this) - :default (SciType. rec-name type type-meta ext-map))) + :default (if home + this + (SciType. rec-name type type-meta ext-map nil nil nil)))) #?@(:cljd [IFn (-invoke [this] (types/sci-invoke this)) @@ -184,7 +190,10 @@ (types/sci-invoke this a b c d e f g h i j k l m n o p q r s t))]) types/IBox - (getVal [_] ext-map) + (getVal [_] + (if home + (world/managed-value home registry value-slot) + ext-map)) #?@(:cljd [types/ICustomType] :clj [sci.impl.types.ICustomType] @@ -192,7 +201,7 @@ (getMethods [_] nil) (getInterfaces [_] nil) (getProtocols [_] nil) - (getFields [_] ext-map)) + (getFields [this] (types/getVal this))) #?(:cljs (defn fork-sci-type [^SciType this] @@ -203,7 +212,8 @@ obj (js/Object.create proto)] (.call SciType obj (.-rec-name this) type (.-type-meta this) - (types/getVal this)) + (.-ext-map this) (.-home this) (.-registry this) + (.-value-slot this)) obj))) #?(:cljs @@ -293,14 +303,29 @@ [t proto-map impls] (-install-native-protocol-on! (ensure-js-prototype t) proto-map impls))) +(defn- mutable-type? [type] + (and (utils/sci-type? type) + (some (fn [field] + (let [m (meta field)] + (or (:volatile-mutable m) + (:unsynchronized-mutable m)))) + (:sci.impl/fields (types/getVal type))))) + (defn ->type-impl [rec-name type type-meta m] - #?(:cljs (if-let [proto (when (instance? lang/Type type) - (:sci.impl/js-prototype (types/getVal type)))] - (let [obj (js/Object.create proto)] - (.call SciType obj rec-name type type-meta m) - obj) - (SciType. rec-name type type-meta m)) - :default (SciType. rec-name type type-meta m))) + (let [desc (when (mutable-type? type) + (world/register-managed! :deftype-fields [m] [])) + home (:home desc) + registry (:registry desc) + value-slot (some-> desc :slots first)] + #?(:cljs (if-let [proto (when (instance? lang/Type type) + (:sci.impl/js-prototype (types/getVal type)))] + (let [obj (js/Object.create proto)] + (.call SciType obj rec-name type type-meta m + home registry value-slot) + obj) + (SciType. rec-name type type-meta m home registry value-slot)) + :default (SciType. rec-name type type-meta m + home registry value-slot)))) #?(:cljs (defmethod types/sci-pr-writer :default [this w opts] diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index 00e2fa50..2c76fbe1 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -3,6 +3,7 @@ (:require #?(:cljs [goog.string]) [sci.ctx-store :as store] + [sci.impl.deftype :as deftype] [sci.impl.namespaces :as namespaces] [sci.impl.types :as types] [sci.impl.utils :as utils :refer [strip-core-ns]] @@ -26,7 +27,7 @@ :when (utils/sci-type? t)] (world/register-type! t (types/getVal t) - #?(:cljs sci.impl.deftype/fork-type-data :default nil))) + #?(:cljs deftype/fork-type-data :default nil))) (doseq [[_ ns-map] (:namespaces @(:env ctx)) [_ v] ns-map :when (and (utils/var? v) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 1e9dac1a..9057dbcc 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -334,14 +334,6 @@ :when (< slot (cells-length cells))] (cells-set! cells slot absent)))) -(defn- selected-managed-world [^DenseWorld home registry] - (let [active (active-world-state)] - (if (and active - (identical? registry - (.-registry ^DenseWorld (.-world ^ReadWorld active)))) - (.-world ^ReadWorld active) - home))) - (defn managed-value "Read a self-described managed slot in the active related world, falling back to the owner's creation world outside managed evaluation." @@ -407,6 +399,25 @@ (managed-swap! home registry slot (constantly new) nil validate! notify!)) +(defn managed-assoc! + "Associate one key in a managed persistent-map slot without the generic + callback/validation path. Used by mutable SCI deftype fields." + [home registry slot k value] + (call-with-managed-mutation + home registry + (fn [^DenseWorld world] + (ensure-capacity! world (inc slot)) + (loop [] + (let [cells (current-cells world) + raw-old (cells-get cells slot) + old (if (identical? absent raw-old) + (slot-value home slot {}) + raw-old) + new (assoc old k value)] + (if (cells-cas! cells slot raw-old new) + value + (recur))))))) + (defn managed-compare-and-set! [home registry slot expected new validate! notify!] (call-with-managed-mutation diff --git a/test/sci/defrecords_and_deftype_test.cljc b/test/sci/defrecords_and_deftype_test.cljc index f37e49b9..d2c7066a 100644 --- a/test/sci/defrecords_and_deftype_test.cljc +++ b/test/sci/defrecords_and_deftype_test.cljc @@ -293,11 +293,32 @@ (let [parent-box (sci/eval-string* parent "box") child (sci/fork parent) child-box (sci/eval-string* child "box")] - (is (not (identical? parent-box child-box))) + ;; CLJS instances must move to the child Type's cloned native-protocol + ;; prototype. JVM/CLJD can retain the stable managed handle itself. + (is (#?(:cljs not :default identity) + (identical? parent-box child-box))) (is (true? (sci/eval-string* child "(identical? box box-alias)"))) (is (= 2 (sci/eval-string* child "(box-value (bump! box))"))) (is (= 1 (sci/eval-string* parent "(box-value box)")))))) +(deftest forked-captured-deftype-state-test + (let [parent (sci/init nil)] + (sci/eval-string* + parent + "(defprotocol ICapturedForkBox (captured-bump! [_])) + (deftype CapturedForkBox [^:volatile-mutable value] + ICapturedForkBox + (captured-bump! [this] + (set! value (inc value)) + value)) + (def captured-bump + (let [box (->CapturedForkBox 0)] + (fn [] (captured-bump! box))))") + (let [child (sci/fork parent)] + (is (= [1 2] + (sci/eval-string* child "[(captured-bump) (captured-bump)]"))) + (is (= 1 (sci/eval-string* parent "(captured-bump)")))))) + (deftest forked-type-metadata-test (let [parent (sci/init nil)] (sci/eval-string* From 25cb294aa5789a47247c5dc30fdcf294b1df388b Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:52:58 -0700 Subject: [PATCH 18/31] Right-size forked world snapshots --- doc/fork-state-audit.md | 7 +++++++ doc/forking.md | 5 +++-- src/sci/impl/world.cljc | 12 ++++++------ 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 1bd7d4b5..476cd8a8 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -253,6 +253,13 @@ five million direct child-world atom reads improved from 193--194 ms to 167--171 ms (roughly 13 percent). These ratios are local diagnostics, not a cross-machine performance claim. +Fork copying uses the registry's logical `:next-slot` bound rather than the +backing array's exponential-growth capacity. In alternating powersave-profile +runs with 16,385 logical slots in a 32,768-cell source array, 101-fork medians +were 1.91 ms versus 2.46--2.83 ms before right-sizing (about 22--32 percent +faster). The benefit approaches zero when capacity is already tightly packed; +it adds no read or mutation indirection. + ### Delay Represent a delay as a handle to a world-local state machine: diff --git a/doc/forking.md b/doc/forking.md index 00170033..656258f6 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -128,8 +128,9 @@ shared wake-up monitor is only a scheduling signal: a waiter always rechecks the state of its own world. Host code that tests for the concrete host delay or promise class can observe these representation differences. -Forking is O(number of allocated slots), including spare array capacity, while -slot reads and writes are constant time. This intentionally favors the common +Forking is O(the lineage's allocated logical slots); unused backing-array +capacity is not copied. Slot reads and writes are constant time. This +intentionally favors the common case where reads and mutations greatly outnumber forks. A page-level copy-on-write representation remains a possible next step if workloads with large worlds and frequent forks justify its extra read/write indirection. diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index 9057dbcc..bde3fdb2 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -669,10 +669,10 @@ (defn- copy-world [^DenseWorld world fork-value] (sweep-managed! world) (let [source (current-cells world) - n (cells-length source) - target (new-cells n) registry (.-registry world) registry-state @registry + logical-n (:next-slot registry-state) + target (new-cells (max 16 logical-n)) descriptors (:descriptors registry-state) managed-descriptors (:managed-descriptors registry-state) handles (set (keys descriptors)) @@ -681,14 +681,14 @@ registry #?(:clj (ReentrantReadWriteLock.) :default nil) (volatile! true))] - (dotimes [i n] + (dotimes [i logical-n] (cells-set! target i (cells-get source i))) (when fork-value ;; Per-cell copiers establish target-local type/control realizations ;; before general Forkable values inspect the child world. (doseq [[_ {:keys [value-slot value-fork-fn]}] descriptors :when value-fork-fn - :when (< value-slot n) + :when (< value-slot logical-n) :let [v (cells-get target value-slot)] :when (not (identical? absent v))] (cells-set! target value-slot (value-fork-fn v))) @@ -698,14 +698,14 @@ (doseq [[_ {:keys [value-slot host-fork? value-fork-fn]}] descriptors :when (and host-fork? (nil? value-fork-fn)) - :when (< value-slot n) + :when (< value-slot logical-n) :let [v (cells-get target value-slot)] :when (not (identical? absent v))] (cells-set! target value-slot (if (contains? handles v) v (fork-value v)))) (doseq [{:keys [fork-slots]} managed-descriptors slot fork-slots - :when (< slot n) + :when (< slot logical-n) :let [v (cells-get target slot)] :when (not (identical? absent v))] (cells-set! target slot (fork-value v)))))) From 6020aacb16e856ffaf3a2b88dc90b67a59a30ea1 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 06:55:31 -0700 Subject: [PATCH 19/31] Classify additional mutable host resources --- doc/fork-state-audit.md | 4 ++-- doc/forking.md | 4 +++- src/sci/fork.cljc | 24 ++++++++++++++++++++++++ test/sci/core_test.cljc | 4 +++- 4 files changed, 32 insertions(+), 4 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 476cd8a8..60ead776 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -143,7 +143,7 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Future / async task | Work launched through the binding conveyor runs in its captured world; a managed fork waits for it | A still-pending direct host Future is rejected; a completed Future may be shared as immutable task outcome state | | Transient collection | Detected as affine when directly stored in a world cell | Fork rejected by default; `:fork-fn` may impose an explicit application policy | | JVM array / CLJS JavaScript array | Shallow-copied once per source identity | Implemented for direct world-cell values; nested elements retain their own policy | -| Host atom/ref/agent/volatile/native multimethod | Detected as unmanaged mutable state on JVM/CLJS | Fork rejected by default; `Forkable` wrapper or `:fork-fn` must choose copy or sharing | +| Host atom/ref/agent/volatile/native multimethod, common JVM atomic/synchronization holders | Detected as unmanaged mutable or affine host state | Fork rejected by default; `Forkable` wrapper or `:fork-fn` must choose copy or sharing | | Plain JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | | JVM/CLJS SCI multimethod tables, preferences, and caches | Stable `SciMultiFn` handle with a fork-local host dispatch engine | Implemented; method mutations use copy-on-write and caches are rebuilt per fork | | ClojureDart SCI multimethod tables | Stable `SciMultiFn` with a dense world-local persistent method map | Implemented for interpreter-created exact-dispatch multimethods; built-in runtime tables remain global | @@ -151,7 +151,7 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | | Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | | RNG, `gensym`, clock, UUID | Host/global nondeterministic source | External capability; not reproducibly forked | -| Readers, writers, streams, iterators, regex matchers | Mutable/consuming host resource | Known JVM direct values are rejected; explicitly share or virtualize with `Forkable`/`:fork-fn` | +| Readers, writers, streams, iterators, regex matchers, mutable Java collections | Mutable/consuming host resource | Known JVM direct values are rejected; explicitly share or virtualize with `Forkable`/`:fork-fn` | | Files, sockets, executors, locks | External host resource | Known JVM direct values are rejected; explicitly share, virtualize, or prohibit application-specific wrappers | The table concerns state created or exposed by SCI itself. Application-owned diff --git a/doc/forking.md b/doc/forking.md index 656258f6..993c7848 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -63,7 +63,9 @@ for known affine or mutable host primitives that SCI can identify safely. Direct host atoms, refs, agents, volatiles, multimethods, transient collections, lazy sequences, pending tasks, Promises, and known consuming or external resources are rejected unless an explicit policy handles them. A -completed JVM Future may be shared because its task lifecycle is immutable. +completed JVM Future or realized host Delay may be shared because its lifecycle +is immutable. Mutable Java collections and common atomic/synchronization +holders are rejected as well; Clojure persistent collections are unaffected. `sci/init` and the two-argument `sci/fork` also accept `:fork-fn`, a legacy one-argument fallback applied to unclassified values stored in world cells. It diff --git a/src/sci/fork.cljc b/src/sci/fork.cljc index b34de223..529bd9e7 100644 --- a/src/sci/fork.cljc +++ b/src/sci/fork.cljc @@ -31,9 +31,12 @@ #?(:clj (cond (instance? clojure.lang.LazySeq value) :lazy-seq + (instance? clojure.lang.Delay value) + (when-not (realized? value) :pending-delay) (instance? java.util.concurrent.Future value) (when-not (.isDone ^java.util.concurrent.Future value) :pending-future) (instance? java.io.Closeable value) :closeable + (instance? java.lang.AutoCloseable value) :auto-closeable (instance? java.util.Iterator value) :iterator (instance? java.util.Enumeration value) :enumeration (instance? java.util.Spliterator value) :spliterator @@ -41,8 +44,14 @@ (instance? java.util.Random value) :random-generator (instance? java.nio.Buffer value) :buffer (instance? java.lang.Thread value) :thread + (instance? java.lang.ThreadLocal value) :thread-local + (instance? java.lang.Process value) :process (instance? java.util.concurrent.Executor value) :executor (instance? java.util.concurrent.locks.Lock value) :lock + (instance? java.util.concurrent.CountDownLatch value) :count-down-latch + (instance? java.util.concurrent.Semaphore value) :semaphore + (instance? java.util.concurrent.Phaser value) :phaser + (instance? java.util.concurrent.CyclicBarrier value) :cyclic-barrier (instance? java.lang.StringBuilder value) :string-builder (instance? java.lang.StringBuffer value) :string-buffer (instance? java.util.BitSet value) :bit-set @@ -52,10 +61,25 @@ (instance? java.util.concurrent.atomic.AtomicBoolean value) :atomic-boolean (instance? java.util.concurrent.atomic.AtomicInteger value) :atomic-integer (instance? java.util.concurrent.atomic.AtomicLong value) :atomic-long + (instance? java.util.concurrent.atomic.AtomicReferenceArray value) :atomic-reference-array + (instance? java.util.concurrent.atomic.AtomicIntegerArray value) :atomic-integer-array + (instance? java.util.concurrent.atomic.AtomicLongArray value) :atomic-long-array + (instance? java.util.concurrent.atomic.AtomicMarkableReference value) :atomic-markable-reference + (instance? java.util.concurrent.atomic.AtomicStampedReference value) :atomic-stamped-reference + (instance? java.util.concurrent.atomic.LongAdder value) :long-adder + (instance? java.util.concurrent.atomic.DoubleAdder value) :double-adder + (and (instance? java.util.Map value) + (not (instance? clojure.lang.IPersistentCollection value))) + :java-map + (and (instance? java.util.Collection value) + (not (instance? clojure.lang.IPersistentCollection value))) + :java-collection :else nil) :cljs (cond (instance? cljs.core/LazySeq value) :lazy-seq + (instance? cljs.core/Delay value) + (when-not (realized? value) :pending-delay) (instance? js/Promise value) :promise (instance? js/Date value) :date (instance? js/Map value) :map diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 8e4ad967..77dc1e5f 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1732,8 +1732,10 @@ (doseq [[resource expected-kind] [[(java.util.concurrent.FutureTask. (fn [] :done)) :pending-future] + [(delay :done) :pending-delay] [(java.io.StringReader. "input") :closeable] - [(java.util.Random. 42) :random-generator]]] + [(java.util.Random. 42) :random-generator] + [(java.util.ArrayList.) :java-collection]]] (let [user-ns (sci/create-ns 'user) parent (sci/init {:namespaces From 548ed89fa93fdd2c53ab1e66e00b31f5967794f8 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 07:05:58 -0700 Subject: [PATCH 20/31] Track mutable deftype liveness and boundaries --- doc/fork-state-audit.md | 39 ++++++++++++++++++++++++++++++++++++++- doc/forking.md | 7 +++++++ src/sci/impl/deftype.cljc | 27 +++++++++++++++++---------- 3 files changed, 62 insertions(+), 11 deletions(-) diff --git a/doc/fork-state-audit.md b/doc/fork-state-audit.md index 60ead776..ea5d5b02 100644 --- a/doc/fork-state-audit.md +++ b/doc/fork-state-audit.md @@ -147,7 +147,7 @@ child-only dynamic metadata cannot affect a nested parent evaluation. | Plain JS object / mutable host collection | Same host object | Shared unless it implements `Forkable` or `:fork-fn` copies it | | JVM/CLJS SCI multimethod tables, preferences, and caches | Stable `SciMultiFn` handle with a fork-local host dispatch engine | Implemented; method mutations use copy-on-write and caches are rebuilt per fork | | ClojureDart SCI multimethod tables | Stable `SciMultiFn` with a dense world-local persistent method map | Implemented for interpreter-created exact-dispatch multimethods; built-in runtime tables remain global | -| SCI protocol extension registries | Protocol Vars and method multimethods are world-local | Implemented; CLJS native-protocol prototype mutations use each world's Type data and copied instances | +| SCI protocol extension registries | Protocol Vars and method multimethods are world-local | Implemented; CLJS native prototypes isolate copied world-cell instances, while opaque closure-only instances retain their creation prototype | | Record hash caches | Shared memoized hash only | Benign derived state if records remain immutable | | Watches with external effects | Shared callback registrations | Must be copied, shared, or prohibited explicitly by capability | | RNG, `gensym`, clock, UUID | Host/global nondeterministic source | External capability; not reproducibly forked | @@ -374,6 +374,43 @@ managed-assoc path. The cost is restricted to types that opt into mutable fields; the representation fixes a state leak that root-only copying could not address. +### Opaque closure and container boundary + +SCI closures can safely capture Vars, SCI refs, delays, promises, +multimethods, and mutable SCI deftype instances because those are stable +handles whose logical state selects the active world. SCI does not reflectively +traverse arbitrary host closure fields or persistent-container contents during +a fork. A mutable host value captured there must therefore be represented by a +`Forkable` application handle before capture; a fallback can only transform +values that are themselves visible in world cells. + +CLJS adds one prototype-specific limitation. A deftype/record instance stored +directly in a world cell is rebuilt on the child Type's cloned prototype, but +an instance reachable only through an opaque closure retains its creation +prototype. Its managed mutable fields remain fork-local, but a native-protocol +extension installed only after the fork is not retroactively visible through +that captured instance. Fully solving this requires a managed closure/fiber +environment or world-routed native protocol dispatch, not a deeper generic +object copy. + +## Longer-term definition identity + +Unison's useful lesson here is architectural separation, not replacing the +dense runtime with content addressing. A later layer can distinguish: + +- a Var/name handle and its world-local definition tip; +- an immutable, canonical `DefId` for analyzed code; +- a namespace-state hash from a causal revision/history hash; and +- opaque execution-world identity and mutable/external capabilities. + +Ordinary SCI should retain Clojure's late Var binding. Pinned `DefId` calls can +be an explicit mode, or the native semantics of lambda-join/Simmis. `hasch` +would be useful for versioned hashes of canonical immutable analyzed forms, +dependency DAGs, and namespace revisions; it should not hash dense cell arrays, +mutable references, resources, or arbitrary host values. That layer can be +added after runtime forking without putting hashes or definition lookups on the +hot Var-dereference path. + ## Recommended implementation order 1. Preserve the corrected asynchronous world conveyance and extend it to any diff --git a/doc/forking.md b/doc/forking.md index 993c7848..450e5e5f 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -74,6 +74,13 @@ The per-fork identity memo applies to protocol, callback, and built-in copying, so identical direct cell values are transformed once and remain aliases in the child. +SCI-owned stable handles remain world-selecting when captured by interpreted +closures, including mutable SCI deftype instances. Arbitrary mutable host +values hidden in a host closure or container are not reflectively discovered; +wrap them in a `Forkable` handle before capture. On CLJS, an instance visible +only through an opaque closure also retains its creation native-protocol +prototype, although its managed mutable fields remain fork-local. + ## Current boundary Var roots, metadata, and watch maps; namespace metadata and loaded-library diff --git a/src/sci/impl/deftype.cljc b/src/sci/impl/deftype.cljc index 15ab66cf..aa54b38c 100644 --- a/src/sci/impl/deftype.cljc +++ b/src/sci/impl/deftype.cljc @@ -316,16 +316,23 @@ (world/register-managed! :deftype-fields [m] [])) home (:home desc) registry (:registry desc) - value-slot (some-> desc :slots first)] - #?(:cljs (if-let [proto (when (instance? lang/Type type) - (:sci.impl/js-prototype (types/getVal type)))] - (let [obj (js/Object.create proto)] - (.call SciType obj rec-name type type-meta m - home registry value-slot) - obj) - (SciType. rec-name type type-meta m home registry value-slot)) - :default (SciType. rec-name type type-meta m - home registry value-slot)))) + value-slot (some-> desc :slots first) + obj #?(:cljs (if-let [proto (when (instance? lang/Type type) + (:sci.impl/js-prototype + (types/getVal type)))] + (let [obj (js/Object.create proto)] + (.call SciType obj rec-name type type-meta m + home registry value-slot) + obj) + (SciType. rec-name type type-meta m + home registry value-slot)) + :default (SciType. rec-name type type-meta m + home registry value-slot))] + #?(:clj (if desc + (world/attach-managed-owner! + registry (:managed-index desc) obj) + obj) + :default obj))) #?(:cljs (defmethod types/sci-pr-writer :default [this w opts] From 622162421f6b73b0c858ae08ce62a1f0f3a0ad56 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 10:53:00 -0700 Subject: [PATCH 21/31] Add interactive forked REPL tree demo --- README.md | 3 + examples/sci/examples/forked_repl.clj | 136 ++++++++++++++++++++++++++ 2 files changed, 139 insertions(+) create mode 100644 examples/sci/examples/forked_repl.clj diff --git a/README.md b/README.md index f89f75a4..a131d7c5 100644 --- a/README.md +++ b/README.md @@ -627,6 +627,9 @@ source world, so the copied state is a quiescent snapshot. See [Forkable SCI worlds](doc/forking.md) for the lifecycle, semantic boundary, and current limitations of this experimental model. +A small interactive tree of forked REPL worlds can be run with +`clojure -M:examples -m sci.examples.forked-repl`. + ### Implementing require and load-file SCI supports loading code via a hook that is invoked by SCI's implementation of diff --git a/examples/sci/examples/forked_repl.clj b/examples/sci/examples/forked_repl.clj new file mode 100644 index 00000000..bf186db2 --- /dev/null +++ b/examples/sci/examples/forked_repl.clj @@ -0,0 +1,136 @@ +(ns sci.examples.forked-repl + (:require + [clojure.string :as str] + [sci.core :as sci])) + +(def bootstrap + "(do + (def ^:dynamic *scenario* :root) + (def model (atom {:revision 0 :decisions []})) + (defn snapshot [] + (assoc @model :scenario *scenario*)) + (defn evolve! [decision] + (swap! model + (fn [state] + (-> state + (update :revision inc) + (update :decisions conj + {:scenario *scenario* + :decision decision})))) + (snapshot)))") + +(def help + "Commands: + :fork NAME fork the selected world and select its child + :use ID select an existing world + :tree show the branch tree and each world's state + :help show this help + :quit exit + +Any other line is evaluated in the selected SCI world. Try: + (evolve! :hire-now)") + +(defn- state-of [ctx] + (try + (sci/eval-string* ctx "(snapshot)") + (catch Throwable e + (str "")))) + +(defn- child-ids [nodes id] + (->> nodes + (keep (fn [[child-id node]] + (when (= id (:parent node)) child-id))) + sort)) + +(defn- print-subtree [nodes selected id prefix last? root?] + (let [{:keys [label ctx]} (get nodes id) + connector (if root? "" (if last? "└─ " "├─ ")) + marker (if (= id selected) "*" " ")] + (println (str prefix connector marker " " id " " label " " + (pr-str (state-of ctx)))) + (let [children (child-ids nodes id) + child-prefix (str prefix + (if root? + "" + (if last? " " "│ ")))] + (doseq [[index child-id] (map-indexed vector children)] + (print-subtree nodes selected child-id child-prefix + (= index (dec (count children))) false))))) + +(defn- print-tree [nodes selected] + (println) + (print-subtree nodes selected 0 "" true true) + (println)) + +(defn- parse-id [s] + (try + (Long/parseLong s) + (catch NumberFormatException _ nil))) + +(defn- fork-selected! [nodes selected next-id label] + (let [parent-id @selected + child-id @next-id + parent-ctx (get-in @nodes [parent-id :ctx]) + child-ctx (sci/fork parent-ctx) + label (if (str/blank? label) + (str "branch-" child-id) + label) + scenario (keyword (str/replace label #"\s+" "-"))] + (sci/eval-string* + child-ctx + (str "(alter-var-root #'*scenario* (constantly " + (pr-str scenario) "))")) + (swap! nodes assoc child-id {:id child-id + :label label + :parent parent-id + :ctx child-ctx}) + (swap! next-id inc) + (reset! selected child-id) + (println "forked" parent-id "→" child-id label))) + +(defn- use-world! [nodes selected argument] + (if-let [id (parse-id argument)] + (if (contains? @nodes id) + (reset! selected id) + (println "unknown world:" id)) + (println "usage: :use ID"))) + +(defn- eval-line! [nodes selected line] + (let [ctx (get-in @nodes [@selected :ctx])] + (try + (prn (sci/eval-string* ctx line)) + (catch Throwable e + (binding [*out* *err*] + (println (ex-message e))))))) + +(defn- handle-line! [nodes selected next-id line] + (let [[command argument] (str/split (str/trim line) #"\s+" 2)] + (case command + ":fork" (fork-selected! nodes selected next-id argument) + (":use" ":switch") (use-world! nodes selected argument) + ":tree" (print-tree @nodes @selected) + ":help" (println help) + ":quit" false + (eval-line! nodes selected line)) + (not= command ":quit"))) + +(defn -main [] + (let [root (sci/init {}) + _ (sci/eval-string* root bootstrap) + nodes (atom {0 {:id 0 :label "root" :parent nil :ctx root}}) + selected (atom 0) + next-id (atom 1)] + (println "Forked SCI REPL") + (println help) + (print-tree @nodes @selected) + (loop [] + (let [{:keys [id label]} (get @nodes @selected)] + (print (format "[%d %s] user=> " id label)) + (flush) + (when-let [line (read-line)] + (when (or (str/blank? line) + (handle-line! nodes selected next-id line)) + (recur))))))) + +;; Run with: +;; clojure -M:examples -m sci.examples.forked-repl From 50341a16ab5d872d656fde1f46682f3ae29c2f6c Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 13:08:14 -0700 Subject: [PATCH 22/31] Make forkable runtime semantics opt-in --- README.md | 11 +- doc/forking.md | 7 +- examples/sci/examples/forked_repl.clj | 2 +- src/sci/core.cljc | 67 +++++---- src/sci/impl/analyzer.cljc | 81 +++++----- src/sci/impl/copy_vars.cljc | 2 +- src/sci/impl/core_protocols.cljc | 153 +++++++++++++++---- src/sci/impl/deftype.cljc | 3 +- src/sci/impl/evaluator.cljc | 9 +- src/sci/impl/execution.cljc | 6 +- src/sci/impl/fns.cljc | 172 +++++++++++++--------- src/sci/impl/multimethods.cljc | 7 +- src/sci/impl/namespaces.cljc | 67 +++++++-- src/sci/impl/opts.cljc | 45 ++++-- src/sci/impl/utils.cljc | 4 +- src/sci/impl/world.cljc | 25 ++-- src/sci/lang.cljc | 121 ++++++++------- test/sci/core_test.cljc | 64 +++++--- test/sci/defrecords_and_deftype_test.cljc | 6 +- test/sci/interrupt_fn_test.cljc | 3 +- test/sci/jit_test.cljs | 5 +- test/sci/multimethods_test.cljc | 2 +- test/sci/namespaces_test.cljc | 4 +- test/sci/native_protocols_test.cljs | 7 +- test/sci/test_utils.cljc | 3 + test/sci/vars_test.cljc | 12 +- 26 files changed, 592 insertions(+), 296 deletions(-) diff --git a/README.md b/README.md index a131d7c5..05a2e5c1 100644 --- a/README.md +++ b/README.md @@ -584,12 +584,18 @@ aren't visible to other users: (sci/eval-string* sci-ctx "forked") ;;=> Unable to resolve symbol: forked ``` -Forking also snapshots the roots and metadata of existing SCI vars and the +Full runtime forking is opt-in. Initialize the shared context with +`:runtime-mode :forkable`; the default `:standard` mode retains SCI's original +direct hot paths and `sci/fork` only copies the namespace environment. + +Forkable mode snapshots the roots and metadata of existing SCI vars and the values of atoms and volatiles created inside SCI. The handles keep their identity, so aliases and functions defined before the fork resolve against the world in which they are invoked: ``` clojure +(def sci-ctx (sci/init {:runtime-mode :forkable})) + (sci/eval-string* sci-ctx "(def counter (atom 0)) (defn bump! [] (swap! counter inc))") @@ -609,7 +615,8 @@ preserve any aliasing that matters to the application: ``` clojure (def sci-ctx - (sci/init {:fork-fn #(if (instance? clojure.lang.Atom %) + (sci/init {:runtime-mode :forkable + :fork-fn #(if (instance? clojure.lang.Atom %) (atom @%) %)})) ``` diff --git a/doc/forking.md b/doc/forking.md index 450e5e5f..f7b92043 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -1,6 +1,11 @@ # Forkable SCI worlds -`sci/fork` creates a branch of an interpreter's runtime state. Namespace maps, +Full runtime forking is enabled with +`(sci/init {:runtime-mode :forkable})`. In the default `:standard` mode SCI +retains its direct execution paths and `sci/fork` preserves its historical +behavior of copying only the namespace environment. + +In forkable mode, `sci/fork` creates a branch of an interpreter's runtime state. Namespace maps, SCI Var roots and metadata, SCI-created atom state, and values of SCI-created volatiles are part of that state. Existing Vars, refs, aliases, and interpreted functions keep their identity; their meaning is selected by the world in which diff --git a/examples/sci/examples/forked_repl.clj b/examples/sci/examples/forked_repl.clj index bf186db2..69c9116e 100644 --- a/examples/sci/examples/forked_repl.clj +++ b/examples/sci/examples/forked_repl.clj @@ -115,7 +115,7 @@ Any other line is evaluated in the selected SCI world. Try: (not= command ":quit"))) (defn -main [] - (let [root (sci/init {}) + (let [root (sci/init {:runtime-mode :forkable}) _ (sci/eval-string* root bootstrap) nodes (atom {0 {:id 0 :label "root" :parent nil :ctx root}}) selected (atom 0) diff --git a/src/sci/core.cljc b/src/sci/core.cljc index 8ba0219f..871dfe8e 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -47,7 +47,7 @@ ([name init-val] (new-var name init-val (meta name))) ([name init-val meta] (let [meta (assoc meta :name (utils/unqualify-symbol name))] - (sci.lang/->Var init-val name meta false false nil (:ns meta))))) + (sci.lang/->Var init-val name meta false false nil (:ns meta) false)))) (defn new-dynamic-var "Same as new-var but adds :dynamic true to meta." @@ -56,7 +56,7 @@ ([name init-val] (new-dynamic-var name init-val (meta name))) ([name init-val meta] (let [meta (assoc meta :dynamic true :name (utils/unqualify-symbol name))] - (sci.lang/->Var init-val name meta false false nil (:ns meta))))) + (sci.lang/->Var init-val name meta false false nil (:ns meta) false)))) (defn set! "Establish thread local binding of dynamic var" @@ -72,7 +72,7 @@ (sci.lang/->Var (vary-meta init-val assoc :sci/macro true) - name meta false false nil (:ns meta))))) + name meta false false nil (:ns meta) false)))) (macros/deftime (defmacro copy-var @@ -305,6 +305,10 @@ need application-specific isolation. SCI-owned mutable primitives are already world-relative and retain identity. + - `:runtime-mode`: `:standard` (the default) retains SCI's direct hot paths. + `:forkable` enables isolated runtime worlds for Vars, dynamic bindings and + SCI-owned mutable primitives. + - `:bindings`: DEPRECATED - `:bindings x` is the same as `:namespaces {'user x}`." ([s] (eval-string s nil)) ([s opts] @@ -334,24 +338,28 @@ ([ctx] (fork ctx nil)) ([ctx opts] - (let [fork-fn (if (contains? opts :fork-fn) - (:fork-fn opts) - (:fork-fn ctx)) - fork-value (fork/value-forker fork-fn) - forked-world (world/fork-world - (:sci.impl/world ctx) fork-value - #(cond - (utils/var? %) (vars/getRawRoot %) - (utils/namespace? %) (meta %) - (utils/sci-type? %) (t/getVal %) - :else (c/deref %)) - meta)] - (assoc ctx - :env (atom @(:env ctx)) - :fork-fn fork-fn - :sci.impl/primary? false - :sci.impl/world forked-world - :sci.impl/read-world (world/read-world forked-world false))))) + (if-let [source-world (:sci.impl/world ctx)] + (let [fork-fn (if (contains? opts :fork-fn) + (:fork-fn opts) + (:fork-fn ctx)) + fork-value (fork/value-forker fork-fn) + forked-world (world/fork-world + source-world fork-value + #(cond + (utils/var? %) (vars/getRawRoot %) + (utils/namespace? %) (meta %) + (utils/sci-type? %) (t/getVal %) + :else (c/deref %)) + meta)] + (assoc ctx + :env (atom @(:env ctx)) + :fork-fn fork-fn + :sci.impl/primary? false + :sci.impl/world forked-world + :sci.impl/read-world (world/read-world forked-world false))) + ;; Preserve the historical namespace-environment fork for standard + ;; contexts. Full live-state isolation is opt-in via :runtime-mode. + (update ctx :env (fn [env] (atom @env)))))) (defn eval-string* "Evaluates string `s` in the context of `ctx` (as produced with @@ -684,14 +692,15 @@ `ctx`. Returns mutated context." [ctx ns-name ns-map] (swap! (:env ctx) update-in [:namespaces ns-name] merge ns-map) - (store/with-ctx ctx - (world/with-active-world - ctx - #(doseq [[_ v] ns-map - :when (and (utils/var? v) - (not (world/registered? (:sci.impl/world ctx) v)))] - (world/register-var! v (vars/getRawRoot v) (meta v) - (vars/getRawWatches v))))) + (when (:sci.impl/world ctx) + (store/with-ctx ctx + (world/with-active-world + ctx + #(doseq [[_ v] ns-map + :when (and (utils/var? v) + (not (world/registered? (:sci.impl/world ctx) v)))] + (world/register-var! v (vars/getRawRoot v) (meta v) + (vars/getRawWatches v)))))) ctx) (defn find-ns diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index 6e6c7bbc..951a72fc 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -57,20 +57,28 @@ (declare analyze analyze-children analyze-call return-call return-map) #?(:clj - (deftype VarNode [^sci.impl.vars.IVar v - ^int slot] - sci.impl.types/Eval - (eval [_ _ctx _bindings] - (let [state (.get ^ThreadLocal execution/current) - ^clojure.lang.Volatile holder - (aget ^objects state execution/active-cells-holder-index) - ^java.util.concurrent.atomic.AtomicReferenceArray cells - (when holder (.deref holder))] - (if (nil? holder) - (.getDirectRoot v) - (.selectRoot v (.get cells slot))))) - sci.impl.types/Stack - (stack [_] nil))) + (do + (deftype DirectVarNode [^sci.impl.vars.IVar v] + sci.impl.types/Eval + (eval [_ _ctx _bindings] + (.getDirectRoot v)) + sci.impl.types/Stack + (stack [_] nil)) + + (deftype VarNode [^sci.impl.vars.IVar v + ^int slot] + sci.impl.types/Eval + (eval [_ _ctx _bindings] + (let [state (.get ^ThreadLocal execution/current) + ^clojure.lang.Volatile holder + (aget ^objects state execution/active-cells-holder-index) + ^java.util.concurrent.atomic.AtomicReferenceArray cells + (when holder (.deref holder))] + (if (nil? holder) + (.getDirectRoot v) + (.selectRoot v (.get cells slot))))) + sci.impl.types/Stack + (stack [_] nil)))) ;;;; Constant children @@ -831,7 +839,8 @@ false false nil - @utils/current-ns) + @utils/current-ns + false) (vars/unbind)))))] (swap! env (fn [env] @@ -2161,16 +2170,19 @@ (eval/resolve-symbol bindings fsym))))) (let [children (analyze-children ctx rest-forms) stack (utils/stack-frame m f-meta) + var-slot (when (and (:sci.impl/world ctx) + (utils/var? f)) + (world/slot-of + (:sci.impl/world ctx) f)) node (return-call ctx expr f children stack - #?(:cljd nil - :cljs (when (utils/var? f) (fn [_ _ v] - (deref v))) :clj nil))] + (when (some? var-slot) + (fn [_ _ v] + (vars/getRootAt v var-slot))))] #?(:cljs (cond (utils/var? f) - (if-let [slot (when-not (:dynamic f-meta) - (world/slot-of (:sci.impl/world ctx) f))] - (t/attach-ast node [:call-vslot [f slot] children stack]) + (if (some? var-slot) + (t/attach-ast node [:call-vslot [f var-slot] children stack]) (t/attach-ast node [:call-var f children stack])) (fn? f) (t/attach-ast node [:call-direct f children stack]) @@ -2213,15 +2225,12 @@ node (return-call ctx expr f children stack - #?(:cljd (fn [ctx bindings f] - (t/eval f ctx bindings)) - :cljs (if (utils/var? f) - (fn [ctx bindings f] - (t/eval @f ctx bindings)) - (fn [ctx bindings f] - (t/eval f ctx bindings))) - :clj (fn [ctx bindings f] - (t/eval f ctx bindings))))] + (fn [ctx bindings f] + (let [callee (t/eval f ctx bindings)] + (if (and (:sci.impl/world ctx) + (utils/var? callee)) + (vars/getRawRoot callee) + callee))))] #?(:cljs (if (utils/var? f) node ;; computed callee, e.g. ((add 1) 2): the callee @@ -2371,18 +2380,22 @@ (str "Can't take value of a macro: " v "")) :cljs (new js/Error (str "Can't take value of a macro: " v "")))) - (let [slot (when-not (:dynamic mv) + (let [slot (when (:sci.impl/world ctx) (world/slot-of (:sci.impl/world ctx) v))] #?(:clj (if (some? slot) (VarNode. v (int slot)) - (sci.impl.types/->Node - (faster/deref-1 v) nil)) + (if (:sci.impl/world ctx) + (sci.impl.types/->Node + (faster/deref-1 v) nil) + (DirectVarNode. v))) :default (sci.impl.types/->Node (if (some? slot) (vars/getRootAt v slot) - (faster/deref-1 v)) + (if (:sci.impl/world ctx) + (faster/deref-1 v) + (faster/deref-1 v))) nil ;; Dynamic Vars retain binding-frame ;; lookup. Other registered Vars resolve diff --git a/src/sci/impl/copy_vars.cljc b/src/sci/impl/copy_vars.cljc index 0e7c6338..e72e98f8 100644 --- a/src/sci/impl/copy_vars.cljc +++ b/src/sci/impl/copy_vars.cljc @@ -162,7 +162,7 @@ ;; NOTE: emit as little code as possible, so our JS bundle is as small as possible (if (and (not macro) elide-vars (not dyn) (not ctx)) sym - `(sci.lang/->Var ~init ~nm ~varm false ~ctx nil ~ns)))) + `(sci.lang/->Var ~init ~nm ~varm false ~ctx nil ~ns false)))) (defmacro copy-core-var [sym] `(copy-var ~sym clojure-core-ns {:copy-meta-from ~(core-sym sym)})) diff --git a/src/sci/impl/core_protocols.cljc b/src/sci/impl/core_protocols.cljc index 7a3a525e..f169abfb 100644 --- a/src/sci/impl/core_protocols.cljc +++ b/src/sci/impl/core_protocols.cljc @@ -9,6 +9,7 @@ [sci.impl.refs :as refs] [sci.impl.types :as types] [sci.impl.utils :as utils] + [sci.impl.vars :as vars] [sci.impl.world :as world] [sci.lang :as lang]) #?@(:cljd [] :clj [(:import [sci.impl.records SciRecord] @@ -48,8 +49,10 @@ ;; On CLJS, SCI types implement protocols natively; the wrapper only adds ;; world-relative routing before falling back to cljs.core/deref. #?(:cljd - (defn deref* [x] - (if (refs/sci-atom? x) + (defn forkable-deref* [x] + (if (utils/var? x) + (vars/getRawRoot x) + (if (refs/sci-atom? x) (clojure.core/deref x) (if (and (world/primary-world?) (satisfies? IDeref x)) (clojure.core/deref x) @@ -58,11 +61,13 @@ v (if (satisfies? IDeref x) (clojure.core/deref x) - (-deref x))))))) + (-deref x)))))))) :clj - (defn deref* + (defn forkable-deref* ([x] - (if (refs/sci-atom? x) + (if (utils/var? x) + (vars/getRawRoot x) + (if (refs/sci-atom? x) (clojure.core/deref x) (if (and (world/primary-world?) (instance? clojure.lang.IDeref x)) @@ -72,34 +77,41 @@ v (if (instance? clojure.lang.IDeref x) (clojure.core/deref x) - (deref x))))))) + (deref x)))))))) ([x & args] (apply clojure.core/deref x args))) :cljs - (defn deref* [x] - (if (refs/sci-atom? x) + (defn forkable-deref* [x] + (if (utils/var? x) + (vars/getRawRoot x) + (if (refs/sci-atom? x) (clojure.core/deref x) (if (world/primary-world?) (clojure.core/deref x) (let [v (tracked-value x)] (if-not (identical? untracked-value v) v - (clojure.core/deref x))))))) + (clojure.core/deref x)))))))) -(defn atom* +(defn forkable-apply [f & args] + (apply clojure.core/apply + (if (utils/var? f) (vars/getRawRoot f) f) + args)) + +(defn forkable-atom* "Creates an atom whose value and control state are owned by the active SCI world." [x & options] (apply refs/atom x options)) -(defn volatile!* +(defn forkable-volatile!* "Creates a volatile whose value is owned by the active SCI world." [x] (let [v (clojure.core/volatile! x)] (world/register! v x) v)) -(defn vreset!* +(defn forkable-vreset!* [v x] (if (world/mutable-primary-world?) (clojure.core/vreset! v x) @@ -111,12 +123,12 @@ (world/reset-value! v x)) (clojure.core/vreset! v x)))) -(defn vswap!* +(defn forkable-vswap!* [v f & args] (if (world/mutable-primary-world?) (clojure.core/vreset! v (apply f (clojure.core/deref v) args)) (if (world/tracked? v) - (vreset!* v (apply f (tracked-value v) args)) + (forkable-vreset!* v (apply f (tracked-value v) args)) (clojure.core/vreset! v (apply f (clojure.core/deref v) args))))) (defn- validate-ref! [ref v] @@ -302,7 +314,7 @@ ;;;; Re-routing #?(:clj - (defn swap!* [ref f & args] + (defn forkable-swap!* [ref f & args] (cond (refs/sci-atom? ref) (apply clojure.core/swap! ref f args) @@ -320,7 +332,7 @@ :else (apply swap ref f args))) :cljs - (defn swap!* [ref f & args] + (defn forkable-swap!* [ref f & args] (cond (refs/sci-atom? ref) (apply clojure.core/swap! ref f args) @@ -335,7 +347,7 @@ (apply clojure.core/swap! ref f args)))) #?(:cljd - (defn swap!* [ref f & args] + (defn forkable-swap!* [ref f & args] (cond (refs/sci-atom? ref) (apply clojure.core/swap! ref f args) @@ -355,7 +367,7 @@ (apply -swap! ref f args)))) #?(:cljd - (defn reset!* [ref v] + (defn forkable-reset!* [ref v] (cond (refs/sci-atom? ref) (clojure.core/reset! ref v) @@ -374,7 +386,7 @@ :else (-reset! ref v))) :clj - (defn reset!* [ref v] + (defn forkable-reset!* [ref v] (cond (refs/sci-atom? ref) (clojure.core/reset! ref v) @@ -392,7 +404,7 @@ :else (reset ref v))) :cljs - (defn reset!* [ref v] + (defn forkable-reset!* [ref v] (cond (refs/sci-atom? ref) (clojure.core/reset! ref v) @@ -407,7 +419,7 @@ (clojure.core/reset! ref v)))) #?(:cljd - (defn compare-and-set!* [ref old new] + (defn forkable-compare-and-set!* [ref old new] (cond (refs/sci-atom? ref) (clojure.core/compare-and-set! ref old new) @@ -422,7 +434,7 @@ :else (clojure.core/compare-and-set! ref old new))) :clj - (defn compare-and-set!* [ref old new] + (defn forkable-compare-and-set!* [ref old new] (cond (refs/sci-atom? ref) (clojure.core/compare-and-set! ref old new) @@ -440,7 +452,7 @@ :else (compareAndSet ref old new))) :cljs - (defn compare-and-set!* [ref old new] + (defn forkable-compare-and-set!* [ref old new] (cond (refs/sci-atom? ref) (clojure.core/compare-and-set! ref old new) @@ -455,7 +467,7 @@ (clojure.core/compare-and-set! ref old new)))) #?(:clj - (defn swap-vals!* [ref f & args] + (defn forkable-swap-vals!* [ref f & args] (cond (refs/sci-atom? ref) (apply clojure.core/swap-vals! ref f args) @@ -480,7 +492,7 @@ (apply swapVals ref f args)))) #?(:clj - (defn reset-vals!* [ref v] + (defn forkable-reset-vals!* [ref v] (cond (refs/sci-atom? ref) (clojure.core/reset-vals! ref v) @@ -504,6 +516,97 @@ :else (resetVals ref v)))) +;; Standard contexts retain SCI's original direct host paths. Forkable +;; contexts install the world-aware functions above as per-context core Vars. +#?(:cljd + (defn deref* [x] + (if (satisfies? IDeref x) + (clojure.core/deref x) + (-deref x))) + :clj + (defn deref* + ([x] + (if (instance? clojure.lang.IDeref x) + (clojure.core/deref x) + (deref x))) + ([x & args] + (apply clojure.core/deref x args))) + :cljs + (defn deref* [x] + (clojure.core/deref x))) + +(defn atom* [x & options] + (apply clojure.core/atom x options)) + +(defn volatile!* [x] + (clojure.core/volatile! x)) + +(defn vreset!* [v x] + (clojure.core/vreset! v x)) + +(defn vswap!* [v f & args] + (clojure.core/vreset! v (apply f (clojure.core/deref v) args))) + +#?(:clj + (defn swap!* [ref f & args] + (if (instance? clojure.lang.IAtom ref) + (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f)) + (if args + (apply swap ref f args) + (swap ref f)))) + :cljs + (defn swap!* [ref f & args] + (apply clojure.core/swap! ref f args))) + +#?(:cljd + (defn swap!* [ref f & args] + (if (or (instance? cljd.core/Atom ref) + (satisfies? ISwap ref)) + (if args + (apply clojure.core/swap! ref f args) + (clojure.core/swap! ref f)) + (if args + (apply -swap! ref f args) + (-swap! ref f))))) + +#?(:cljd + (defn reset!* [ref v] + (if (or (instance? cljd.core/Atom ref) + (satisfies? IReset ref)) + (clojure.core/reset! ref v) + (-reset! ref v))) + :clj + (defn reset!* [ref v] + (if (instance? clojure.lang.IAtom ref) + (clojure.core/reset! ref v) + (reset ref v))) + :cljs + (defn reset!* [ref v] + (clojure.core/reset! ref v))) + +#?(:clj + (defn compare-and-set!* [ref old new] + (if (instance? clojure.lang.IAtom ref) + (clojure.core/compare-and-set! ref old new) + (compareAndSet ref old new))) + :default + (defn compare-and-set!* [ref old new] + (clojure.core/compare-and-set! ref old new))) + +#?(:clj + (defn swap-vals!* [ref f & args] + (if (instance? clojure.lang.IAtom ref) + (apply clojure.core/swap-vals! ref f args) + (apply swapVals ref f args)))) + +#?(:clj + (defn reset-vals!* [ref v] + (if (instance? clojure.lang.IAtom ref) + (clojure.core/reset-vals! ref v) + (resetVals ref v)))) + ;;;; Protocol vars (def swap-protocol diff --git a/src/sci/impl/deftype.cljc b/src/sci/impl/deftype.cljc index aa54b38c..d6e30369 100644 --- a/src/sci/impl/deftype.cljc +++ b/src/sci/impl/deftype.cljc @@ -312,7 +312,8 @@ (:sci.impl/fields (types/getVal type))))) (defn ->type-impl [rec-name type type-meta m] - (let [desc (when (mutable-type? type) + (let [desc (when (and (world/current-world) + (mutable-type? type)) (world/register-managed! :deftype-fields [m] [])) home (:home desc) registry (:registry desc) diff --git a/src/sci/impl/evaluator.cljc b/src/sci/impl/evaluator.cljc index 3793e395..4e6d790e 100644 --- a/src/sci/impl/evaluator.cljc +++ b/src/sci/impl/evaluator.cljc @@ -34,7 +34,7 @@ prev (get the-current-ns var-name) prev (if-not (utils/var? prev) (let [m (meta prev)] - (lang/->Var prev var-name m false false nil (:ns m))) + (lang/->Var prev var-name m false false nil (:ns m) false)) prev) v (do (when-not (identical? utils/var-unbound init) (vars/bindRoot prev init)) @@ -415,8 +415,11 @@ `(defn ~'fn-call ~'[ctx bindings f args] ;; TODO: can we prevent hitting this at all, by analyzing more efficiently? ;; (prn :count ~'f ~'(count args) ~'args) - (case ~'(count args) - ~@cases))))) + (let [~'f (if (and (:sci.impl/world ~'ctx) (utils/var? ~'f)) + (vars/getRawRoot ~'f) + ~'f)] + (case ~'(count args) + ~@cases)))))) (def-fn-call) diff --git a/src/sci/impl/execution.cljc b/src/sci/impl/execution.cljc index 0010967f..92941de6 100644 --- a/src/sci/impl/execution.cljc +++ b/src/sci/impl/execution.cljc @@ -13,11 +13,13 @@ #?(:cljd (#/(List/filled dynamic) 7 nil) :default (object-array 7))) -#?(:clj +#?(:cljd + (def current (volatile! (new-state))) + :clj (def ^ThreadLocal current (proxy [ThreadLocal] [] (initialValue [] (new-state)))) - :default + :cljs (def current (volatile! (new-state)))) (defn current-state [] diff --git a/src/sci/impl/fns.cljc b/src/sci/impl/fns.cljc index a21cb3bf..8e5c7c99 100644 --- a/src/sci/impl/fns.cljc +++ b/src/sci/impl/fns.cljc @@ -35,53 +35,68 @@ ([n disable-arity-checks] `(gen-fn ~n ~disable-arity-checks false)) ([n _disable-arity-checks varargs] - (if (zero? n) - (let [varargs-param (when varargs (gensym))] - `(let [recur# recur] - (fn ~'arity-0 ~(cond-> [] - varargs (conj '& varargs-param)) - (let [active-ctx# (world/active-ctx ~'ctx) - interrupt-fn# (:interrupt-fn active-ctx#) - ~'invoc-array (when-not (zero? ~'invoc-size) - #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) - :default (object-array ~'invoc-size)))] - (when ~'enclosed->invocation - (~'enclosed->invocation ~'enclosed-array ~'invoc-array)) - (wrap-this-as - ~@(when varargs - [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) - (loop [] - (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret# (types/eval ~'body active-ctx# ~'invoc-array)] - (if (identical? recur# ret#) - (recur) - ret#)))))))) - (let [fn-params (vec (repeatedly n gensym)) - varargs-param (when varargs (gensym)) - asets `(do ~@(map (fn [fn-param idx] - `(aset ~(with-meta 'invoc-array - #?(:cljd {:tag 'List} :default {:tag 'objects})) ~idx ~fn-param)) - fn-params (range)))] - `(let [recur# recur] - (fn ~(symbol (str "arity-" n)) ~(cond-> fn-params - varargs (conj '& varargs-param)) - (let [active-ctx# (world/active-ctx ~'ctx) - interrupt-fn# (:interrupt-fn active-ctx#) - ~'invoc-array (when-not (zero? ~'invoc-size) - #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) - :default (object-array ~'invoc-size)))] - (when ~'enclosed->invocation - (~'enclosed->invocation ~'enclosed-array ~'invoc-array)) - ~asets - (wrap-this-as - ~@(when varargs - [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) - (loop [] - (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret# (types/eval ~'body active-ctx# ~'invoc-array)] - (if (identical? recur# ret#) - (recur) - ret#))))))))))) + (letfn [(emit [forkable?] + (if (zero? n) + (let [varargs-param (when varargs (gensym))] + `(let [recur# recur + ~@(when-not forkable? + ['interrupt-fn (list :interrupt-fn 'ctx)])] + (fn ~'arity-0 ~(cond-> [] + varargs (conj '& varargs-param)) + (let [~@(when forkable? + ['active-ctx (list 'world/active-ctx 'ctx) + 'interrupt-fn (list :interrupt-fn 'active-ctx)]) + ~'invoc-array (when-not (zero? ~'invoc-size) + #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) + :default (object-array ~'invoc-size)))] + (when ~'enclosed->invocation + (~'enclosed->invocation ~'enclosed-array ~'invoc-array)) + (wrap-this-as + ~@(when varargs + [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) + (loop [] + (when-not (nil? ~'interrupt-fn) (~'interrupt-fn)) + (let [ret# (types/eval ~'body + ~(if forkable? 'active-ctx 'ctx) + ~'invoc-array)] + (if (identical? recur# ret#) + (recur) + ret#)))))))) + (let [fn-params (vec (repeatedly n gensym)) + varargs-param (when varargs (gensym)) + asets `(do ~@(map (fn [fn-param idx] + `(aset ~(with-meta 'invoc-array + #?(:cljd {:tag 'List} :default {:tag 'objects})) + ~idx ~fn-param)) + fn-params (range)))] + `(let [recur# recur + ~@(when-not forkable? + ['interrupt-fn (list :interrupt-fn 'ctx)])] + (fn ~(symbol (str "arity-" n)) + ~(cond-> fn-params varargs (conj '& varargs-param)) + (let [~@(when forkable? + ['active-ctx (list 'world/active-ctx 'ctx) + 'interrupt-fn (list :interrupt-fn 'active-ctx)]) + ~'invoc-array (when-not (zero? ~'invoc-size) + #?(:cljd (#/(List/filled dynamic) ~'invoc-size nil) + :default (object-array ~'invoc-size)))] + (when ~'enclosed->invocation + (~'enclosed->invocation ~'enclosed-array ~'invoc-array)) + ~asets + (wrap-this-as + ~@(when varargs + [`(aset ~(with-meta 'invoc-array #?(:cljd {:tag 'List} :default nil)) ~'vararg-idx ~varargs-param)]) + (loop [] + (when-not (nil? ~'interrupt-fn) (~'interrupt-fn)) + (let [ret# (types/eval ~'body + ~(if forkable? 'active-ctx 'ctx) + ~'invoc-array)] + (if (identical? recur# ret#) + (recur) + ret#))))))))))] + `(if (:sci.impl/world ~'ctx) + ~(emit true) + ~(emit false))))) #_(require '[clojure.pprint :as pprint]) #_(binding [*print-meta* true] @@ -151,27 +166,48 @@ 19 (gen-fn 19) 20 (gen-fn 20) ;; default case for 20+ args (used by loop) - (let [recur# recur] - (fn arity-many [& args] - (let [active-ctx (world/active-ctx ctx) - interrupt-fn# (:interrupt-fn active-ctx) - invoc-array (when-not (zero? invoc-size) - #?(:cljd (#/(List/filled dynamic) invoc-size nil) - :default (object-array invoc-size)))] - (when enclosed->invocation - (enclosed->invocation enclosed-array invoc-array)) - (loop [args args i 0] - (when (< i fixed-arity) - (aset #?(:cljd invoc-array - :clj ^objects invoc-array - :cljs ^objects invoc-array) i (first args)) - (recur (next args) (inc i)))) - (loop [] - (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret (types/eval body active-ctx invoc-array)] - (if (identical? recur# ret) - (recur) - ret))))))))] + (if (:sci.impl/world ctx) + (let [recur# recur] + (fn arity-many [& args] + (let [active-ctx (world/active-ctx ctx) + interrupt-fn# (:interrupt-fn active-ctx) + invoc-array (when-not (zero? invoc-size) + #?(:cljd (#/(List/filled dynamic) invoc-size nil) + :default (object-array invoc-size)))] + (when enclosed->invocation + (enclosed->invocation enclosed-array invoc-array)) + (loop [args args i 0] + (when (< i fixed-arity) + (aset #?(:cljd invoc-array + :clj ^objects invoc-array + :cljs ^objects invoc-array) i (first args)) + (recur (next args) (inc i)))) + (loop [] + (when-not (nil? interrupt-fn#) (interrupt-fn#)) + (let [ret (types/eval body active-ctx invoc-array)] + (if (identical? recur# ret) + (recur) + ret))))))) + (let [recur# recur + interrupt-fn# (:interrupt-fn ctx)] + (fn arity-many [& args] + (let [invoc-array (when-not (zero? invoc-size) + #?(:cljd (#/(List/filled dynamic) invoc-size nil) + :default (object-array invoc-size)))] + (when enclosed->invocation + (enclosed->invocation enclosed-array invoc-array)) + (loop [args args i 0] + (when (< i fixed-arity) + (aset #?(:cljd invoc-array + :clj ^objects invoc-array + :cljs ^objects invoc-array) i (first args)) + (recur (next args) (inc i)))) + (loop [] + (when-not (nil? interrupt-fn#) (interrupt-fn#)) + (let [ret (types/eval body ctx invoc-array)] + (if (identical? recur# ret) + (recur) + ret))))))))] f))) (defn lookup-by-arity [arities arity] diff --git a/src/sci/impl/multimethods.cljc b/src/sci/impl/multimethods.cljc index 1a2265d1..29b06168 100644 --- a/src/sci/impl/multimethods.cljc +++ b/src/sci/impl/multimethods.cljc @@ -355,9 +355,12 @@ (defn multi-fn-impl [name dispatch-fn default hierarchy] #?(:cljd (let [method-table (atom {})] - (world/register! method-table {}) + (when (world/current-world) + (world/register! method-table {})) (SciMultiFn. name dispatch-fn default method-table)) - :default (managed-multifn name dispatch-fn default hierarchy))) + :default (if (world/current-world) + (managed-multifn name dispatch-fn default hierarchy) + (new-host-multifn name dispatch-fn default hierarchy)))) (defn multi-fn-add-method-impl [multifn dispatch-val f] diff --git a/src/sci/impl/namespaces.cljc b/src/sci/impl/namespaces.cljc index 14da7adb..3f39f026 100644 --- a/src/sci/impl/namespaces.cljc +++ b/src/sci/impl/namespaces.cljc @@ -1619,7 +1619,7 @@ 'assoc! (copy-core-var assoc!) 'assoc-in (copy-core-var assoc-in) 'associative? (copy-core-var associative?) - 'atom (copy-var core-protocols/atom* clojure-core-ns {:name 'atom}) + 'atom (copy-core-var atom) #?@(:clj ['bean (copy-core-var bean)]) 'binding (macrofy 'binding sci-binding) 'binding-conveyor-fn (copy-core-var sci.impl.vars/binding-conveyor-fn) @@ -1690,10 +1690,8 @@ 'deftype (macrofy 'deftype sci.impl.deftype/deftype-macro clojure-core-ns) 'delay (macrofy 'delay delay*) - 'delay? (copy-var refs/delay?* clojure-core-ns - {:copy-meta-from 'clojure.core/delay?}) - #?@(:clj ['deliver (copy-var refs/deliver* clojure-core-ns - {:copy-meta-from 'clojure.core/deliver})]) + 'delay? (copy-core-var delay?) + #?@(:clj ['deliver (copy-core-var deliver)]) #?@(:cljs ['demunge (copy-core-var cljs.core/demunge)]) #?@(:cljd [] :default ['derive (copy-var hierarchies/derive* clojure-core-ns {:name 'derive})]) #?@(:cljd [] :default ['descendants (copy-var hierarchies/descendants* clojure-core-ns {:name 'descendants})]) @@ -1752,8 +1750,7 @@ 'float (copy-core-var float) 'fn? (copy-core-var fn?) 'for (macrofy 'for for-macro/expand-for) - 'force (copy-var refs/force* clojure-core-ns - {:copy-meta-from 'clojure.core/force}) + 'force (copy-core-var force) 'get (copy-core-var get) 'get-thread-binding-frame-impl (new-var 'get-thread-binding-frame-impl sci.impl.vars/get-thread-binding-frame) #?@(:clj ['get-thread-bindings (copy-var sci.impl.vars/get-thread-bindings clojure-core-ns {:name 'get-thread-bindings})]) @@ -1841,8 +1838,7 @@ 'max-key (copy-core-var max-key) 'meta (copy-core-var meta) 'memfn (copy-var memfn clojure-core-ns {:macro true}) - 'memoize (copy-var refs/memoize* clojure-core-ns - {:copy-meta-from 'clojure.core/memoize}) + 'memoize (copy-core-var memoize) 'merge (copy-core-var merge) 'merge-with (copy-core-var merge-with) 'min (copy-core-var min) @@ -1894,8 +1890,7 @@ 'partition-all (copy-core-var partition-all) 'partition-by (copy-core-var partition-by) 'persistent! (copy-core-var persistent!) - #?@(:clj ['promise (copy-var refs/promise* clojure-core-ns - {:copy-meta-from 'clojure.core/promise})]) + #?@(:clj ['promise (copy-core-var promise)]) 'push-thread-bindings (copy-var sci.impl.vars/push-thread-bindings clojure-core-ns {:name 'push-thread-bindings}) 'qualified-ident? (copy-core-var qualified-ident?) 'qualified-symbol? (copy-core-var qualified-symbol?) @@ -2053,10 +2048,10 @@ 'vec (copy-core-var vec) 'vector (copy-core-var vector) 'vector? (copy-core-var vector?) - 'volatile! (copy-var core-protocols/volatile!* clojure-core-ns {:name 'volatile!}) + 'volatile! (copy-core-var volatile!) 'volatile? (copy-core-var volatile?) - 'vreset! (copy-var core-protocols/vreset!* clojure-core-ns {:name 'vreset!}) - 'vswap! (copy-var core-protocols/vswap!* clojure-core-ns {:name 'vswap!}) + 'vreset! (copy-core-var vreset!) + 'vswap! (macrofy 'vswap! vswap!) 'when-first (macrofy 'when-first when-first*) 'when-let (macrofy 'when-let when-let*) 'when-some (macrofy 'when-some when-some*) @@ -2075,7 +2070,7 @@ ;; -write comes from the IWriter protocol-vars entry below 'locking (macrofy 'locking locking*) - '-delay* (new-var '-delay* refs/delay* clojure-core-ns) + '-delay* (new-var '-delay* (fn [f] (delay (f))) clojure-core-ns) #?@(:cljd ['-lazy-seq* (new-var '-lazy-seq* (fn [f] (lazy-seq (f))) clojure-core-ns) ;; no unchecked math on cljd, alias to the checked variants 'unchecked-inc (new-var 'unchecked-inc inc clojure-core-ns) @@ -2134,6 +2129,45 @@ INamed IAtom IVolatile IIterable Inst IEncodeJS IEncodeClojure)))) + (def forkable-core-overrides + (merge + {'deref (copy-var core-protocols/forkable-deref* clojure-core-ns + {:name 'deref}) + 'apply (copy-var core-protocols/forkable-apply clojure-core-ns + {:name 'apply}) + 'swap! (copy-var core-protocols/forkable-swap!* clojure-core-ns + {:name 'swap!}) + 'reset! (copy-var core-protocols/forkable-reset!* clojure-core-ns + {:name 'reset!}) + 'compare-and-set! + (copy-var core-protocols/forkable-compare-and-set!* clojure-core-ns + {:name 'compare-and-set!}) + 'atom (copy-var core-protocols/forkable-atom* clojure-core-ns + {:name 'atom}) + 'volatile! (copy-var core-protocols/forkable-volatile!* clojure-core-ns + {:name 'volatile!}) + 'vreset! (copy-var core-protocols/forkable-vreset!* clojure-core-ns + {:name 'vreset!}) + 'vswap! (copy-var core-protocols/forkable-vswap!* clojure-core-ns + {:name 'vswap!}) + 'delay? (copy-var refs/delay?* clojure-core-ns + {:copy-meta-from 'clojure.core/delay?}) + 'force (copy-var refs/force* clojure-core-ns + {:copy-meta-from 'clojure.core/force}) + 'memoize (copy-var refs/memoize* clojure-core-ns + {:copy-meta-from 'clojure.core/memoize}) + '-delay* (new-var '-delay* refs/delay* clojure-core-ns)} + #?(:clj + {'swap-vals! (copy-var core-protocols/forkable-swap-vals!* + clojure-core-ns {:name 'swap-vals!}) + 'reset-vals! (copy-var core-protocols/forkable-reset-vals!* + clojure-core-ns {:name 'reset-vals!}) + 'promise (copy-var refs/promise* clojure-core-ns + {:copy-meta-from 'clojure.core/promise}) + 'deliver (copy-var refs/deliver* clojure-core-ns + {:copy-meta-from 'clojure.core/deliver})} + :default {}))) + (defn dir-fn [ns] (let [ctx (store/get-ctx) @@ -2395,7 +2429,8 @@ false nil nil - clojure-walk-namespace)) + clojure-walk-namespace + false)) (def clojure-walk-ns {:obj clojure-walk-namespace diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index 2c76fbe1..31e65856 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -14,10 +14,11 @@ [sci.impl.types ICustomType])])) (defn- register-vars! [ctx] - (store/with-ctx ctx - (world/with-active-world - ctx - #(do + (when (:sci.impl/world ctx) + (store/with-ctx ctx + (world/with-active-world + ctx + #(do (doseq [[_ ns-map] (:namespaces @(:env ctx)) :let [ns-obj (:obj ns-map)] :when ns-obj] @@ -34,7 +35,15 @@ (not (world/registered? (:sci.impl/world ctx) v)))] (world/register-var! v (vars/getRawRoot v) (meta v) - (vars/getRawWatches v))))))) + (vars/getRawWatches v)))))))) + +(defn- normalize-runtime-mode [mode] + (let [mode (or mode :standard)] + (when-not (#{:standard :forkable} mode) + (throw (ex-info "Invalid SCI runtime mode." + {:runtime-mode mode + :allowed #{:standard :forkable}}))) + mode)) #?(:clj (defrecord Env [namespaces imports load-fn])) @@ -276,6 +285,7 @@ deftype-fn interrupt-fn unrestricted + runtime-mode fork-fn #?(:cljs async-load-fn) #?(:cljs js-libs) @@ -285,11 +295,16 @@ ns-aliases (merge default-ns-aliases ns-aliases) raw-classes (merge default-classes classes) classes (normalize-classes raw-classes) + runtime-mode (normalize-runtime-mode runtime-mode) namespaces (cond-> namespaces + (= :forkable runtime-mode) + (->> (merge-with merge + {'clojure.core + namespaces/forkable-core-overrides})) bindings (merge {'user (assoc bindings :obj utils/user-ns)})) _ (init-env! env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) - world-root (world/new-world) + world-root (when (= :forkable runtime-mode) (world/new-world)) ctx (assoc (->ctx {} env features readers (or allow deny) :interrupt-fn interrupt-fn) :allow (when allow (process-permissions #{} allow)) @@ -298,11 +313,13 @@ :proxy-fn proxy-fn :deftype-fn deftype-fn :unrestricted unrestricted + :runtime-mode runtime-mode :fork-fn fork-fn :sci.impl/world world-root - :sci.impl/read-world (world/read-world world-root true) - :sci.impl/lineage (atom nil) - :sci.impl/primary? true + :sci.impl/read-world (when world-root + (world/read-world world-root true)) + :sci.impl/lineage (when world-root (atom nil)) + :sci.impl/primary? (when world-root true) #?@(:clj [:main-thread-id (.getId (Thread/currentThread))]))] (register-vars! ctx) ctx)) @@ -321,6 +338,7 @@ readers reify-fn deftype-fn + runtime-mode fork-fn #?(:cljs async-load-fn) #?(:cljs js-libs) @@ -328,6 +346,14 @@ :or {load-fn (:load-fn env) #?@(:cljs [async-load-fn (:async-load-fn env)]) features (:features ctx)}} opts + inherited-runtime-mode (:runtime-mode ctx :standard) + runtime-mode (if (contains? opts :runtime-mode) + (normalize-runtime-mode runtime-mode) + inherited-runtime-mode) + _ (when-not (= runtime-mode inherited-runtime-mode) + (throw (ex-info "SCI runtime mode cannot be changed by merge-opts." + {:runtime-mode runtime-mode + :context-runtime-mode inherited-runtime-mode}))) raw-classes (merge (:raw-classes @!env) classes) classes (normalize-classes raw-classes) namespaces (cond-> namespaces @@ -343,6 +369,7 @@ :reify-fn reify-fn :deftype-fn deftype-fn :unrestricted unrestricted + :runtime-mode runtime-mode :fork-fn fork-fn :sci.impl/world (:sci.impl/world ctx) :sci.impl/read-world (:sci.impl/read-world ctx) diff --git a/src/sci/impl/utils.cljc b/src/sci/impl/utils.cljc index 20bd8828..70a28800 100644 --- a/src/sci/impl/utils.cljc +++ b/src/sci/impl/utils.cljc @@ -324,7 +324,7 @@ (dynamic-var name init-val (meta name))) ([name init-val meta] (let [meta (assoc meta :dynamic true :name (unqualify-symbol name))] - (lang/->Var init-val name meta false false nil (:ns meta))))) + (lang/->Var init-val name meta false false nil (:ns meta) false)))) ;; foundational namespaces (def user-ns (lang/->Namespace 'user nil)) @@ -352,7 +352,7 @@ ([name init-val] (new-var name init-val (meta name))) ([name init-val meta] (let [meta (assoc meta :name (unqualify-symbol name))] - (lang/->Var init-val name meta false nil nil (:ns meta))))) + (lang/->Var init-val name meta false nil nil (:ns meta) false)))) (defn var? [x] (instance? #?(:cljd lang/Var :clj sci.lang.Var :cljs sci.lang.Var) x)) diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index bde3fdb2..d0659b7a 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -16,6 +16,10 @@ (deftype DenseWorld [cells-holder registry gate persistent?]) (deftype ReadWorld [world primary?]) +(defprotocol IWorldTracked + (-world-tracked? [handle]) + (-mark-world-tracked! [handle])) + (defn read-world [world primary?] (ReadWorld. world primary?)) @@ -122,15 +126,17 @@ shared gate permit; a fork takes the exclusive permit and therefore observes a quiescent source world without adding locks to individual reads." [ctx f] - #?(:clj - (let [^DenseWorld world (:sci.impl/world ctx) - lock (.readLock ^ReentrantReadWriteLock (.-gate world))] - (.lock lock) - (try - (call-with-active-world ctx f) - (finally (.unlock lock)))) - :default - (call-with-active-world ctx f))) + (if-let [world (:sci.impl/world ctx)] + #?(:clj + (let [^DenseWorld world world + lock (.readLock ^ReentrantReadWriteLock (.-gate world))] + (.lock lock) + (try + (call-with-active-world ctx f) + (finally (.unlock lock)))) + :default + (call-with-active-world ctx f)) + (f))) (defn current-world [] (:sci.impl/world store/*ctx*)) @@ -468,6 +474,7 @@ (register-var! handle value m nil)) ([handle value m watches] (when-let [^DenseWorld world (current-world)] + (-mark-world-tracked! handle) (let [{:keys [value-slot meta-slot]} (allocate-descriptor! world handle :var (not (:sci/built-in m)) (:sci.impl/fork-fn m))] diff --git a/src/sci/lang.cljc b/src/sci/lang.cljc index 5f45f476..467fda9e 100644 --- a/src/sci/lang.cljc +++ b/src/sci/lang.cljc @@ -110,16 +110,25 @@ #?(:cljd ^:mutable watches :clj ^:volatile-mutable watches :cljs ^:mutable watches) - ns] + ns + #?(:cljd ^:mutable world-tracked + :clj ^:volatile-mutable world-tracked + :cljs ^:mutable world-tracked)] ;; marker interface, clj only for now #?@(:cljd [] :clj [sci.lang.IVar]) + world/IWorldTracked + (-world-tracked? [_] world-tracked) + (-mark-world-tracked! [this] + #?(:cljd (set! world-tracked true) + :default (set! (.-world-tracked this) true)) + true) types/HasName (getName [this] - (or (:name (world/var-meta this meta)) sym)) + (or (:name (if world-tracked (world/var-meta this meta) meta)) sym)) vars/IVar (bindRoot [this v] - (let [old-root (world/var-value this root) - current-meta (world/var-meta this meta)] + (let [old-root (if world-tracked (world/var-value this root) root) + current-meta (if world-tracked (world/var-meta this meta) meta)] (vars/with-writeable-var this current-meta (if (world/current-world) (do (world/register-var! this v current-meta) @@ -130,14 +139,14 @@ ;; this is the return value for alter-var-root which should be the only place calling bindRoot directly v) (getRawRoot [this] - (world/var-value this root)) + (if world-tracked (world/var-value this root) root)) (getRawWatches [_] watches) (getDirectRoot [this] (if thread-bound (if-let [tbox (vars/get-thread-binding this)] (types/getVal tbox) - root) - root)) + (if world-tracked (world/var-value this root) root)) + (if world-tracked (world/var-value this root) root))) (selectRoot [this world-value] (if thread-bound (if-let [tbox (vars/get-thread-binding this)] @@ -155,14 +164,14 @@ (world/var-value-at slot root))) (toSymbol [this] ;; if we have at least a name from metadata, then build the symbol from that - (let [current-meta (world/var-meta this meta)] + (let [current-meta (if world-tracked (world/var-meta this meta) meta)] (if-let [sym-name (some-> (:name current-meta) name)] (symbol (some-> (:ns current-meta) types/getName name) sym-name) ;; otherwise, fall back to the symbol sym))) (isMacro [this] - (let [current-meta (world/var-meta this meta) - current-root (world/var-value this root)] + (let [current-meta (if world-tracked (world/var-meta this meta) meta) + current-root (if world-tracked (world/var-value this root) root)] (or (:macro current-meta) (when-some [m (clojure.core/meta current-root)] (:sci/macro m))))) @@ -170,7 +179,7 @@ #?(:cljd (set! thread-bound v) :default (set! (.-thread-bound this) v))) (unbind [this] - (let [current-meta (world/var-meta this meta)] + (let [current-meta (if world-tracked (world/var-meta this meta) meta)] (vars/with-writeable-var this current-meta (if (world/current-world) (let [unbound (vars/->SciUnbound this)] @@ -185,10 +194,10 @@ (not (instance? #?(:cljd vars/SciUnbound :clj sci.impl.vars.SciUnbound :cljs sci.impl.vars.SciUnbound) - (world/var-value this root)))) + (if world-tracked (world/var-value this root) root)))) vars/DynVar (dynamic? [this] - (:dynamic (world/var-meta this meta))) + (:dynamic (if world-tracked (world/var-meta this meta) meta))) types/IBox (setVal [this v] (if-let [b (vars/get-thread-binding this)] @@ -215,7 +224,7 @@ (vars/bumping-set! (.-root this) v))) (vars/bumping-set! (.-root this) v)) (throw-root-binding this))))) - (getVal [this] (world/var-value this root)) + (getVal [this] (if world-tracked (world/var-value this root) root)) #?(:cljd IDeref :clj clojure.lang.IDeref :cljs IDeref) (#?(:cljd -deref :clj deref @@ -223,8 +232,8 @@ (if thread-bound (if-let [tbox (vars/get-thread-binding this)] (types/getVal tbox) - (world/var-value this root)) - (world/var-value this root))) + (if world-tracked (world/var-value this root) root)) + (if world-tracked (world/var-value this root) root))) Object (toString [this] (str "#'" (vars/toSymbol this))) @@ -233,9 +242,9 @@ (-write writer "#'") (-pr-writer (vars/toSymbol a) writer opts))) #?(:cljd IMeta :clj clojure.lang.IMeta :cljs IMeta) - #?(:cljd (-meta [this] (world/var-meta this meta)) - :clj (clojure.core/meta [this] (world/var-meta this meta)) - :cljs (-meta [this] (world/var-meta this meta))) + #?(:cljd (-meta [this] (if world-tracked (world/var-meta this meta) meta)) + :clj (clojure.core/meta [this] (if world-tracked (world/var-meta this meta) meta)) + :cljs (-meta [this] (if world-tracked (world/var-meta this meta) meta))) ;; #?(:clj Comparable :cljs IEquiv) ;; (-equiv [this other] ;; (if (instance? Var other) @@ -353,82 +362,82 @@ ;; #?(:cljs Fn) ;; In the real CLJS this is there... why? #?(:cljd IFn :clj clojure.lang.IFn :cljs IFn) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this] - (@this)) + ((vars/getDirectRoot this))) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a] - (@this a)) + ((vars/getDirectRoot this) a)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b] - (@this a b)) + ((vars/getDirectRoot this) a b)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c] - (@this a b c)) + ((vars/getDirectRoot this) a b c)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d] - (@this a b c d)) + ((vars/getDirectRoot this) a b c d)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d e] - (@this a b c d e)) + ((vars/getDirectRoot this) a b c d e)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d e f] - (@this a b c d e f)) + ((vars/getDirectRoot this) a b c d e f)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d e f g] - (@this a b c d e f g)) + ((vars/getDirectRoot this) a b c d e f g)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d e f g h] - (@this a b c d e f g h)) + ((vars/getDirectRoot this) a b c d e f g h)) (#?(:cljd -invoke :clj invoke :cljs -invoke) [this a b c d e f g h i] - (@this a b c d e f g h i)) + ((vars/getDirectRoot this) a b c d e f g h i)) #?@(:cljd [(-invoke-more [this a b c d e f g h i rest] - (apply @this a b c d e f g h i rest)) + (apply (vars/getDirectRoot this) a b c d e f g h i rest)) (-apply [this args] - (apply @this args))] + (apply (vars/getDirectRoot this) args))] :clj [(invoke [this a b c d e f g h i j] - (@this a b c d e f g h i j)) + ((vars/getDirectRoot this) a b c d e f g h i j)) (invoke [this a b c d e f g h i j k] - (@this a b c d e f g h i j k)) + ((vars/getDirectRoot this) a b c d e f g h i j k)) (invoke [this a b c d e f g h i j k l] - (@this a b c d e f g h i j k l)) + ((vars/getDirectRoot this) a b c d e f g h i j k l)) (invoke [this a b c d e f g h i j k l m] - (@this a b c d e f g h i j k l m)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m)) (invoke [this a b c d e f g h i j k l m n] - (@this a b c d e f g h i j k l m n)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n)) (invoke [this a b c d e f g h i j k l m n o] - (@this a b c d e f g h i j k l m n o)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o)) (invoke [this a b c d e f g h i j k l m n o p] - (@this a b c d e f g h i j k l m n o p)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p)) (invoke [this a b c d e f g h i j k l m n o p q] - (@this a b c d e f g h i j k l m n o p q)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q)) (invoke [this a b c d e f g h i j k l m n o p q r] - (@this a b c d e f g h i j k l m n o p q r)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r)) (invoke [this a b c d e f g h i j k l m n o p q r s] - (@this a b c d e f g h i j k l m n o p q r s)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s)) (invoke [this a b c d e f g h i j k l m n o p q r s t] - (@this a b c d e f g h i j k l m n o p q r s t)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s t)) (invoke [this a b c d e f g h i j k l m n o p q r s t rest] - (apply @this a b c d e f g h i j k l m n o p q r s t rest)) + (apply (vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s t rest)) (applyTo [this args] - (apply @this args))] + (apply (vars/getDirectRoot this) args))] :cljs [(-invoke [this a b c d e f g h i j] - (@this a b c d e f g h i j)) + ((vars/getDirectRoot this) a b c d e f g h i j)) (-invoke [this a b c d e f g h i j k] - (@this a b c d e f g h i j k)) + ((vars/getDirectRoot this) a b c d e f g h i j k)) (-invoke [this a b c d e f g h i j k l] - (@this a b c d e f g h i j k l)) + ((vars/getDirectRoot this) a b c d e f g h i j k l)) (-invoke [this a b c d e f g h i j k l m] - (@this a b c d e f g h i j k l m)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m)) (-invoke [this a b c d e f g h i j k l m n] - (@this a b c d e f g h i j k l m n)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n)) (-invoke [this a b c d e f g h i j k l m n o] - (@this a b c d e f g h i j k l m n o)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o)) (-invoke [this a b c d e f g h i j k l m n o p] - (@this a b c d e f g h i j k l m n o p)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p)) (-invoke [this a b c d e f g h i j k l m n o p q] - (@this a b c d e f g h i j k l m n o p q)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q)) (-invoke [this a b c d e f g h i j k l m n o p q r] - (@this a b c d e f g h i j k l m n o p q r)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r)) (-invoke [this a b c d e f g h i j k l m n o p q r s] - (@this a b c d e f g h i j k l m n o p q r s)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s)) (-invoke [this a b c d e f g h i j k l m n o p q r s t] - (@this a b c d e f g h i j k l m n o p q r s t)) + ((vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s t)) (-invoke [this a b c d e f g h i j k l m n o p q r s t rest] - (apply @this a b c d e f g h i j k l m n o p q r s t rest))])) + (apply (vars/getDirectRoot this) a b c d e f g h i j k l m n o p q r s t rest))])) #?(:cljd nil :clj diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 77dc1e5f..00d64ac8 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -1193,7 +1193,7 @@ (realized? d) (= 1 @d)])")))) (deftest forked-delay-state-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(def effects (atom [])) @@ -1463,8 +1463,38 @@ #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error) #"Unable to resolve symbol: y" (sci/eval-string* ctx "y")))))) +(deftest runtime-mode-test + (testing "standard is the default and keeps the historical namespace fork" + (let [ctx (sci/init nil) + child (sci/fork ctx)] + (is (= :standard (:runtime-mode ctx))) + (is (nil? (:sci.impl/world ctx))) + (is (= 1 (sci/eval-string* ctx + "(let [a (atom 0)] (swap! a inc) @a)"))) + (sci/eval-string* child "(def child-only 1)") + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error) + #"Unable to resolve symbol: child-only" + (sci/eval-string* ctx "child-only"))))) + (testing "forkability is explicit and cannot change during merge" + (let [ctx (tu/forkable-init nil)] + (is (= :forkable (:runtime-mode ctx))) + (is (some? (:sci.impl/world ctx))) + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo + :clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) + #"cannot be changed" + (sci/merge-opts ctx {:runtime-mode :standard}))))) + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo + :clj clojure.lang.ExceptionInfo + :cljs ExceptionInfo) + #"Invalid SCI runtime mode" + (sci/init {:runtime-mode :unknown})))) + (deftest forked-world-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(def x 1) @@ -1517,7 +1547,7 @@ (is (= [1 10 0 0 20] (sci/eval-string* parent "(world-value)")))))))) (deftest first-fork-realizes-mutable-primary-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(def x 1) @@ -1547,7 +1577,7 @@ (is (= [2 5 9 true] (sci/eval-string* grandchild "(state)"))))))) (deftest forked-atom-control-state-test - (let [parent (sci/init nil) + (let [parent (tu/forkable-init nil) a (sci/eval-string* parent "(def events (atom [])) @@ -1584,7 +1614,7 @@ (sci/eval-string* child "[@a @events]")))))) (deftest forked-memoize-cache-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (is (= [[:shared 1] [:shared 1] 1] (sci/eval-string* parent @@ -1616,7 +1646,7 @@ resource (->ForkableState (atom 0) copies) state-var (sci/new-var 'state resource {:ns user-ns}) alias-var (sci/new-var 'state-alias resource {:ns user-ns}) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'state state-var 'state-alias alias-var}} :fork-fn (fn [value] @@ -1640,7 +1670,7 @@ (let [user-ns (sci/create-ns 'user) resource (->ProhibitedState :socket) resource-var (sci/new-var 'resource resource {:ns user-ns}) - parent (sci/init {:namespaces {'user {'resource resource-var}}}) + parent (tu/forkable-init {:namespaces {'user {'resource resource-var}}}) result (try (sci/fork parent) ::not-thrown @@ -1651,7 +1681,7 @@ (is (= :socket result)))) (deftest affine-transient-fork-policy-test - (let [parent (sci/init nil) + (let [parent (tu/forkable-init nil) transient-value (sci/eval-string* parent "(def working (transient [])) working")] (is (thrown-with-msg? @@ -1667,7 +1697,7 @@ #?(:cljd nil :default (deftest forked-array-state-test - (let [parent (sci/init nil) + (let [parent (tu/forkable-init nil) parent-array (sci/eval-string* parent "(def buffer (object-array [1 2])) @@ -1694,7 +1724,7 @@ copies (atom 0) state-var (sci/new-var 'host-state host-state {:ns user-ns}) alias-var (sci/new-var 'host-state-alias host-state {:ns user-ns}) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'host-state state-var 'host-state-alias alias-var}}})] @@ -1721,7 +1751,7 @@ #?(:clj (deftest affine-host-resource-fork-policy-test (testing "lazy realization is rejected" - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(def pending-xs (map inc [1 2 3]))") (try (sci/fork parent) @@ -1737,7 +1767,7 @@ [(java.util.Random. 42) :random-generator] [(java.util.ArrayList.) :java-collection]]] (let [user-ns (sci/create-ns 'user) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'resource (sci/new-var 'resource resource @@ -1752,7 +1782,7 @@ (let [task (java.util.concurrent.FutureTask. (fn [] :done)) _ (.run task) user-ns (sci/create-ns 'user) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'task (sci/new-var 'task task {:ns user-ns})}}}) child (sci/fork parent)] @@ -1763,7 +1793,7 @@ (deftest affine-js-resource-fork-policy-test (let [promise (js/Promise.resolve 1) user-ns (sci/create-ns 'user) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'promise (sci/new-var 'promise promise {:ns user-ns})}}})] @@ -1780,7 +1810,7 @@ (deftest fork-host-value-cooperation-test (let [user-ns (sci/create-ns 'user) state-var (sci/new-var 'state (atom 0) {:ns user-ns}) - parent (sci/init + parent (tu/forkable-init {:namespaces {'user {'state state-var}} :fork-fn #(if (instance? clojure.lang.Atom %) (atom @%) @@ -1795,7 +1825,7 @@ (deftest fork-waits-for-active-evaluation-test (let [entered (promise) release (promise) - parent (sci/init {:bindings {'block! (fn [] + parent (tu/forkable-init {:bindings {'block! (fn [] (deliver entered true) @release)}}) evaluation (future (sci/eval-string* parent "(block!)"))] @@ -1811,7 +1841,7 @@ (let [n 1000 a-calls (atom 0) b-calls (atom 0) - parent (sci/init + parent (tu/forkable-init {:bindings {'step-a (fn [x] (swap! a-calls inc) (inc x)) 'step-b (fn [x] (swap! b-calls inc) (inc x))}})] diff --git a/test/sci/defrecords_and_deftype_test.cljc b/test/sci/defrecords_and_deftype_test.cljc index d2c7066a..a998ee29 100644 --- a/test/sci/defrecords_and_deftype_test.cljc +++ b/test/sci/defrecords_and_deftype_test.cljc @@ -280,7 +280,7 @@ (is (= "user.Dude" (tu/eval* "(deftype Dude []) (str Dude)" {})))) (deftest forked-deftype-instance-state-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(defprotocol IForkBox (bump! [_]) (box-value [_])) @@ -302,7 +302,7 @@ (is (= 1 (sci/eval-string* parent "(box-value box)")))))) (deftest forked-captured-deftype-state-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(defprotocol ICapturedForkBox (captured-bump! [_])) @@ -320,7 +320,7 @@ (is (= 1 (sci/eval-string* parent "(captured-bump)")))))) (deftest forked-type-metadata-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(deftype ForkMeta []) diff --git a/test/sci/interrupt_fn_test.cljc b/test/sci/interrupt_fn_test.cljc index ac1b08fb..3afb72b7 100644 --- a/test/sci/interrupt_fn_test.cljc +++ b/test/sci/interrupt_fn_test.cljc @@ -2,7 +2,8 @@ (:require [clojure.test :refer [deftest is testing]] [sci.core :as sci] - [sci.interrupt :as interrupt])) + [sci.interrupt :as interrupt] + [sci.test-utils :as tu])) (defn limit-interrupt "Signals via a plain ex-info. Sandboxed code can catch this. Used to test the diff --git a/test/sci/jit_test.cljs b/test/sci/jit_test.cljs index 3a053f76..c1e57701 100644 --- a/test/sci/jit_test.cljs +++ b/test/sci/jit_test.cljs @@ -5,7 +5,8 @@ (:require [clojure.string :as str] [clojure.test :as t :refer [deftest is testing]] [sci.core :as sci] - [sci.impl.jit :as jit])) + [sci.impl.jit :as jit] + [sci.test-utils :as tu])) ;; strict compile: an emitter exception must fail the test, not hide behind ;; a silent interpreter fallback (which the differential checks can't see, @@ -262,7 +263,7 @@ (is (= {:val expected} jitted) src)))) (deftest jit-fork-world-test - (let [parent (sci/init {})] + (let [parent (tu/forkable-init {})] (sci/eval-string* parent "(def x 1) (defn f [] 1) (defn call [] [(f) x])") diff --git a/test/sci/multimethods_test.cljc b/test/sci/multimethods_test.cljc index f640f987..19d2d896 100644 --- a/test/sci/multimethods_test.cljc +++ b/test/sci/multimethods_test.cljc @@ -57,7 +57,7 @@ ")))) (deftest forked-multimethod-state-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(defmulti branch-method identity) diff --git a/test/sci/namespaces_test.cljc b/test/sci/namespaces_test.cljc index eb4a9d68..f45fba20 100644 --- a/test/sci/namespaces_test.cljc +++ b/test/sci/namespaces_test.cljc @@ -144,7 +144,7 @@ (eval* "(ns ^{:a 1} foo {:b 1}) (meta *ns*) (ns bar) (meta (the-ns 'foo))")))) (deftest forked-namespace-metadata-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(ns fork.meta {:branch :parent})") (let [child (sci/fork parent)] (is (identical? (sci/find-ns parent 'fork.meta) @@ -428,7 +428,7 @@ bar/bar"} :file "foo/bar.clj"}))}))))) (deftest forked-loaded-libs-test - (let [parent (sci/init + (let [parent (tu/forkable-init {:load-fn (fn [{:keys [:namespace]}] (when (= 'fork.loaded namespace) diff --git a/test/sci/native_protocols_test.cljs b/test/sci/native_protocols_test.cljs index 86fd42e2..598505fc 100644 --- a/test/sci/native_protocols_test.cljs +++ b/test/sci/native_protocols_test.cljs @@ -1,7 +1,8 @@ (ns sci.native-protocols-test (:require [clojure.test :refer [deftest is testing]] [sci.core :as sci] - [sci.protocol-lib :as plib])) + [sci.protocol-lib :as plib] + [sci.test-utils :as tu])) (def cljs-core-ns (sci/create-ns 'cljs.core)) @@ -148,7 +149,7 @@ f")] [(get f :a) (satisfies? ILookup f)]"))))) (deftest forked-native-protocol-extension-test - (let [parent (sci/init opts)] + (let [parent (tu/forkable-init opts)] (sci/eval-string* parent "(deftype ForkNative []) @@ -163,7 +164,7 @@ f")] (is (= 1 (sci/eval-string* parent "(count fork-native)")))))) (deftest forked-record-native-protocol-extension-test - (let [parent (sci/init opts)] + (let [parent (tu/forkable-init opts)] (sci/eval-string* parent "(defrecord ForkNativeRecord []) diff --git a/test/sci/test_utils.cljc b/test/sci/test_utils.cljc index 54fa438f..5834ebce 100644 --- a/test/sci/test_utils.cljc +++ b/test/sci/test_utils.cljc @@ -18,6 +18,9 @@ (when native? (println "Testing native version.")) +(defn forkable-init [opts] + (sci.core/init (assoc (or opts {}) :runtime-mode :forkable))) + (defn eval* [form ctx] (if (not native?) (#?(:cljd sci/eval-string :default eval-string) (str form) ctx) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index b5e7d439..577c30a1 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -115,7 +115,7 @@ (addons/future {}))))) (deftest forked-future-uses-child-world-test - (let [parent (sci/init (addons/future {}))] + (let [parent (tu/forkable-init (addons/future {}))] (sci/eval-string* parent "(def state (atom 0)) @@ -134,7 +134,7 @@ (deftest forked-future-participates-in-world-quiescence-test (let [entered (promise) release (promise) - parent (sci/init + parent (tu/forkable-init (addons/future {:bindings {'block! (fn [] (deliver entered true) @@ -174,7 +174,7 @@ {:classes {'java.lang.Thread java.lang.Thread}})))) (deftest forked-bound-fn-uses-child-world-test - (let [parent (sci/init {})] + (let [parent (tu/forkable-init {})] (sci/eval-string* parent "(def state (atom 0)) @@ -217,7 +217,7 @@ (deftest world-scoped-dynamic-binding-test (let [parent-holder (atom nil) - parent (sci/init + parent (tu/forkable-init {:bindings {'read-parent #(sci/eval-string* @parent-holder "late")}})] (reset! parent-holder parent) @@ -288,7 +288,7 @@ (deftest forked-promise-state-test (when-not tu/native? (let [entered (promise) - parent (sci/init + parent (tu/forkable-init (-> (addons/future {}) (assoc :bindings {'mark-entered @@ -408,7 +408,7 @@ ":o 1 :n 5"))) (deftest forked-var-watch-test - (let [parent (sci/init nil)] + (let [parent (tu/forkable-init nil)] (sci/eval-string* parent "(def effects (atom [])) From 8ef4d70c7c001709564908892e858d6d129c1740 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 13:45:13 -0700 Subject: [PATCH 23/31] Add forkable continuation contexts --- API.md | 246 +++++++++++++++++++++----------- CHANGELOG.md | 6 + doc/forking.md | 14 ++ src/sci/core.cljc | 36 +++++ src/sci/impl/analyzer.cljc | 3 +- src/sci/impl/execution.cljc | 32 ++++- src/sci/impl/fns.cljc | 88 ++++++------ src/sci/impl/multimethods.cljc | 14 +- src/sci/impl/refs.cljc | 112 ++++++++------- src/sci/impl/vars.cljc | 150 ++++++++++++++++--- src/sci/impl/world.cljc | 117 ++++++++------- test/sci/core_test.cljc | 18 ++- test/sci/multimethods_test.cljc | 87 +++++++---- test/sci/vars_test.cljc | 150 +++++++++++++++++++ 14 files changed, 783 insertions(+), 290 deletions(-) diff --git a/API.md b/API.md index 15381ab3..2e22f071 100644 --- a/API.md +++ b/API.md @@ -25,11 +25,14 @@ needing something from the dark `impl` side! - [`alter-var-root`](#sci.core/alter-var-root) - Atomically alters the root binding of sci var v by applying f to its current value plus any args. - [`assert`](#sci.core/assert) - SCI var that represents SCI's clojure.core/*assert*. - [`binding`](#sci.core/binding) - Macro for binding sci vars. + - [`capture-continuation-context`](#sci.core/capture-continuation-context) - Capture the active SCI context and dynamic bindings for later continuation resumption. + - [`continuation-context-fn`](#sci.core/continuation-context-fn) - Return a function that invokes f with the SCI world and dynamic bindings represented by continuation-context. - [`copy-ns`](#sci.core/copy-ns) - Returns map of names to SCI vars as a result of copying public Clojure vars from ns-sym (a symbol). - [`copy-var`](#sci.core/copy-var) - Copies contents from var sym to a new sci var. - [`copy-var*`](#sci.core/copy-var*) - Copies Clojure var to SCI var. - [`create-ns`](#sci.core/create-ns) - Creates namespace object. - - [`enable-unrestricted-access!`](#sci.core/enable-unrestricted-access!) - Calling this will enable - Altering core vars using alter-var-root - In CLJS: set! is able to set the value of any var. + - [`disable-jit`](#sci.core/disable-jit) + - [`enable-unrestricted-access!`](#sci.core/enable-unrestricted-access!) - Removed. - [`err`](#sci.core/err) - SCI var that represents SCI's clojure.core/*err*. - [`eval-form`](#sci.core/eval-form) - Evaluates form (as produced by parse-string or parse-next) in the context of ctx (as produced with init). - [`eval-string`](#sci.core/eval-string) - Evaluates string s as one or multiple Clojure expressions using the Small Clojure Interpreter. @@ -37,7 +40,7 @@ needing something from the dark `impl` side! - [`eval-string+`](#sci.core/eval-string+) - Evaluates string s in the context of ctx (as produced with init). - [`file`](#sci.core/file) - SCI var that represents SCI's clojure.core/*file*. - [`find-ns`](#sci.core/find-ns) - Returns SCI ns object as created with sci/create-ns from ctx found by ns-sym. - - [`fork`](#sci.core/fork) - Forks a context (as produced with init) into a new context. + - [`fork`](#sci.core/fork) - Forks a context (as produced with init) into an isolated runtime world. - [`format-stacktrace`](#sci.core/format-stacktrace) - Returns a list of formatted stack trace elements as strings from stacktrace. - [`future`](#sci.core/future) - Like clojure.core/future but also conveys sci bindings to the thread. - [`get-column-number`](#sci.core/get-column-number) @@ -69,11 +72,13 @@ needing something from the dark `impl` side! - [`read-eval`](#sci.core/read-eval) - SCI var that represents SCI's clojure.core/*read-eval*. - [`reader`](#sci.core/reader) - Coerces x into indexing pushback-reader to be used with parse-next. - [`resolve`](#sci.core/resolve) + - [`retarget-continuation-context`](#sci.core/retarget-continuation-context) - Copy a captured continuation context for target-ctx, which must belong to the same SCI lineage. - [`set!`](#sci.core/set!) - Establish thread local binding of dynamic var. - [`source-reader`](#sci.core/source-reader) - [`stacktrace`](#sci.core/stacktrace) - Returns list of stacktrace element maps from exception, if available. - [`var->symbol`](#sci.core/var->symbol) - Returns a fully qualified symbol from a sci.lang.Var. - [`with-bindings`](#sci.core/with-bindings) - Macro for binding sci vars. + - [`with-detached-context`](#sci.core/with-detached-context) - Invoke zero-argument f outside the currently executing SCI context. - [`with-in-str`](#sci.core/with-in-str) - Evaluates body in a context in which sci's *in* is bound to a fresh StringReader initialized with the string s. - [`with-out-str`](#sci.core/with-out-str) - Evaluates exprs in a context in which sci's *out* is bound to a fresh StringWriter. - [`sci.ctx-store`](#sci.ctx-store) - Canonical place for projects to store, update and retrieve a context. @@ -180,25 +185,25 @@ The main SCI API namespace. -

Source

+

Source

## `*2` -

Source

+

Source

## `*3` -

Source

+

Source

## `*e` -

Source

+

Source

## `add-class!` ``` clojure @@ -209,7 +214,7 @@ Function. Adds class (JVM class or JS object) to `ctx` as `class-name` (a symbol). Returns mutated context. -

Source

+

Source

## `add-import!` ``` clojure @@ -219,7 +224,7 @@ Adds class (JVM class or JS object) to `ctx` as `class-name` (a Function. Adds import of class named by `class-name` (a symbol) to namespace named by [`ns-name`](#sci.core/ns-name) (a symbol) under alias `alias` (a symbol). Returns mutated context. -

Source

+

Source

## `add-js-lib!` ``` clojure @@ -229,7 +234,7 @@ Adds import of class named by `class-name` (a symbol) to namespace named by [`ns Function. Add js library to context, so it can be used with `require`. -

Source

+

Source

## `add-namespace!` ``` clojure @@ -240,7 +245,7 @@ Function. Adds namespace map `ns-map` named by the symbol [`ns-name`](#sci.core/ns-name) to `ctx`. Returns mutated context. -

Source

+

Source

## `all-ns` ``` clojure @@ -250,7 +255,7 @@ Adds namespace map `ns-map` named by the symbol [`ns-name`](#sci.core/ns-name) t Function. Returns all SCI ns objects in the `ctx` -

Source

+

Source

## `alter-var-root` ``` clojure @@ -262,7 +267,7 @@ Function. Atomically alters the root binding of sci var v by applying f to its current value plus any args. -

Source

+

Source

## `assert` @@ -270,7 +275,7 @@ Atomically alters the root binding of sci var v by applying f to its SCI var that represents SCI's clojure.core/*assert* -

Source

+

Source

## `binding` ``` clojure @@ -281,7 +286,34 @@ Macro. Macro for binding sci vars. Must be called with a vector of sci dynamic vars to values. -

Source

+

Source

+ +## `capture-continuation-context` +``` clojure + +(capture-continuation-context) +(capture-continuation-context ctx) +``` +Function. + +Capture the active SCI context and dynamic bindings for later continuation + resumption. Must be called from managed SCI evaluation. The returned token is + opaque; use [`continuation-context-fn`](#sci.core/continuation-context-fn) to resume through it. + + The explicit `ctx` arity is for host embedding boundaries invoked through an + interpreted function after the top-level evaluation has returned. +

Source

+ +## `continuation-context-fn` +``` clojure + +(continuation-context-fn continuation-context f) +``` +Function. + +Return a function that invokes `f` with the SCI world and dynamic bindings + represented by `continuation-context`. +

Source

## `copy-ns` ``` clojure @@ -312,7 +344,7 @@ Returns map of names to SCI vars as a result of copying public important for ClojureScript to not pull in vars into the compiled JS. Any additional vars can be added after the fact with sci/copy-var manually. -

Source

+

Source

## `copy-var` ``` clojure @@ -325,13 +357,19 @@ Macro. Copies contents from var `sym` to a new sci var. The value [`ns`](#sci.core/ns) is an object created with [`sci.core/create-ns`](#sci.core/create-ns). - Options: + On ClojureScript, when `sym` names a protocol (except `cljs.core/IFn`), + the sci var holds a protocol entry instead of the raw protocol object. + Sci code can then implement the protocol on `deftype` types, extend those + with `extend-type` and use `satisfies?`. Host code calling protocol + methods on such instances dispatches into the sci implementations. + + Options (ignored for protocols): - `:name`: The name of the copied var. Defaults to the original var name. - `:copy-meta-from`: A symbol resolving to a var whose metadata (`:doc`, `:arglists`, `:file`, `:line`, `:column`) is used instead of `sym`'s. Useful for wrapper vars that delegate to another var. -

Source

+

Source

## `copy-var*` ``` clojure @@ -341,7 +379,7 @@ Copies contents from var `sym` to a new sci var. The value [`ns`](#sci.core/ns) Function. Copies Clojure var to SCI var. Runtime analog of compile time [`copy-var`](#sci.core/copy-var). -

Source

+

Source

## `create-ns` ``` clojure @@ -352,7 +390,13 @@ Copies Clojure var to SCI var. Runtime analog of compile time [`copy-var`](#sci. Function. Creates namespace object. Can be used in var metadata. -

Source

+

Source

+ +## `disable-jit` + + + +

Source

## `enable-unrestricted-access!` ``` clojure @@ -361,13 +405,9 @@ Creates namespace object. Can be used in var metadata. ``` Function. -Calling this will enable - - Altering core vars using [`alter-var-root`](#sci.core/alter-var-root) - - In CLJS: [`set!`](#sci.core/set!) is able to set the value of any var. - - In CLJS: instance method calls are not restricted to only `:classes` - - In the future, more unrestricted access may be added, so only use this when you're not using SCI as a sandbox. -

Source

+Removed. Use the `:unrestricted` option of [`init`](#sci.core/init) or [`eval-string`](#sci.core/eval-string) + instead. Throws when called. +

Source

## `err` @@ -375,7 +415,7 @@ Calling this will enable SCI var that represents SCI's `clojure.core/*err*` -

Source

+

Source

## `eval-form` ``` clojure @@ -388,7 +428,7 @@ Evaluates form (as produced by [`parse-string`](#sci.core/parse-string) or [`par context of `ctx` (as produced with [`init`](#sci.core/init)). To allow namespace switches, establish root binding of `sci/ns` with `sci/binding` or `sci/with-bindings.` -

Source

+

Source

## `eval-string` ``` clojure @@ -419,8 +459,22 @@ Evaluates string `s` as one or multiple Clojure expressions using the Small Cloj - `:interrupt-fn`: a zero-arg fn called on every interpreted `fn` entry / `loop` entry + - `:unrestricted`: when `true`, evaluated code may mutate built-in vars + and CLJS instance interop skips `:classes` checks. Off by default. + Applies only to this context: a context created during an unrestricted + evaluation is sandboxed unless it also gets this option. + + - `:fork-fn`: optional one-argument host function used by [`fork`](#sci.core/fork) to copy + values held in SCI world cells that do not implement `sci.fork/Forkable` and + need application-specific isolation. SCI-owned mutable primitives are + already world-relative and retain identity. + + - `:runtime-mode`: `:standard` (the default) retains SCI's direct hot paths. + `:forkable` enables isolated runtime worlds for Vars, dynamic bindings and + SCI-owned mutable primitives. + - `:bindings`: DEPRECATED - `:bindings x` is the same as `:namespaces {'user x}`. -

Source

+

Source

## `eval-string*` ``` clojure @@ -431,7 +485,7 @@ Function. Evaluates string `s` in the context of `ctx` (as produced with [`init`](#sci.core/init)). -

Source

+

Source

## `eval-string+` ``` clojure @@ -450,7 +504,7 @@ Evaluates string `s` in the context of `ctx` (as produced with Returns map with: * `:val` - the evaluated value * `:ns` - the namespace object -

Source

+

Source

## `file` @@ -458,7 +512,7 @@ Evaluates string `s` in the context of `ctx` (as produced with SCI var that represents SCI's `clojure.core/*file*` -

Source

+

Source

## `find-ns` ``` clojure @@ -468,19 +522,23 @@ SCI var that represents SCI's `clojure.core/*file*` Function. Returns SCI ns object as created with `sci/create-ns` from `ctx` found by `ns-sym`. -

Source

+

Source

## `fork` ``` clojure (fork ctx) +(fork ctx opts) ``` Function. -Forks a context (as produced with [`init`](#sci.core/init)) into a new context. Any new - vars created in the new context won't be visible in the original - context. -

Source

+Forks a context (as produced with [`init`](#sci.core/init)) into an isolated runtime world. + + Existing SCI Vars and SCI-created mutable primitives retain identity, but + their values diverge after the fork. Host values may implement + `sci.fork/Forkable`; `opts` may contain `:fork-fn`, which overrides the + context's fallback function for other application-specific host values. +

Source

## `format-stacktrace` ``` clojure @@ -490,7 +548,7 @@ Forks a context (as produced with [`init`](#sci.core/init)) into a new context. Function. Returns a list of formatted stack trace elements as strings from stacktrace. -

Source

+

Source

## `future` ``` clojure @@ -500,7 +558,7 @@ Returns a list of formatted stack trace elements as strings from stacktrace. Macro. Like clojure.core/future but also conveys sci bindings to the thread. -

Source

+

Source

## `get-column-number` ``` clojure @@ -508,7 +566,7 @@ Like clojure.core/future but also conveys sci bindings to the thread. (get-column-number reader) ``` Function. -

Source

+

Source

## `get-line-number` ``` clojure @@ -516,7 +574,7 @@ Function. (get-line-number reader) ``` Function. -

Source

+

Source

## `in` @@ -524,7 +582,7 @@ Function. SCI var that represents SCI's `clojure.core/*in*` -

Source

+

Source

## `init` ``` clojure @@ -537,7 +595,7 @@ Creates an initial sci context from given options `opts`. The context can be used with [`eval-string*`](#sci.core/eval-string*). See [`eval-string`](#sci.core/eval-string) for available options. The internal organization of the context is implementation detail and may change in the future. -

Source

+

Source

## `intern` ``` clojure @@ -552,7 +610,7 @@ Finds or creates a sci var named by the symbol name in the namespace binding to val if supplied. The namespace must exist in the ctx. The sci var will adopt any metadata from the name symbol. Returns the sci var. -

Source

+

Source

## `merge-opts` ``` clojure @@ -562,7 +620,7 @@ Finds or creates a sci var named by the symbol name in the namespace Function. Updates a context with opts merged in and returns it. -

Source

+

Source

## `new-dynamic-var` ``` clojure @@ -574,7 +632,7 @@ Updates a context with opts merged in and returns it. Function. Same as new-var but adds :dynamic true to meta. -

Source

+

Source

## `new-macro-var` ``` clojure @@ -586,7 +644,7 @@ Function. Same as new-var but adds :macro true to meta as well as :sci/macro true to meta of the fn itself. -

Source

+

Source

## `new-var` ``` clojure @@ -598,7 +656,7 @@ Same as new-var but adds :macro true to meta as well Function. Returns a new sci var. -

Source

+

Source

## `normalize-meta` ``` clojure @@ -606,7 +664,7 @@ Returns a new sci var. (normalize-meta m) ``` Function. -

Source

+

Source

## `ns` @@ -614,7 +672,7 @@ Function. SCI var that represents SCI's `clojure.core/*ns*` -

Source

+

Source

## `ns-name` ``` clojure @@ -624,7 +682,7 @@ SCI var that represents SCI's `clojure.core/*ns*` Function. Returns name of SCI ns as symbol. -

Source

+

Source

## `out` @@ -632,7 +690,7 @@ Returns name of SCI ns as symbol. SCI var that represents SCI's `clojure.core/*out*` -

Source

+

Source

## `parse-next` ``` clojure @@ -643,7 +701,7 @@ SCI var that represents SCI's `clojure.core/*out*` Function. Parses next form from reader -

Source

+

Source

## `parse-next+string` ``` clojure @@ -654,7 +712,7 @@ Parses next form from reader Function. Parses next form from reader -

Source

+

Source

## `parse-string` ``` clojure @@ -665,7 +723,7 @@ Function. Parses string `s` in the context of `ctx` (as produced with [`init`](#sci.core/init)). -

Source

+

Source

## `pmap` ``` clojure @@ -676,7 +734,7 @@ Parses string `s` in the context of `ctx` (as produced with Function. Like clojure.core/pmap but also conveys sci bindings to the threads. -

Source

+

Source

## `print-dup` @@ -684,7 +742,7 @@ Like clojure.core/pmap but also conveys sci bindings to the threads. SCI var that represents SCI's `clojure.core/*print-dup*` -

Source

+

Source

## `print-err-fn` @@ -692,7 +750,7 @@ SCI var that represents SCI's `clojure.core/*print-dup*` SCI var that represents SCI's `cljs.core/*print-err-fn*` -

Source

+

Source

## `print-fn` @@ -700,7 +758,7 @@ SCI var that represents SCI's `cljs.core/*print-err-fn*` SCI var that represents SCI's `cljs.core/*print-fn*` -

Source

+

Source

## `print-length` @@ -708,7 +766,7 @@ SCI var that represents SCI's `cljs.core/*print-fn*` SCI var that represents SCI's `clojure.core/*print-length*` -

Source

+

Source

## `print-level` @@ -716,7 +774,7 @@ SCI var that represents SCI's `clojure.core/*print-length*` SCI var that represents SCI's `clojure.core/*print-level*` -

Source

+

Source

## `print-meta` @@ -724,7 +782,7 @@ SCI var that represents SCI's `clojure.core/*print-level*` SCI var that represents SCI's `clojure.core/*print-meta*` -

Source

+

Source

## `print-namespace-maps` @@ -732,7 +790,7 @@ SCI var that represents SCI's `clojure.core/*print-meta*` SCI var that represents SCI's `clojure.core/*print-namespace-maps*` -

Source

+

Source

## `print-newline` @@ -740,7 +798,7 @@ SCI var that represents SCI's `clojure.core/*print-namespace-maps*` SCI var that represents SCI's `cljs.core/*print-newline*` -

Source

+

Source

## `print-readably` @@ -748,7 +806,7 @@ SCI var that represents SCI's `cljs.core/*print-newline*` SCI var that represents SCI's `clojure.core/*print-readably*` -

Source

+

Source

## `read-eval` @@ -756,7 +814,7 @@ SCI var that represents SCI's `clojure.core/*print-readably*` SCI var that represents SCI's `clojure.core/*read-eval*` -

Source

+

Source

## `reader` ``` clojure @@ -767,7 +825,7 @@ Function. Coerces x into indexing pushback-reader to be used with parse-next. Accepts: string or java.io.Reader. -

Source

+

Source

## `resolve` ``` clojure @@ -775,7 +833,18 @@ Coerces x into indexing pushback-reader to be used with (resolve ctx sym) ``` Function. -

Source

+

Source

+ +## `retarget-continuation-context` +``` clojure + +(retarget-continuation-context continuation-context target-ctx) +``` +Function. + +Copy a captured continuation context for `target-ctx`, which must belong to + the same SCI lineage. The copy has independent dynamic binding boxes. +

Source

## `set!` ``` clojure @@ -785,7 +854,7 @@ Function. Function. Establish thread local binding of dynamic var -

Source

+

Source

## `source-reader` ``` clojure @@ -793,7 +862,7 @@ Establish thread local binding of dynamic var (source-reader x) ``` Function. -

Source

+

Source

## `stacktrace` ``` clojure @@ -803,7 +872,7 @@ Function. Function. Returns list of stacktrace element maps from exception, if available. -

Source

+

Source

## `var->symbol` ``` clojure @@ -813,7 +882,7 @@ Returns list of stacktrace element maps from exception, if available. Function. Returns a fully qualified symbol from a `sci.lang.Var` -

Source

+

Source

## `with-bindings` ``` clojure @@ -824,7 +893,22 @@ Macro. Macro for binding sci vars. Must be called with map of sci dynamic vars to values. Used in babashka. -

Source

+

Source

+ +## `with-detached-context` +``` clojure + +(with-detached-context f) +``` +Function. + +Invoke zero-argument `f` outside the currently executing SCI context. + + Embeddings use this host boundary when interpreted code recursively creates + an independent SCI interpreter. The caller's active world and dynamic + binding frame are restored even when `f` throws. Ordinary nested evaluation + of an existing context does not need this function. +

Source

## `with-in-str` ``` clojure @@ -835,7 +919,7 @@ Macro. Evaluates body in a context in which sci's *in* is bound to a fresh StringReader initialized with the string s. -

Source

+

Source

## `with-out-str` ``` clojure @@ -847,7 +931,7 @@ Macro. Evaluates exprs in a context in which sci's *out* is bound to a fresh StringWriter. Returns the string created by any nested printing calls. -

Source

+

Source

----- # sci.ctx-store @@ -855,8 +939,8 @@ Evaluates exprs in a context in which sci's *out* is bound to a fresh Canonical place for projects to store, update and retrieve a context. This can be used by projects that need to expose their context to - functions. SCI does not populate this dynamic var itself during - evaluation. Projects like `sci.configs` assume this var to be set in + functions. SCI binds this dynamic var to the evaluating context during + `eval-form`. Projects like `sci.configs` assume this var to be set in some of their functions. @@ -918,7 +1002,7 @@ Bind `ctx` during execution of body. Representation of a SCI namespace, created e.g. with `(create-ns 'foo)`. The fields of this type are implementation detail and should not be accessed directly. -

Source

+

Source

## `Type` @@ -926,7 +1010,7 @@ Representation of a SCI namespace, created e.g. with `(create-ns 'foo)`. Representation of a SCI custom type, created e.g. with `(defrecord Foo [])`. The fields of this type are implementation detail and should not be accessed directly. -

Source

+

Source

## `Var` @@ -936,7 +1020,7 @@ Representation of a SCI custom type, created e.g. with `(defrecord Foo [])`. The Representation of a SCI var, created e.g. with `(defn foo [])` The fields of this type are implementation detail and should not be accessed directly. -

Source

+

Source

## `notify-watches` ``` clojure @@ -944,4 +1028,4 @@ Representation of a SCI var, created e.g. with `(defn foo [])` (notify-watches ref watches old-val new-val) ``` Function. -

Source

+

Source

diff --git a/CHANGELOG.md b/CHANGELOG.md index 2e2fb2da..6da1934c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,12 @@ SCI is used in [babashka](https://github.com/babashka/babashka), - Caches resolved JVM instance methods per call site for performance - Fix [babashka#2030](https://github.com/babashka/babashka/issues/2030): `aset` on a primitive array was reflective and 170x slower than `aset-double` - Bump edamame to `1.6.43` +- Add forkable interpreter worlds for Vars, namespaces, dynamic bindings, SCI + mutable values, and application-defined host resources. +- Add explicit continuation-context capture and retargeting so an embedding can + resume a suspended computation independently in related forked worlds. +- Add `with-detached-context` for recursively constructing an independent SCI + interpreter without inheriting the caller's execution-local world. ## 0.15.58 diff --git a/doc/forking.md b/doc/forking.md index f7b92043..d04f4042 100644 --- a/doc/forking.md +++ b/doc/forking.md @@ -35,6 +35,13 @@ This shape combines four useful precedents: lineage. - Dynamic binding frames remain thread/evaluation scoped. A fork snapshots root bindings; it does not capture a running continuation or binding frame. +- Hosts that suspend interpreted code can explicitly capture its dynamic + binding frame with `sci/capture-continuation-context`. After forking the SCI + context, `sci/retarget-continuation-context` creates an independent binding + frame for the child world, and `sci/continuation-context-fn` resumes a host + continuation with that world and frame installed. Retargeting is restricted + to the same SCI lineage. Ordinary `sci/fork` still does not implicitly copy + running continuations. - Interpreter bindings are scoped to their world. Managed asynchronous callbacks convey and restore both the selected world and binding frame. - Writes before the first fork have ordinary SCI/Clojure mutable behavior. @@ -61,6 +68,13 @@ one fork and preserves aliases to its result. | Affine or movable authority | Reject the non-destructive fork, or keep authority outside the SCI value world | | Prohibited resource | Throw an explanatory exception from `fork-value` | +An embedding that lets interpreted code construct a new, independent SCI +interpreter should perform that construction through +`sci/with-detached-context`. This temporarily leaves the caller's selected +world and dynamic binding frame, runs the supplied host thunk, and restores the +caller afterwards. Evaluating an existing SCI context recursively does not need +this boundary; it is specifically for creating a separate context lineage. + Only values directly stored in world cells are inspected. A host container that holds mutable children must implement the protocol and copy its own graph. Unclassified values retain the compatibility behavior of being shared, except diff --git a/src/sci/core.cljc b/src/sci/core.cljc index 871dfe8e..e528314c 100644 --- a/src/sci/core.cljc +++ b/src/sci/core.cljc @@ -15,6 +15,7 @@ [sci.ctx-store :as store] [sci.fork :as fork] [sci.impl.callstack :as cs] + [sci.impl.execution :as execution] [sci.impl.interpreter :as i] [sci.impl.io :as sio] [sci.impl.macros :as macros] @@ -58,11 +59,46 @@ (let [meta (assoc meta :dynamic true :name (utils/unqualify-symbol name))] (sci.lang/->Var init-val name meta false false nil (:ns meta) false)))) +(defn with-detached-context + "Invoke zero-argument `f` outside the currently executing SCI context. + + Embeddings use this host boundary when interpreted code recursively creates + an independent SCI interpreter. The caller's active world and dynamic + binding frame are restored even when `f` throws. Ordinary nested evaluation + of an existing context does not need this function." + [f] + (store/with-ctx nil + (execution/call-with-detached-state f))) + (defn set! "Establish thread local binding of dynamic var" [dynamic-var v] (t/setVal dynamic-var v)) +(defn capture-continuation-context + "Capture the active SCI context and dynamic bindings for later continuation + resumption. Must be called from managed SCI evaluation. The returned token is + opaque; use `continuation-context-fn` to resume through it. + + The explicit `ctx` arity is for host embedding boundaries invoked through an + interpreted function after the top-level evaluation has returned." + ([] + (vars/capture-continuation-context)) + ([ctx] + (vars/capture-continuation-context ctx))) + +(defn retarget-continuation-context + "Copy a captured continuation context for `target-ctx`, which must belong to + the same SCI lineage. The copy has independent dynamic binding boxes." + [continuation-context target-ctx] + (vars/retarget-continuation-context continuation-context target-ctx)) + +(defn continuation-context-fn + "Return a function that invokes `f` with the SCI world and dynamic bindings + represented by `continuation-context`." + [continuation-context f] + (vars/continuation-context-fn continuation-context f)) + (defn new-macro-var "Same as new-var but adds :macro true to meta as well as :sci/macro true to meta of the fn itself." diff --git a/src/sci/impl/analyzer.cljc b/src/sci/impl/analyzer.cljc index 951a72fc..78a26951 100644 --- a/src/sci/impl/analyzer.cljc +++ b/src/sci/impl/analyzer.cljc @@ -56,7 +56,8 @@ (declare analyze analyze-children analyze-call return-call return-map) -#?(:clj +#?(:cljd nil + :clj (do (deftype DirectVarNode [^sci.impl.vars.IVar v] sci.impl.types/Eval diff --git a/src/sci/impl/execution.cljc b/src/sci/impl/execution.cljc index 92941de6..260cf350 100644 --- a/src/sci/impl/execution.cljc +++ b/src/sci/impl/execution.cljc @@ -22,9 +22,37 @@ :cljs (def current (volatile! (new-state)))) +(defn call-with-detached-state + "Invoke `f` with an empty execution-local state, restoring the caller's + interpreter state afterwards. This is the host boundary used when an SCI + program constructs an independent interpreter recursively." + [f] + #?(:cljd + (let [previous @current] + (vreset! current (new-state)) + (try + (f) + (finally + (vreset! current previous)))) + :clj + (let [previous (.get ^ThreadLocal current)] + (.set ^ThreadLocal current (new-state)) + (try + (f) + (finally + (.set ^ThreadLocal current previous)))) + :cljs + (let [previous @current] + (vreset! current (new-state)) + (try + (f) + (finally + (vreset! current previous)))))) + (defn current-state [] - #?(:clj (.get ^ThreadLocal current) - :default @current)) + #?(:cljd @current + :clj (.get ^ThreadLocal current) + :cljs @current)) (defn active-world ([] (active-world (current-state))) diff --git a/src/sci/impl/fns.cljc b/src/sci/impl/fns.cljc index 8e5c7c99..0bd00015 100644 --- a/src/sci/impl/fns.cljc +++ b/src/sci/impl/fns.cljc @@ -166,48 +166,52 @@ 19 (gen-fn 19) 20 (gen-fn 20) ;; default case for 20+ args (used by loop) - (if (:sci.impl/world ctx) - (let [recur# recur] - (fn arity-many [& args] - (let [active-ctx (world/active-ctx ctx) - interrupt-fn# (:interrupt-fn active-ctx) - invoc-array (when-not (zero? invoc-size) - #?(:cljd (#/(List/filled dynamic) invoc-size nil) - :default (object-array invoc-size)))] - (when enclosed->invocation - (enclosed->invocation enclosed-array invoc-array)) - (loop [args args i 0] - (when (< i fixed-arity) - (aset #?(:cljd invoc-array - :clj ^objects invoc-array - :cljs ^objects invoc-array) i (first args)) - (recur (next args) (inc i)))) - (loop [] - (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret (types/eval body active-ctx invoc-array)] - (if (identical? recur# ret) - (recur) - ret))))))) - (let [recur# recur - interrupt-fn# (:interrupt-fn ctx)] - (fn arity-many [& args] - (let [invoc-array (when-not (zero? invoc-size) - #?(:cljd (#/(List/filled dynamic) invoc-size nil) - :default (object-array invoc-size)))] - (when enclosed->invocation - (enclosed->invocation enclosed-array invoc-array)) - (loop [args args i 0] - (when (< i fixed-arity) - (aset #?(:cljd invoc-array - :clj ^objects invoc-array - :cljs ^objects invoc-array) i (first args)) - (recur (next args) (inc i)))) - (loop [] - (when-not (nil? interrupt-fn#) (interrupt-fn#)) - (let [ret (types/eval body ctx invoc-array)] - (if (identical? recur# ret) - (recur) - ret))))))))] + ;; ClojureDart's `case` emitter expects a `let`-shaped default; + ;; keeping the mode dispatch inside it also avoids duplicating + ;; this test on every invocation. + (let [forkable? (:sci.impl/world ctx)] + (if forkable? + (let [recur# recur] + (fn arity-many [& args] + (let [active-ctx (world/active-ctx ctx) + interrupt-fn# (:interrupt-fn active-ctx) + invoc-array (when-not (zero? invoc-size) + #?(:cljd (#/(List/filled dynamic) invoc-size nil) + :default (object-array invoc-size)))] + (when enclosed->invocation + (enclosed->invocation enclosed-array invoc-array)) + (loop [args args i 0] + (when (< i fixed-arity) + (aset #?(:cljd invoc-array + :clj ^objects invoc-array + :cljs ^objects invoc-array) i (first args)) + (recur (next args) (inc i)))) + (loop [] + (when-not (nil? interrupt-fn#) (interrupt-fn#)) + (let [ret (types/eval body active-ctx invoc-array)] + (if (identical? recur# ret) + (recur) + ret))))))) + (let [recur# recur + interrupt-fn# (:interrupt-fn ctx)] + (fn arity-many [& args] + (let [invoc-array (when-not (zero? invoc-size) + #?(:cljd (#/(List/filled dynamic) invoc-size nil) + :default (object-array invoc-size)))] + (when enclosed->invocation + (enclosed->invocation enclosed-array invoc-array)) + (loop [args args i 0] + (when (< i fixed-arity) + (aset #?(:cljd invoc-array + :clj ^objects invoc-array + :cljs ^objects invoc-array) i (first args)) + (recur (next args) (inc i)))) + (loop [] + (when-not (nil? interrupt-fn#) (interrupt-fn#)) + (let [ret (types/eval body ctx invoc-array)] + (if (identical? recur# ret) + (recur) + ret)))))))))] f))) (defn lookup-by-arity [arities arity] diff --git a/src/sci/impl/multimethods.cljc b/src/sci/impl/multimethods.cljc index 29b06168..4af3278e 100644 --- a/src/sci/impl/multimethods.cljc +++ b/src/sci/impl/multimethods.cljc @@ -27,8 +27,14 @@ (defn- cljd-swap-method-table! [method-table f & args] (if (world/tracked? method-table) - (world/swap-value! method-table f args - (fn [_] nil) (fn [_ _] nil)) + (let [value (world/swap-value! method-table f args + (fn [_] nil) (fn [_ _] nil))] + ;; The first fork realizes the primary world from the host roots. + ;; Keep this root in sync while executing in that primary world, + ;; just as managed Vars do, but never mirror child mutations. + (when (world/primary-world?) + (reset! method-table value)) + value) (apply swap! method-table f args))))) #?(:cljd nil @@ -356,7 +362,9 @@ (defn multi-fn-impl [name dispatch-fn default hierarchy] #?(:cljd (let [method-table (atom {})] (when (world/current-world) - (world/register! method-table {})) + ;; Branch the table cell, but retain identity-bearing SCI Type + ;; keys and fork-aware method closures inside the persistent map. + (world/register! method-table {} identity)) (SciMultiFn. name dispatch-fn default method-table)) :default (if (world/current-world) (managed-multifn name dispatch-fn default hierarchy) diff --git a/src/sci/impl/refs.cljc b/src/sci/impl/refs.cljc index 696e03d8..c5ab1df2 100644 --- a/src/sci/impl/refs.cljc +++ b/src/sci/impl/refs.cljc @@ -18,7 +18,38 @@ fork/Forkable (fork-value [this] this) - #?@(:clj + #?@(:cljd + [IDeref + (-deref [this] + (atom-value home registry value-slot)) + IReset + (-reset! [this new-value] + (atom-reset! this home registry value-slot control-slot new-value)) + ISwap + (-swap! [this f] + (atom-swap! this home registry value-slot control-slot f nil)) + (-swap! [this f x] + (atom-swap! this home registry value-slot control-slot f [x])) + (-swap! [this f x y] + (atom-swap! this home registry value-slot control-slot f [x y])) + (-swap! [this f x y more] + (atom-swap! this home registry value-slot control-slot f + (list* x y more))) + IMeta + (-meta [this] + (atom-meta home registry control-slot)) + types/IResetMeta + (-reset-meta! [this m] + (atom-reset-meta! home registry control-slot m)) + IWatchable + (-add-watch [this key f] + (atom-add-watch! home registry control-slot key f) + this) + (-remove-watch [this key] + (atom-remove-watch! home registry control-slot key) + this)] + + :clj [clojure.lang.IDeref (deref [this] (atom-value home registry value-slot)) @@ -106,38 +137,7 @@ IEquiv (-equiv [this other] (identical? this other)) IHash - (-hash [this] (goog/getUid this))] - - :cljd - [IDeref - (-deref [this] - (atom-value home registry value-slot)) - IReset - (-reset! [this new-value] - (atom-reset! this home registry value-slot control-slot new-value)) - ISwap - (-swap! [this f] - (atom-swap! this home registry value-slot control-slot f nil)) - (-swap! [this f x] - (atom-swap! this home registry value-slot control-slot f [x])) - (-swap! [this f x y] - (atom-swap! this home registry value-slot control-slot f [x y])) - (-swap! [this f x y more] - (atom-swap! this home registry value-slot control-slot f - (list* x y more))) - IMeta - (-meta [this] - (atom-meta home registry control-slot)) - types/IResetMeta - (-reset-meta! [this m] - (atom-reset-meta! home registry control-slot m)) - IWatchable - (-add-watch [this key f] - (atom-add-watch! home registry control-slot key f) - this) - (-remove-watch [this key] - (atom-remove-watch! home registry control-slot key) - this)])) + (-hash [this] (goog/getUid this))])) (defn sci-atom? [x] (instance? SciAtom x)) @@ -297,18 +297,25 @@ (defn- host-delay [thunk] (clojure.core/delay (thunk))) -(deftype PendingDelayState [thunk delegate] +(deftype PendingDelayState [thunk delegate attempted failure] fork/Forkable (fork-value [_] - (if (realized? delegate) - (try - (RealizedDelayState. @delegate) - (catch #?(:cljd Object :clj Throwable :cljs :default) error - (FailedDelayState. error))) - (PendingDelayState. thunk (host-delay thunk)))) + (cond + @failure (FailedDelayState. @failure) + (or @attempted (realized? delegate)) (RealizedDelayState. @delegate) + :else (PendingDelayState. thunk (host-delay thunk) + (clojure.core/atom false) + (clojure.core/atom nil)))) IDelayState - (-delay-value [_] @delegate) - (-delay-realized? [_] (realized? delegate))) + (-delay-value [_] + (reset! attempted true) + (try + @delegate + (catch #?(:cljd Object :clj Throwable :cljs :default) error + (reset! failure error) + (throw error)))) + (-delay-realized? [_] + (or @attempted (realized? delegate)))) (declare delay-value delay-realized?) @@ -316,7 +323,12 @@ fork/Forkable (fork-value [this] this) - #?@(:clj + #?@(:cljd + [IDeref + (-deref [_] (delay-value home registry state-slot)) + IPending + (-realized? [_] (delay-realized? home registry state-slot))] + :clj [clojure.lang.IDeref (deref [_] (delay-value home registry state-slot)) clojure.lang.IPending @@ -329,12 +341,7 @@ IEquiv (-equiv [this other] (identical? this other)) IHash - (-hash [this] (goog/getUid this))] - :cljd - [IDeref - (-deref [_] (delay-value home registry state-slot)) - IPending - (-realized? [_] (delay-realized? home registry state-slot))])) + (-hash [this] (goog/getUid this))])) (defn sci-delay? [x] (instance? SciDelay x)) @@ -353,7 +360,9 @@ [thunk] (let [{:keys [home registry slots managed-index]} (world/register-managed! - :delay [(PendingDelayState. thunk (host-delay thunk))] [0])] + :delay [(PendingDelayState. thunk (host-delay thunk) + (clojure.core/atom false) + (clojure.core/atom nil))] [0])] (world/attach-managed-owner! registry managed-index (SciDelay. home registry (nth slots 0))))) @@ -364,7 +373,8 @@ (defn force* [x] (if (sci-delay? x) @x (force x))) -#?(:clj +#?(:cljd nil + :clj (do (deftype PendingPromiseState [] fork/Forkable diff --git a/src/sci/impl/vars.cljc b/src/sci/impl/vars.cljc index e4db38f4..89b86c5b 100644 --- a/src/sci/impl/vars.cljc +++ b/src/sci/impl/vars.cljc @@ -36,6 +36,8 @@ (deftype Frame [bindings prev scope prior-bindings]) +(deftype ContinuationContext [ctx frame]) + (def top-frame (Frame. {} nil nil nil)) #?(:cljs @@ -78,27 +80,118 @@ (getVal [_this] val)) (defn clone-thread-binding-frame ^Frame [] - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state))] + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state))] (Frame. (execution/active-bindings state) nil (execution/binding-scope state) nil))) +(declare ^:private retarget-binding-frame) + +(defn capture-continuation-context + "Capture the current SCI context and its persistent dynamic-binding frame. + + The returned value is an opaque host embedding token. It is intended for a + suspended continuation: invoke it later with `continuation-context-fn`, or + retarget an independent copy to a fork of the captured SCI context with + `retarget-continuation-context`." + ([] + (capture-continuation-context store/*ctx*)) + ([ctx] + (when-not (:sci.impl/world ctx) + (throw (ex-info "No managed SCI context is active" + {:type ::no-active-context}))) + (let [source-scope (execution/binding-scope) + target-scope (:sci.impl/world ctx)] + ;; A suspension is a value snapshot, not an alias onto the evaluation's + ;; still-live binding boxes. Clone immediately; the source form may finish + ;; unwinding (or a host callback may choose a target later) before resume. + ;; An interpreted function invoked directly by its host has no ctx-store + ;; binding and therefore a nil binding scope; normalize that frame onto the + ;; explicit interpreter world supplied by the embedding boundary. + (->ContinuationContext + ctx + (retarget-binding-frame (get-thread-binding-frame) + source-scope target-scope))))) + +(defn- clone-binding-map + [bindings box-cache] + (when bindings + (persistent! + (reduce-kv + (fn [ret var* box] + (let [forked-box + (if-let [entry (find @box-cache box)] + (val entry) + (let [copy (TBox. #?(:cljd nil + :clj (Thread/currentThread) + :cljs nil) + (t/getVal box))] + (vswap! box-cache assoc box copy) + copy))] + (assoc! ret var* forked-box))) + (transient {}) + bindings)))) + +(defn- retarget-binding-frame + [frame source-scope target-scope] + (let [box-cache (volatile! {})] + (letfn [(retarget [^Frame current] + (cond + (nil? current) nil + (identical? current top-frame) top-frame + :else + (Frame. (clone-binding-map (.-bindings current) box-cache) + (retarget (.-prev current)) + (if (identical? source-scope (.-scope current)) + target-scope + (.-scope current)) + (clone-binding-map (.-prior-bindings current) + box-cache))))] + (retarget frame)))) + +(defn retarget-continuation-context + "Return an independent continuation context selecting `target-ctx`. + + The target must be a fork in the captured context's lineage. Dynamic binding + boxes are copied, with aliases preserved inside the copied frame chain, and + binding scopes owned by the source world are moved to the target world." + [^ContinuationContext continuation-context target-ctx] + (let [source-ctx (.-ctx continuation-context) + frame (.-frame continuation-context)] + (when-not (and (:sci.impl/world target-ctx) + (identical? (:sci.impl/lineage source-ctx) + (:sci.impl/lineage target-ctx))) + (throw (ex-info + "Cannot retarget a continuation to an unrelated SCI context" + {:type ::unrelated-context}))) + (->ContinuationContext + target-ctx + (retarget-binding-frame frame + (:sci.impl/world source-ctx) + (:sci.impl/world target-ctx))))) + +(defn- frame-scopes [frame] + (loop [current frame + seen #{} + ret {}] + (if (nil? current) + ret + (let [^Frame current current + scope (.-scope current)] + (if (contains? seen scope) + (recur (.-prev current) seen ret) + (recur (.-prev current) + (conj seen scope) + (assoc ret scope (.-bindings current)))))))) + (defn reset-thread-binding-frame [frame] - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) - scopes (loop [^Frame current frame - seen #{} - ret {}] - (if (nil? current) - ret - (let [scope (.-scope current)] - (if (contains? seen scope) - (recur (.-prev current) seen ret) - (recur (.-prev current) - (conj seen scope) - (assoc ret scope (.-bindings current)))))))] + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) + scopes (frame-scopes frame)] (execution/set-binding-frame! state frame) (execution/set-scope-bindings! state scopes) (execution/refresh-active-bindings! state) @@ -125,8 +218,9 @@ (dynamic? [_] false)) (defn push-thread-bindings [bindings] - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) ^Frame frame (or (execution/binding-frame state) top-frame) scope (execution/binding-scope state) scopes (execution/scope-bindings state) @@ -155,8 +249,9 @@ (defn pop-thread-bindings [] #?(:cljs (bump-var-epoch!)) ;; type hint needed to satisfy CLJS compiler / shadow - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) ^Frame frame (or (execution/binding-frame state) top-frame)] (if-let [previous (.-prev frame)] (let [scope (.-scope frame) @@ -181,10 +276,12 @@ bmap))) (defn get-thread-binding #?(:cljd [sci-var] :clj ^TBox [sci-var] :cljs ^TBox [sci-var]) - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) - bmap #?(:clj (or (aget ^objects state execution/active-bindings-index) {}) - :default (execution/active-bindings state))] + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) + bmap #?(:cljd (execution/active-bindings state) + :clj (or (aget ^objects state execution/active-bindings-index) {}) + :cljs (execution/active-bindings state))] #?(:cljd (get bmap sci-var) :clj (.get ^java.util.Map bmap sci-var) :cljs (.get bmap sci-var)))) @@ -212,6 +309,13 @@ ([x y z & args] (invoke (list* x y z args)))))) +(defn continuation-context-fn + "Wrap `f` so every invocation restores a captured continuation context." + [^ContinuationContext continuation-context f] + (binding-frame-fn (.-frame continuation-context) + (.-ctx continuation-context) + f)) + (defn binding-conveyor-fn "Convey the current binding values to an independent task. The shallow frame deliberately cannot pop scopes owned by the submitting execution." diff --git a/src/sci/impl/world.cljc b/src/sci/impl/world.cljc index d0659b7a..ca272b5c 100644 --- a/src/sci/impl/world.cljc +++ b/src/sci/impl/world.cljc @@ -7,9 +7,10 @@ unrelated atoms never contend on a shared world root." (:require [sci.ctx-store :as store] [sci.impl.execution :as execution]) - #?(:clj (:import [java.lang.ref WeakReference] - [java.util.concurrent.atomic AtomicReferenceArray] - [java.util.concurrent.locks ReentrantReadWriteLock]))) + #?@(:cljd [] + :clj [(:import [java.lang.ref WeakReference] + [java.util.concurrent.atomic AtomicReferenceArray] + [java.util.concurrent.locks ReentrantReadWriteLock])])) (def absent #?(:cljd (Object.) :clj (Object.) :cljs (js/Object.))) @@ -24,36 +25,40 @@ (ReadWorld. world primary?)) (defn- new-cells [n] - #?(:clj + #?(:cljd + (#/(List/filled dynamic) n absent) + :clj (let [a (AtomicReferenceArray. (int n))] (dotimes [i n] (.set a i absent)) a) :cljs (let [a (object-array n)] (dotimes [i n] (aset a i absent)) - a) - :cljd - (#/(List/filled dynamic) n absent))) + a))) (defn- cells-length [cells] - #?(:clj (.length ^AtomicReferenceArray cells) - :cljs (alength cells) - :cljd (.-length ^List cells))) + #?(:cljd (.-length ^List cells) + :clj (.length ^AtomicReferenceArray cells) + :cljs (alength cells))) (defn- cells-get [cells slot] - #?(:clj (.get ^AtomicReferenceArray cells (int slot)) - :cljs (aget cells slot) - :cljd (aget ^List cells slot))) + #?(:cljd (aget ^List cells slot) + :clj (.get ^AtomicReferenceArray cells (int slot)) + :cljs (aget cells slot))) (defn- cells-set! [cells slot value] - #?(:clj (.set ^AtomicReferenceArray cells (int slot) value) - :cljs (aset cells slot value) - :cljd (aset ^List cells slot value)) + #?(:cljd (aset ^List cells slot value) + :clj (.set ^AtomicReferenceArray cells (int slot) value) + :cljs (aset cells slot value)) value) (defn- cells-cas! [cells slot old new] - #?(:clj (.compareAndSet ^AtomicReferenceArray cells (int slot) old new) - :default + #?(:cljd + (if (identical? old (cells-get cells slot)) + (do (cells-set! cells slot new) true) + false) + :clj (.compareAndSet ^AtomicReferenceArray cells (int slot) old new) + :cljs (if (identical? old (cells-get cells slot)) (do (cells-set! cells slot new) true) false))) @@ -62,8 +67,9 @@ @(.-cells-holder world)) (defn- with-registry-lock [registry f] - #?(:clj (locking registry (f)) - :default (f))) + #?(:cljd (f) + :clj (locking registry (f)) + :cljs (f))) (defn- ensure-capacity! [^DenseWorld world required] (let [holder (.-cells-holder world)] @@ -86,13 +92,14 @@ (DenseWorld. (volatile! (new-cells 64)) (atom {:next-slot 0 :descriptors {} :managed-descriptors []}) - #?(:clj (ReentrantReadWriteLock.) :default nil) + #?(:cljd nil :clj (ReentrantReadWriteLock.) :cljs nil) (volatile! false))) (defn active-world-state [] - #?(:clj (let [state (.get ^ThreadLocal execution/current)] + #?(:cljd (execution/active-world) + :clj (let [state (.get ^ThreadLocal execution/current)] (aget ^objects state execution/active-world-index)) - :default (execution/active-world))) + :cljs (execution/active-world))) (defn- install-active-world! [state active] (execution/set-active-world! state active) @@ -106,8 +113,9 @@ active) (defn- call-with-active-world [ctx f] - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) previous (execution/active-world state) previous-scope (execution/binding-scope state) active (:sci.impl/read-world ctx)] @@ -127,14 +135,16 @@ a quiescent source world without adding locks to individual reads." [ctx f] (if-let [world (:sci.impl/world ctx)] - #?(:clj + #?(:cljd + (call-with-active-world ctx f) + :clj (let [^DenseWorld world world lock (.readLock ^ReentrantReadWriteLock (.-gate world))] (.lock lock) (try (call-with-active-world ctx f) (finally (.unlock lock)))) - :default + :cljs (call-with-active-world ctx f)) (f))) @@ -311,12 +321,9 @@ "Attach weak ownership after constructing a self-described handle. The owner is never retained strongly by the lineage registry." [registry managed-index owner] - (let [owner-ref #?(:clj (WeakReference. owner) - :cljs (when (exists? js/WeakRef) (js/WeakRef. owner)) - ;; Dart weak-reference availability varies with the host - ;; SDK. The descriptor remains non-owning until a - ;; portable implementation is available. - :cljd nil)] + (let [owner-ref #?(:cljd nil + :clj (WeakReference. owner) + :cljs (when (exists? js/WeakRef) (js/WeakRef. owner)))] (when owner-ref (with-registry-lock registry @@ -327,9 +334,9 @@ (defn- live-managed-owner? [owner-ref] (or (nil? owner-ref) - #?(:clj (some? (.get ^WeakReference owner-ref)) - :cljs (some? (.deref owner-ref)) - :cljd true))) + #?(:cljd true + :clj (some? (.get ^WeakReference owner-ref)) + :cljs (some? (.deref owner-ref))))) (defn- sweep-managed! [^DenseWorld world] (let [cells (current-cells world)] @@ -372,13 +379,15 @@ (.-registry ^DenseWorld (.-world ^ReadWorld active)))) ^DenseWorld world (if related? (.-world ^ReadWorld active) home)] - #?(:clj + #?(:cljd + (f world) + :clj (if related? (f world) (let [lock (.readLock ^ReentrantReadWriteLock (.-gate world))] (.lock lock) (try (f world) (finally (.unlock lock))))) - :default + :cljs (f world)))) (defn managed-swap! @@ -442,13 +451,16 @@ (do (notify! world validation old new) true) false))))))) -(defn register! [handle value] - (when-let [^DenseWorld world (current-world)] - (let [{:keys [value-slot]} - (allocate-descriptor! world handle :ref true nil)] - (ensure-capacity! world (inc value-slot)) - (cells-set! (current-cells world) value-slot value))) - handle) +(defn register! + ([handle value] + (register! handle value nil)) + ([handle value value-fork-fn] + (when-let [^DenseWorld world (current-world)] + (let [{:keys [value-slot]} + (allocate-descriptor! world handle :ref true value-fork-fn)] + (ensure-capacity! world (inc value-slot)) + (cells-set! (current-cells world) value-slot value))) + handle)) (defn- allocate-var-watch-slot! [^DenseWorld world handle fallback] (let [registry (.-registry world)] @@ -659,8 +671,9 @@ world) (defn- call-with-selected-world [^DenseWorld world f] - (let [state #?(:clj (.get ^ThreadLocal execution/current) - :default (execution/current-state)) + (let [state #?(:cljd (execution/current-state) + :clj (.get ^ThreadLocal execution/current) + :cljs (execution/current-state)) previous (execution/active-world state) previous-scope (execution/binding-scope state)] (install-active-world! state (ReadWorld. world false)) @@ -686,7 +699,7 @@ target-world (DenseWorld. (volatile! target) registry - #?(:clj (ReentrantReadWriteLock.) :default nil) + #?(:cljd nil :clj (ReentrantReadWriteLock.) :cljs nil) (volatile! true))] (dotimes [i logical-n] (cells-set! target i (cells-get source i))) @@ -719,7 +732,11 @@ target-world)) (defn fork-world [^DenseWorld world fork-value snapshot-value snapshot-var-meta] - #?(:clj + #?(:cljd + (do + (realize-primary! world snapshot-value snapshot-var-meta) + (copy-world world fork-value)) + :clj (let [^ReentrantReadWriteLock gate (.-gate world)] (when (pos? (.getReadHoldCount gate)) (throw (IllegalStateException. @@ -730,7 +747,7 @@ (realize-primary! world snapshot-value snapshot-var-meta) (copy-world world fork-value) (finally (.unlock lock))))) - :default + :cljs (do (realize-primary! world snapshot-value snapshot-var-meta) (copy-world world fork-value)))) diff --git a/test/sci/core_test.cljc b/test/sci/core_test.cljc index 00d64ac8..4c7b6d23 100644 --- a/test/sci/core_test.cljc +++ b/test/sci/core_test.cljc @@ -17,7 +17,8 @@ fork/Forkable (fork-value [_] (swap! copies inc) - (ForkableState. (atom @state) copies))) + #?(:cljd (ForkableState. (atom @state) copies nil {} -1) + :default (ForkableState. (atom @state) copies)))) (defrecord ProhibitedState [resource] fork/Forkable @@ -1209,8 +1210,7 @@ :cljs "(try (force failed) (catch :default _ nil))" :cljd "(try (force failed) (catch Object _ nil))")) (let [child (sci/fork parent) - expected [false true #?(:cljs false :default true) - 2 [:completed :pending]]] + expected [false true true 2 [:completed :pending]]] (is (= expected (sci/eval-string* child @@ -1748,7 +1748,8 @@ (swap! host-state inc)]"))) (is (= 0 @host-state)))))) -#?(:clj +#?(:cljd nil + :clj (deftest affine-host-resource-fork-policy-test (testing "lazy realization is rejected" (let [parent (tu/forkable-init nil)] @@ -1806,7 +1807,8 @@ (sci/eval-string* (sci/fork parent {:fork-fn identity}) "promise")))))) -#?(:clj +#?(:cljd nil + :clj (deftest fork-host-value-cooperation-test (let [user-ns (sci/create-ns 'user) state-var (sci/new-var 'state (atom 0) {:ns user-ns}) @@ -1821,7 +1823,8 @@ (is (= 0 (sci/eval-string* parent "@state"))) (is (= 1 (sci/eval-string* child "@state"))))))) -#?(:clj +#?(:cljd nil + :clj (deftest fork-waits-for-active-evaluation-test (let [entered (promise) release (promise) @@ -1836,7 +1839,8 @@ (is (= true (deref evaluation 1000 ::timeout))) (is (map? (deref forking 1000 ::timeout))))))) -#?(:clj +#?(:cljd nil + :clj (deftest independent-world-slots-do-not-retry-test (let [n 1000 a-calls (atom 0) diff --git a/test/sci/multimethods_test.cljc b/test/sci/multimethods_test.cljc index 19d2d896..b2cb1d43 100644 --- a/test/sci/multimethods_test.cljc +++ b/test/sci/multimethods_test.cljc @@ -60,38 +60,65 @@ (let [parent (tu/forkable-init nil)] (sci/eval-string* parent - "(defmulti branch-method identity) - (defmethod branch-method :default [_] :parent-default) - (defmethod branch-method :shared [_] :parent-shared) - (derive ::cat ::animal) - (defmulti animal-method identity) - (defmethod animal-method ::animal [_] :animal) - (defmethod animal-method :default [_] :not-animal) - ;; Populate dispatch caches before the fork. - [(branch-method :child) (animal-method ::cat)]") + #?(:cljd + "(defmulti branch-method identity) + (defmethod branch-method :default [_] :parent-default) + (defmethod branch-method :shared [_] :parent-shared) + (branch-method :child)" + :default + "(defmulti branch-method identity) + (defmethod branch-method :default [_] :parent-default) + (defmethod branch-method :shared [_] :parent-shared) + (derive ::cat ::animal) + (defmulti animal-method identity) + (defmethod animal-method ::animal [_] :animal) + (defmethod animal-method :default [_] :not-animal) + ;; Populate dispatch caches before the fork. + [(branch-method :child) (animal-method ::cat)]")) (let [child (sci/fork parent)] - (is (= [:child :child-only #{:child :shared} {:left #{:right}}] + (is (= #?(:cljd [:child :child-only #{:child :shared}] + :default [:child :child-only #{:child :shared} + {:left #{:right}}]) (sci/eval-string* child - "(defmethod branch-method :shared [_] :child) - (defmethod branch-method :child [_] :child-only) - (remove-method branch-method :default) - (prefer-method branch-method :left :right) - (derive ::dog ::animal) - [(branch-method :shared) - (branch-method :child) - (set (keys (methods branch-method))) - (prefers branch-method)]"))) - (is (= [:parent-shared :parent-default #{:default :shared} {}] + #?(:cljd + "(defmethod branch-method :shared [_] :child) + (defmethod branch-method :child [_] :child-only) + (remove-method branch-method :default) + [(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method)))]" + :default + "(defmethod branch-method :shared [_] :child) + (defmethod branch-method :child [_] :child-only) + (remove-method branch-method :default) + (prefer-method branch-method :left :right) + (derive ::dog ::animal) + [(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method))) + (prefers branch-method)]")))) + (is (= #?(:cljd [:parent-shared :parent-default + #{:default :shared}] + :default [:parent-shared :parent-default + #{:default :shared} {}]) (sci/eval-string* parent - "[(branch-method :shared) - (branch-method :child) - (set (keys (methods branch-method))) - (prefers branch-method)]"))) - (is (= [:animal :animal] - (sci/eval-string* child - "[(animal-method ::cat) (animal-method ::dog)]"))) - (is (= [:animal :not-animal] - (sci/eval-string* parent - "[(animal-method ::cat) (animal-method ::dog)]")))))) + #?(:cljd + "[(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method)))]" + :default + "[(branch-method :shared) + (branch-method :child) + (set (keys (methods branch-method))) + (prefers branch-method)]")))) + #?(:cljd nil + :default + (do + (is (= [:animal :animal] + (sci/eval-string* + child "[(animal-method ::cat) (animal-method ::dog)]"))) + (is (= [:animal :not-animal] + (sci/eval-string* + parent "[(animal-method ::cat) (animal-method ::dog)]")))))))) diff --git a/test/sci/vars_test.cljc b/test/sci/vars_test.cljc index 577c30a1..2d569186 100644 --- a/test/sci/vars_test.cljc +++ b/test/sci/vars_test.cljc @@ -209,6 +209,156 @@ (sci/with-bindings {1 1} (sci/eval-string "*x*" {:bindings {'*x* 1}})))))) +(deftest forked-continuation-context-test + (let [captured (atom nil) + parent (tu/forkable-init + {:bindings + {'capture-continuation-context! + #(reset! captured (sci/capture-continuation-context))}})] + (sci/eval-string* + parent + "(def state (atom 0)) + (def ^:dynamic *outer* :root) + (def ^:dynamic *inner* :root) + (defn resume! [tag] + (let [before [*outer* *inner*] + _ (set! *inner* tag)] + [before [*outer* *inner*] (swap! state inc)])) + (defn unwind! [] + (let [inner *inner*] + (pop-thread-bindings) + [inner *outer* *inner*])) + (binding [*outer* :outer] + (binding [*inner* :inner] + (capture-continuation-context!)))") + (let [child (sci/fork parent) + sibling (sci/fork parent) + child-context + (sci/retarget-continuation-context @captured child) + sibling-context + (sci/retarget-continuation-context @captured sibling) + parent-resume + (sci/continuation-context-fn + @captured + (sci/eval-string* parent "resume!")) + child-resume + (sci/continuation-context-fn + child-context + (sci/eval-string* child "resume!")) + sibling-resume + (sci/continuation-context-fn + sibling-context + (sci/eval-string* sibling "resume!")) + child-unwind + (sci/continuation-context-fn + child-context + (sci/eval-string* child "unwind!"))] + (is (= [[:outer :inner] [:outer :parent] 1] + (parent-resume :parent))) + (is (= [[:outer :inner] [:outer :child] 1] + (child-resume :child))) + (is (= [[:outer :inner] [:outer :sibling] 1] + (sibling-resume :sibling))) + ;; The child capsule retains its own prior `set!`, then unwinds exactly + ;; one nested binding frame without touching parent or sibling boxes. + (is (= [:child :outer :root] (child-unwind))) + (is (= 1 (sci/eval-string* parent "@state"))) + (is (= 1 (sci/eval-string* child "@state"))) + (is (= 1 (sci/eval-string* sibling "@state"))) + (is (= [:root :root] + (sci/eval-string* parent "[*outer* *inner*]"))) + (is (= [:root :root] + (sci/eval-string* child "[*outer* *inner*]")))))) + +(deftest continuation-context-rejects-unrelated-lineage-test + (let [captured (atom nil) + parent (tu/forkable-init + {:bindings + {'capture-continuation-context! + #(reset! captured (sci/capture-continuation-context))}}) + unrelated (tu/forkable-init {})] + (sci/eval-string* parent "(capture-continuation-context!)") + (is (thrown-with-msg? + #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error) + #"unrelated SCI context" + (sci/retarget-continuation-context @captured unrelated))))) + +(deftest continuation-context-captures-binding-values-immediately-test + (let [captured (atom nil) + parent (tu/forkable-init + {:bindings + {'capture-continuation-context! + #(reset! captured (sci/capture-continuation-context))}})] + (sci/eval-string* + parent + "(def ^:dynamic *value* :root) + (defn capture-and-mutate! [] + (binding [*value* :captured] + (capture-continuation-context!) + (set! *value* :after-capture)))") + (sci/eval-string* parent "(capture-and-mutate!)") + (let [child (sci/fork parent) + parent-resume + (sci/continuation-context-fn + @captured + (sci/eval-string* parent "(fn [] *value*)")) + child-resume + (sci/continuation-context-fn + (sci/retarget-continuation-context @captured child) + (sci/eval-string* child "(fn [] *value*)"))] + (is (= :captured (parent-resume))) + (is (= :captured (child-resume))) + (is (= :root (sci/eval-string* parent "*value*"))) + (is (= :root (sci/eval-string* child "*value*")))))) + +(deftest explicit-context-captures-host-invoked-interpreted-function-test + (let [captured (atom nil) + context-holder (atom nil) + parent (tu/forkable-init + {:bindings + {'capture-continuation-context! + #(reset! captured + (sci/capture-continuation-context @context-holder))}})] + (reset! context-holder parent) + (let [suspend + (sci/eval-string* + parent + "(def ^:dynamic *scope* :root) + (fn [] + (binding [*scope* :host-invoked] + (capture-continuation-context!)))")] + ;; This interpreted closure runs after eval-string* has returned, which is + ;; how an embedding such as Spindel invokes an interpreted Spin body. + (suspend) + (let [child (sci/fork parent) + resume + (sci/continuation-context-fn + (sci/retarget-continuation-context @captured child) + (sci/eval-string* child "(fn [] *scope*)"))] + (is (= :host-invoked (resume))) + (is (= :root (sci/eval-string* parent "*scope*"))) + (is (= :root (sci/eval-string* child "*scope*"))))))) + +#?(:cljd nil + :clj + (deftest independent-interpreter-can-be-created-recursively-test + (let [outer + (sci/init + {:bindings + {'create-inner! + #(sci/with-detached-context + (fn [] + (let [ctx (sci/init {})] + (sci/eval-string* + ctx + "(ns nested.runtime) + (defmacro answer [] 42)") + (sci/eval-string* ctx "(nested.runtime/answer)"))))}})] + (is (= 42 + (sci/eval-string* + outer + "(create-inner!)")))))) + (deftest binding-api-test (when-not tu/native? (let [x (sci/new-dynamic-var 'x)] From 653fe958bb2a792080ab5119237f6dd707efafea Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Mon, 31 Aug 2026 13:52:24 -0700 Subject: [PATCH 24/31] Release SCI 0.15.59 --- CHANGELOG.md | 2 ++ resources/SCI_VERSION | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6da1934c..93aeb801 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,8 @@ SCI is used in [babashka](https://github.com/babashka/babashka), ## Unreleased +## 0.15.59 + - Caches resolved JVM instance methods per call site for performance - Fix [babashka#2030](https://github.com/babashka/babashka/issues/2030): `aset` on a primitive array was reflective and 170x slower than `aset-double` - Bump edamame to `1.6.43` diff --git a/resources/SCI_VERSION b/resources/SCI_VERSION index d788da18..578f21f1 100644 --- a/resources/SCI_VERSION +++ b/resources/SCI_VERSION @@ -1 +1 @@ -0.15.58 +0.15.59 From a2c1137124b63f321ef21faa4e80e2b510c92886 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Tue, 1 Sep 2026 03:11:11 -0700 Subject: [PATCH 25/31] build: prepare replikativ SCI distribution --- .circleci/config.yml | 21 +++++++++++++++++---- .circleci/script/deploy | 8 +++----- CHANGELOG.md | 7 +++++++ README.md | 17 ++++++++++++++--- project.clj | 17 ++++++++++------- resources/SCI_VERSION | 2 +- 6 files changed, 52 insertions(+), 20 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index fc8ff1a0..d7b4cb50 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -213,15 +213,28 @@ workflows: version: 2 ci: jobs: - - jvm - - node + - jvm: + filters: + tags: + only: /.*/ + - node: + filters: + tags: + only: /.*/ # - planck - - linux + - linux: + filters: + tags: + only: /.*/ # - mac - deploy: + context: + - clojars-deploy filters: branches: - only: master + ignore: /.*/ + tags: + only: /^replikativ-v0\.15\.59\.1$/ requires: - jvm - node diff --git a/.circleci/script/deploy b/.circleci/script/deploy index 6b0054c0..13b56b1a 100755 --- a/.circleci/script/deploy +++ b/.circleci/script/deploy @@ -1,8 +1,6 @@ #!/usr/bin/env bash -if [ -z "$CIRCLE_PULL_REQUEST" ] && [ "$CIRCLE_BRANCH" = "master" ] -then - lein with-profiles +compile-java do clean, deploy clojars -fi +set -euo pipefail -exit 0; +test "${CIRCLE_TAG:-}" = "replikativ-v0.15.59.1" +lein with-profiles +compile-java do clean, deploy clojars diff --git a/CHANGELOG.md b/CHANGELOG.md index 93aeb801..84cb372c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,13 @@ SCI is used in [babashka](https://github.com/babashka/babashka), ## Unreleased +## 0.15.59-replikativ.1 + +- Adds forkable interpreter worlds with explicit host-resource fork policies +- Adds continuation-context retargeting for forked execution +- Compatibility distribution of upstream SCI 0.15.59; published under + `org.replikativ/sci` while the changes are proposed upstream + ## 0.15.59 - Caches resolved JVM instance methods per call site for performance diff --git a/README.md b/README.md index 05a2e5c1..67ca5180 100644 --- a/README.md +++ b/README.md @@ -1,12 +1,19 @@ -[![CircleCI](https://circleci.com/gh/babashka/sci/tree/master.svg?style=shield)](https://circleci.com/gh/babashka/sci/tree/master) -[![Clojars Project](https://img.shields.io/clojars/v/org.babashka/sci.svg)](https://clojars.org/org.babashka/sci) +[![CircleCI](https://circleci.com/gh/replikativ/sci/tree/master.svg?style=shield)](https://circleci.com/gh/replikativ/sci/tree/master) +[![Clojars Project](https://img.shields.io/clojars/v/org.replikativ/sci.svg)](https://clojars.org/org.replikativ/sci) [![Financial Contributors on Open Collective](https://opencollective.com/babashka/all/badge.svg?label=financial+contributors)](https://opencollective.com/babashka) [![project chat](https://img.shields.io/badge/slack-join_chat-brightgreen.svg)](https://app.slack.com/client/T03RZGPFR/C015LCR9MHD) **Small Clojure Interpreter** +> This is the replikativ compatibility distribution of SCI. It preserves the +> `sci.*` namespaces and upstream API while adding forkable interpreter worlds, +> explicit host-resource fork policies, and continuation-context retargeting. +> The changes remain proposed upstream; this coordinate gives downstream +> replikativ libraries a stable Maven dependency in the meantime. Do not put +> `org.replikativ/sci` and `org.babashka/sci` on the same classpath. +