coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Step 10c: batch coalescing + global subscriber registry

Browse Source 
Provide subscribers stored in global *provide-subscribers* dict (keyed
by name) instead of on provide frames. Fixes subscriber loss when
frames are reconstructed, and enables cross-cek_run notification.

Batch integration: batch-begin!/batch-end! primitives manage
*provide-batch-depth*. fire-provide-subscribers defers to queue when
depth > 0, batch-end! flushes deduped. signals.sx batch calls both.

context now prefers scope-peek over frame value — scope stack is the
source of truth since provide! always updates it (even in nested
cek_run where provide frames aren't on the kont).

2754/2768 OCaml (14 pre-existing). 32/32 WASM.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-05 11:39:38 +00:00
parent 44b520a9e9
commit fb262aa49b
7 changed files with 1457 additions and 1341 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
hosts/ocaml/bin/run_tests.ml
View File

@@ -441,6 +441,8 @@ let make_test_env () =
match args with
| [state] -> Sx_ref.cek_run state
| _ -> Nil);
bind "batch-begin!" (fun _args -> Sx_ref.batch_begin_b ());
bind "batch-end!" (fun _args -> Sx_ref.batch_end_b ());
bind "now-ms" (fun _args -> Number 1000.0);
bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0);
bind "try-rerender-page" (fun _args -> Nil);

27
hosts/ocaml/lib/sx_ref.ml
View File

File diff suppressed because one or more lines are too long

8
shared/static/wasm/sx/core-signals.sx
View File

@@ -149,8 +149,9 @@
batch
:effects (mutation)
(fn
((thunk :as lambda))
((thunk :as callable))
(set! *batch-depth* (+ *batch-depth* 1))
(batch-begin!)
(cek-call thunk nil)
(set! *batch-depth* (- *batch-depth* 1))
(when
@@ -165,14 +166,15 @@
((s :as signal))
(for-each
(fn
((sub :as lambda))
((sub :as callable))
(when
(not (contains? seen sub))
(append! seen sub)
(append! pending sub)))
(signal-subscribers s)))
queue)
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
(for-each (fn ((sub :as callable)) (sub)) pending))))
(batch-end!)))
(define
notify-subscribers
:effects (mutation)

2454
shared/static/wasm/sx_browser.bc.js
View File

File diff suppressed because one or more lines are too long

2
shared/static/wasm/sx_browser.bc.wasm.js
View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create};
}
(globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-b2cc3269",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-9b135b3a",[2,3,5]],["std_exit-10fb8830",[2]],["start-f5d3f095",0]],"generated":(b=>{var
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-7ca4d3ad",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-bec4a5c4",[2,3,5]],["std_exit-10fb8830",[2]],["start-f5d3f095",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

297
spec/evaluator.sx
View File

@@ -401,8 +401,11 @@
(define *bind-tracking* nil)
;; Cond/case helpers
(define *provide-batch-depth* 0)
(define *library-registry* (dict))
;; Special form constructors — build state for CEK evaluation
(define
library-name-key
(fn
@@ -411,7 +414,6 @@
"."
(map (fn (s) (if (symbol? s) (symbol-name s) (str s))) spec))))
;; Special form constructors — build state for CEK evaluation
(define
library-loaded?
(fn (spec) (has-key? *library-registry* (library-name-key spec))))
@@ -436,9 +438,9 @@
(define io-lookup (fn (name) (get *io-registry* name)))
;; Quasiquote expansion
(define io-names (fn () (keys *io-registry*)))
;; Quasiquote expansion
(define
step-sf-io
(fn
@@ -469,9 +471,17 @@
(define *prim-param-types* nil)
;; Macro expansion — expand then re-evaluate the result
(define set-prim-param-types! (fn (types) (set! *prim-param-types* types)))
;; Macro expansion — expand then re-evaluate the result
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════
(define
value-matches-type?
(fn
@@ -498,14 +508,6 @@
(slice expected-type 0 (- (string-length expected-type) 1))))
true)))))
;; ═══════════════════════════════════════════════════════════════
;; Part 6: CEK Machine Core
;;
;; cek-run: trampoline loop — steps until terminal.
;; cek-step: single step — dispatches on phase (eval vs continue).
;; step-eval: evaluates control expression, pushes frames.
;; step-continue: pops a frame, processes result.
;; ═══════════════════════════════════════════════════════════════
(define
strict-check-args
(fn
@@ -577,6 +579,12 @@
(define eval-expr (fn (expr (env :as dict)) nil))
;; ═══════════════════════════════════════════════════════════════
;; Part 7: Special Form Step Functions
;;
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
(define
bind-lambda-params
(fn
@@ -601,12 +609,7 @@
true))
false))))
;; ═══════════════════════════════════════════════════════════════
;; Part 7: Special Form Step Functions
;;
;; Each step-sf-* handles one special form in the eval phase.
;; They push frames and return new CEK states — never recurse.
;; ═══════════════════════════════════════════════════════════════
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
(define
call-lambda
(fn
@@ -633,7 +636,9 @@
(slice params (len args))))
(make-thunk (lambda-body f) local))))
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
(define
call-component
(fn
@@ -651,9 +656,7 @@
(env-bind! local "children" children))
(make-thunk (component-body comp) local))))
;; List evaluation — dispatches on head: special forms, macros,
;; higher-order forms, or function calls. This is the main
;; expression dispatcher for the CEK machine.
;; call/cc: capture entire kont as undelimited escape continuation
(define
parse-keyword-args
(fn
@@ -685,7 +688,6 @@
raw-args)
(list kwargs children))))
;; call/cc: capture entire kont as undelimited escape continuation
(define
cond-scheme?
(fn
@@ -713,6 +715,7 @@
(= (type-of test) "symbol")
(or (= (symbol-name test) "else") (= (symbol-name test) ":else"))))))
;; Pattern matching (match form)
(define
sf-named-let
(fn
@@ -760,7 +763,7 @@
((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(cek-call loop-fn init-vals))))))
;; Pattern matching (match form)
;; Condition system special forms
(define
sf-lambda
(fn
@@ -790,7 +793,6 @@
params-expr)))
(make-lambda param-names body env))))
;; Condition system special forms
(define
sf-defcomp
(fn
@@ -1178,6 +1180,7 @@
(slice raw-args (len (macro-params mac)))))
(trampoline (eval-expr (macro-body mac) local)))))))
;; Scope/provide/context — structured downward data passing
(define
cek-step-loop
(fn
@@ -1187,7 +1190,6 @@
state
(cek-step-loop (cek-step state)))))
;; Scope/provide/context — structured downward data passing
(define
cek-run
(fn
@@ -1218,6 +1220,18 @@
(step-eval state)
(step-continue state))))
;; ═══════════════════════════════════════════════════════════════
;; R7RS syntax-rules / define-syntax
;;
;; syntax-rules creates a macro transformer via pattern matching.
;; define-syntax binds the transformer as a macro (reuses define).
;; Pattern language: _ (wildcard), literals (exact match),
;; pattern variables (bind), ... (ellipsis/repetition).
;; ═══════════════════════════════════════════════════════════════
;; Match a syntax-rules pattern against a form.
;; Returns a dict of bindings on success, nil on failure.
;; literals is a list of symbol name strings that must match exactly.
(define
step-eval
(fn
@@ -1274,18 +1288,8 @@
(step-eval-list expr env kont))
:else (make-cek-value expr env kont)))))
;; ═══════════════════════════════════════════════════════════════
;; R7RS syntax-rules / define-syntax
;;
;; syntax-rules creates a macro transformer via pattern matching.
;; define-syntax binds the transformer as a macro (reuses define).
;; Pattern language: _ (wildcard), literals (exact match),
;; pattern variables (bind), ... (ellipsis/repetition).
;; ═══════════════════════════════════════════════════════════════
;; Match a syntax-rules pattern against a form.
;; Returns a dict of bindings on success, nil on failure.
;; literals is a list of symbol name strings that must match exactly.
;; Match a list pattern against a form list, handling ellipsis at any position.
;; pi = pattern index, fi = form index.
(define
step-sf-raise
(fn
@@ -1295,8 +1299,8 @@
env
(kont-push (make-raise-eval-frame env false) kont))))
;; Match a list pattern against a form list, handling ellipsis at any position.
;; pi = pattern index, fi = form index.
;; Find which pattern variable in a template drives an ellipsis.
;; Returns the variable name (string) whose binding is a list, or nil.
(define
step-sf-guard
(fn
@@ -1370,8 +1374,8 @@
env
kont))))
;; Find which pattern variable in a template drives an ellipsis.
;; Returns the variable name (string) whose binding is a list, or nil.
;; Find ALL ellipsis-bound pattern variables in a template.
;; Returns a list of variable name strings.
(define
step-sf-callcc
(fn
@@ -1381,8 +1385,8 @@
env
(kont-push (make-callcc-frame env) kont))))
;; Find ALL ellipsis-bound pattern variables in a template.
;; Returns a list of variable name strings.
;; Instantiate a template with pattern variable bindings.
;; Handles ellipsis repetition and recursive substitution.
(define
step-sf-case
(fn
@@ -1392,8 +1396,9 @@
env
(kont-push (make-case-frame nil (rest args) env) kont))))
;; Instantiate a template with pattern variable bindings.
;; Handles ellipsis repetition and recursive substitution.
;; Walk a template list, handling ellipsis at any position.
;; When element at i is followed by ... at i+1, expand the element
;; for each value of its ellipsis variables (all cycled in parallel).
(define
step-sf-let-match
(fn
@@ -1407,9 +1412,10 @@
env
kont))))
;; Walk a template list, handling ellipsis at any position.
;; When element at i is followed by ... at i+1, expand the element
;; for each value of its ellipsis variables (all cycled in parallel).
;; Try each syntax-rules clause against a form.
;; Returns the instantiated template for the first matching rule, or errors.
;; form is the raw args (without macro name). We prepend a dummy _ symbol
;; because syntax-rules patterns include the keyword as the first element.
(define
step-eval-list
(fn
@@ -1577,10 +1583,6 @@
:else (step-eval-call head args env kont)))))
(step-eval-call head args env kont))))))
;; Try each syntax-rules clause against a form.
;; Returns the instantiated template for the first matching rule, or errors.
;; form is the raw args (without macro name). We prepend a dummy _ symbol
;; because syntax-rules patterns include the keyword as the first element.
(define
kont-extract-provides
(fn
@@ -1596,6 +1598,10 @@
(cons {:subscribers (list) :env (get frame "env") :value (get frame "value") :type "provide" :remaining (list) :name (get frame "name")} rest-frames)
rest-frames)))))
;; Special form: (syntax-rules (literal ...) (pattern template) ...)
;; Creates a Macro with rules/literals stored in closure env.
;; Body is a marker symbol; expand-macro detects it and calls
;; the pattern matcher directly.
(define
fire-provide-subscribers
(fn
@@ -1604,12 +1610,64 @@
((subs (get frame "subscribers")))
(when
(not (empty? subs))
(for-each (fn (sub) (cek-call sub (list kont))) subs)))))
(if
(> *provide-batch-depth* 0)
(for-each
(fn
(sub)
(when
(not (contains? *provide-batch-queue* sub))
(append! *provide-batch-queue* sub)))
subs)
(for-each (fn (sub) (cek-call sub (list kont))) subs))))))
(define
fire-provide-subscribers
(fn
(name)
(let
((subs (get *provide-subscribers* name)))
(when
(and subs (not (empty? subs)))
(if
(> *provide-batch-depth* 0)
(for-each
(fn
(sub)
(when
(not (contains? *provide-batch-queue* sub))
(append! *provide-batch-queue* sub)))
subs)
(for-each (fn (sub) (cek-call sub (list nil))) subs))))))
;; R7RS records (SRFI-9)
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
(define
batch-begin!
(fn () (set! *provide-batch-depth* (+ *provide-batch-depth* 1))))
;; Delimited continuations
(define
batch-end!
(fn
()
(set! *provide-batch-depth* (- *provide-batch-depth* 1))
(when
(= *provide-batch-depth* 0)
(let
((queue *provide-batch-queue*))
(set! *provide-batch-queue* (list))
(for-each (fn (sub) (cek-call sub (list nil))) queue)))))
;; Special form: (syntax-rules (literal ...) (pattern template) ...)
;; Creates a Macro with rules/literals stored in closure env.
;; Body is a marker symbol; expand-macro detects it and calls
;; the pattern matcher directly.
(define
step-sf-bind
(fn
@@ -1622,6 +1680,7 @@
env
(kont-push (make-bind-frame body env prev) kont)))))
;; Signal dereferencing with reactive dependency tracking
(define
step-sf-parameterize
(fn
@@ -1640,17 +1699,13 @@
(make-parameterize-frame bindings nil (list) body env)
kont)))))))
;; R7RS records (SRFI-9)
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; (define-record-type <point>
;; (make-point x y)
;; point?
;; (x point-x)
;; (y point-y set-point-y!))
;;
;; Creates: constructor, predicate, accessors, optional mutators.
;; Opaque — only accessible through generated functions.
;; Generative — each call creates a unique type.
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-match
(fn
@@ -1671,7 +1726,7 @@
(syntax-rules-match-list pattern 0 form 0 literals)
:else (if (= pattern form) (dict) nil))))
;; Delimited continuations
;; Reactive signal tracking — captures dependency continuation for re-render
(define
syntax-rules-match-list
(fn
@@ -1773,7 +1828,13 @@
template)
:else nil)))
;; Signal dereferencing with reactive dependency tracking
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-find-all-vars
(fn
@@ -1791,13 +1852,6 @@
template)
:else (list))))
;; ═══════════════════════════════════════════════════════════════
;; Part 8: Call Dispatch
;;
;; cek-call: invoke a function from native code (runs a nested
;; trampoline). step-eval-call: CEK-native call dispatch for
;; lambda, component, native fn, and continuations.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-instantiate
(fn
@@ -1811,7 +1865,6 @@
template
:else (syntax-rules-instantiate-list template 0 bindings))))
;; Reactive signal tracking — captures dependency continuation for re-render
(define
syntax-rules-instantiate-list
(fn
@@ -1869,13 +1922,6 @@
((full-form (cons (make-symbol "_") form)))
(syntax-rules-try-rules literals rules full-form))))
;; ═══════════════════════════════════════════════════════════════
;; Part 9: Higher-Order Form Machinery
;;
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
;; argument evaluation, then dispatches to the appropriate step-ho-*.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-try-rules
(fn
@@ -2026,6 +2072,14 @@
(define *protocol-registry* (dict))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
sf-define-record-type
(fn
@@ -2062,6 +2116,9 @@
field-specs)
nil))))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
sf-define-protocol
(fn
@@ -2178,6 +2235,13 @@
(list "match checks nil but has no non-nil pattern"))))
warnings)))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
sf-implement
(fn
@@ -2225,14 +2289,6 @@
(dict-set! impls type-name type-impls)
nil))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
satisfies?
(fn
@@ -2247,9 +2303,6 @@
false
(not (nil? (get (get proto "impls") (type-of value)))))))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
check-match-exhaustiveness
(fn
@@ -2307,13 +2360,6 @@
(list local body)
(match-find-clause val (rest clauses) env))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
match-pattern
(fn
@@ -2750,10 +2796,9 @@
(not (contains? *bind-tracking* name))
(append! *bind-tracking* name)))
(make-cek-value
(if
frame
(get frame "value")
(let ((sv (scope-peek name))) (if (nil? sv) default-val sv)))
(let
((sv (scope-peek name)))
(if (nil? sv) (if frame (get frame "value") default-val) sv))
env
kont))))
@@ -3602,13 +3647,13 @@
(fn
(name)
(let
((pf (kont-find-provide rest-k name)))
(when
pf
(dict-set!
pf
"subscribers"
(append (get pf "subscribers") (list subscriber))))))
((existing (get *provide-subscribers* name)))
(dict-set!
*provide-subscribers*
name
(append
(if existing existing (list))
(list subscriber)))))
tracked))
(make-cek-value value fenv rest-k)))
("provide-set"
@@ -3616,23 +3661,15 @@
((name (get frame "name"))
(fenv (get frame "env"))
(target (kont-find-provide rest-k name)))
(if
target
(let
((old-val (get target "value")))
(dict-set! target "value" value)
(scope-pop! name)
(scope-push! name value)
(when
(not (= old-val value))
(fire-provide-subscribers target rest-k))
(make-cek-value value fenv rest-k))
(if
(env-has? fenv "provide-set!")
(do
(apply (env-get fenv "provide-set!") (list name value))
(make-cek-value value fenv rest-k))
(make-cek-value nil fenv rest-k)))))
(let
((old-val (if target (get target "value") (scope-peek name))))
(when target (dict-set! target "value" value))
(scope-pop! name)
(scope-push! name value)
(when
(not (= old-val value))
(fire-provide-subscribers name))
(make-cek-value value fenv rest-k))))
("scope-acc"
(let
((remaining (get frame "remaining"))

8
spec/signals.sx
View File

@@ -149,8 +149,9 @@
batch
:effects (mutation)
(fn
((thunk :as lambda))
((thunk :as callable))
(set! *batch-depth* (+ *batch-depth* 1))
(batch-begin!)
(cek-call thunk nil)
(set! *batch-depth* (- *batch-depth* 1))
(when
@@ -165,14 +166,15 @@
((s :as signal))
(for-each
(fn
((sub :as lambda))
((sub :as callable))
(when
(not (contains? seen sub))
(append! seen sub)
(append! pending sub)))
(signal-subscribers s)))
queue)
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
(for-each (fn ((sub :as callable)) (sub)) pending))))
(batch-end!)))
(define
notify-subscribers
:effects (mutation)