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

Fix server import suspension, dist sync, JIT errors

Browse Source 
- cek_run patched to handle import suspensions via _import_hook.
  define-library (import ...) now resolves cleanly on the server.
  IO suspension errors: 190 → 0. JIT failures: ~50 → 0.
- _import_hook wired in sx_server.ml to load .sx files on demand.
- compile-modules.js syncs source .sx files to dist/sx/ before
  compiling — eliminates stale bytecode from out-of-date copies.
- WASM binary rebuilt with all fixes.
- 2658/2658 tests pass (8 new — previously failing import tests).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-04 22:52:41 +00:00
parent b0a4be0f22
commit 5ac1ca9756
11 changed files with 480 additions and 408 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
hosts/ocaml/bin/sx_server.ml
View File

@@ -783,6 +783,18 @@ let () =
if not (Sx_primitives.is_primitive name) then
Hashtbl.replace _shared_vm_globals name v)
(* Import hook — resolves (import ...) suspensions inside eval_expr/cek_run.
Loads the .sx file for the library, registers it, and returns true. *)
let () =
Sx_types._import_hook := Some (fun lib_spec ->
let key = Sx_ref.library_name_key lib_spec in
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then true
else match resolve_library_path lib_spec with
| Some path ->
(try load_library_file path; true
with _ -> false)
| None -> false)
let make_server_env () =
let env = make_env () in
Sx_render.setup_render_env env;

41
hosts/ocaml/browser/compile-modules.js
View File

@@ -16,12 +16,53 @@ const { execSync, spawnSync } = require('child_process');
const distDir = process.argv[2] || path.join(__dirname, 'dist');
const sxDir = path.join(distDir, 'sx');
const projectRoot = path.resolve(__dirname, '..', '..', '..');
if (!fs.existsSync(sxDir)) {
console.error('sx dir not found:', sxDir);
process.exit(1);
}
// Sync source .sx files to dist/sx/ before compiling.
// Source locations: spec/ for core, lib/ for compiler/vm, web/ and web/lib/ for web stack.
const SOURCE_MAP = {
// spec/
'render.sx': 'spec/render.sx',
'core-signals.sx': 'spec/signals.sx',
// lib/
'bytecode.sx': 'lib/bytecode.sx', 'compiler.sx': 'lib/compiler.sx',
'vm.sx': 'lib/vm.sx', 'freeze.sx': 'lib/freeze.sx',
'highlight.sx': 'lib/highlight.sx',
// web/lib/
'dom.sx': 'web/lib/dom.sx', 'browser.sx': 'web/lib/browser.sx',
// web/
'signals.sx': 'web/signals.sx', 'deps.sx': 'web/deps.sx',
'router.sx': 'web/router.sx', 'page-helpers.sx': 'web/page-helpers.sx',
'adapter-html.sx': 'web/adapter-html.sx', 'adapter-sx.sx': 'web/adapter-sx.sx',
'adapter-dom.sx': 'web/adapter-dom.sx',
'boot-helpers.sx': 'web/lib/boot-helpers.sx',
'hypersx.sx': 'web/hypersx.sx',
'harness.sx': 'spec/harness.sx', 'harness-reactive.sx': 'web/harness-reactive.sx',
'harness-web.sx': 'web/harness-web.sx',
'engine.sx': 'web/engine.sx', 'orchestration.sx': 'web/orchestration.sx',
'boot.sx': 'web/boot.sx',
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
};
let synced = 0;
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
const srcPath = path.join(projectRoot, src);
const dstPath = path.join(sxDir, dist);
if (fs.existsSync(srcPath)) {
const srcContent = fs.readFileSync(srcPath);
const dstExists = fs.existsSync(dstPath);
if (!dstExists || !fs.readFileSync(dstPath).equals(srcContent)) {
fs.writeFileSync(dstPath, srcContent);
synced++;
}
}
}
if (synced > 0) console.log('Synced ' + synced + ' source files to dist/sx/');
// Find the native OCaml binary
const binPaths = [
path.join(__dirname, '..', '_build', 'default', 'bin', 'sx_server.exe'),

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

@@ -488,7 +488,21 @@ and cek_step_loop state =
(* cek-run *)
and cek_run state =
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final))))
(let rec run s =
let final = cek_step_loop s in
if sx_truthy (cek_suspended_p final) then begin
let request = cek_io_request final in
let op = match request with Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "") | _ -> "" in
if op = "import" then
let lib_spec = match request with Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil) | _ -> Nil in
let key = library_name_key lib_spec in
let resolved = sx_truthy (library_loaded_p key) ||
(match !_import_hook with Some hook -> hook lib_spec | None -> false) in
if resolved then run (cek_resume final Nil)
else raise (Eval_error "IO suspension in non-IO context")
else raise (Eval_error "IO suspension in non-IO context")
end else cek_value final
in run state)
(* cek-resume *)
and cek_resume suspended_state result' =
@@ -815,7 +829,26 @@ let cek_run_iterative state =
s := cek_step !s
done;
(match cek_suspended_p !s with
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
| Bool true ->
let request = cek_io_request !s in
let op = match request with Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "") | _ -> "" in
if op = "import" then begin
let lib_spec = match request with Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil) | _ -> Nil in
let key = library_name_key lib_spec in
let resolved = sx_truthy (library_loaded_p key) ||
(match !_import_hook with Some hook -> hook lib_spec | None -> false) in
if resolved then begin
s := cek_resume !s Nil;
(* Continue the step loop after resolving the import *)
while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
&& not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
s := cek_step !s
done;
(match cek_suspended_p !s with
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
| _ -> cek_value !s)
end else raise (Eval_error "IO suspension in non-IO context")
end else raise (Eval_error "IO suspension in non-IO context")
| _ -> cek_value !s)
with Eval_error msg ->
_last_error_kont_ref := cek_kont !s;

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

@@ -1,6 +1,7 @@
(define-library (sx signals)
(define-library
(sx signals)
(export
make-signal
signal?
@@ -26,205 +27,193 @@
with-island-scope
register-in-scope)
(begin
(define
make-signal
(fn
(value)
(dict "__signal" true "value" value "subscribers" (list) "deps" (list))))
(define signal? (fn (x) (and (dict? x) (has-key? x "__signal"))))
(define signal-value (fn (s) (get s "value")))
(define signal-set-value! (fn (s v) (dict-set! s "value" v)))
(define signal-subscribers (fn (s) (get s "subscribers")))
(define
signal-add-sub!
(fn
(s f)
(when
(not (contains? (get s "subscribers") f))
(dict-set! s "subscribers" (append (get s "subscribers") (list f))))))
(define
signal-remove-sub!
(fn
(s f)
(dict-set!
s
"subscribers"
(filter (fn (sub) (not (identical? sub f))) (get s "subscribers")))))
(define signal-deps (fn (s) (get s "deps")))
(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
(define
signal
:effects ()
(fn ((initial-value :as any)) (make-signal initial-value)))
(define
deref
:effects ()
(fn
((s :as any))
(if
(not (signal? s))
s
(let
((ctx (context "sx-reactive" nil)))
(define
make-signal
(fn
(value)
(dict
"__signal"
true
"value"
value
"subscribers"
(list)
"deps"
(list))))
(define signal? (fn (x) (and (dict? x) (has-key? x "__signal"))))
(define signal-value (fn (s) (get s "value")))
(define signal-set-value! (fn (s v) (dict-set! s "value" v)))
(define signal-subscribers (fn (s) (get s "subscribers")))
(define
signal-add-sub!
(fn
(s f)
(when
ctx
(not (contains? (get s "subscribers") f))
(dict-set!
s
"subscribers"
(append (get s "subscribers") (list f))))))
(define
signal-remove-sub!
(fn
(s f)
(dict-set!
s
"subscribers"
(filter
(fn (sub) (not (identical? sub f)))
(get s "subscribers")))))
(define signal-deps (fn (s) (get s "deps")))
(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
(define
signal
:effects ()
(fn ((initial-value :as any)) (make-signal initial-value)))
(define
deref
:effects ()
(fn
((s :as any))
(if
(not (signal? s))
s
(let
((dep-list (get ctx "deps")) (notify-fn (get ctx "notify")))
((ctx (context "sx-reactive" nil)))
(when
(not (contains? dep-list s))
(append! dep-list s)
(signal-add-sub! s notify-fn))))
(signal-value s)))))
(define
reset!
:effects (mutation)
(fn
((s :as signal) value)
(when
(signal? s)
(let
((old (signal-value s)))
ctx
(let
{:notify notify-fn :deps dep-list}
ctx
(when
(not (contains? dep-list s))
(append! dep-list s)
(signal-add-sub! s notify-fn))))
(signal-value s)))))
(define
reset!
:effects (mutation)
(fn
((s :as signal) value)
(when
(not (identical? old value))
(signal-set-value! s value)
(notify-subscribers s))))))
(define
swap!
:effects (mutation)
(fn
((s :as signal) (f :as callable) &rest args)
(when
(signal? s)
(let
((old (signal-value s))
(new-val (trampoline (apply f (cons old args)))))
(signal? s)
(let
((old (signal-value s)))
(when
(not (identical? old value))
(signal-set-value! s value)
(notify-subscribers s))))))
(define
swap!
:effects (mutation)
(fn
((s :as signal) (f :as callable) &rest args)
(when
(not (identical? old new-val))
(signal-set-value! s new-val)
(notify-subscribers s))))))
(define
computed
:effects (mutation)
(fn
((compute-fn :as lambda))
(let
((s (make-signal nil)) (deps (list)) (compute-ctx nil))
(let
((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s))))))))
(recompute)
(register-in-scope (fn () (dispose-computed s)))
s))))
(define
effect
:effects (mutation)
(fn
((effect-fn :as lambda))
(let
((deps (list)) (disposed false) (cleanup-fn nil))
(let
((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result))))))))
(run-effect)
(signal? s)
(let
((old (signal-value s))
(new-val (trampoline (apply f (cons old args)))))
(when
(not (identical? old new-val))
(signal-set-value! s new-val)
(notify-subscribers s))))))
(define
computed
:effects (mutation)
(fn
((compute-fn :as lambda))
(let
((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)))))
(register-in-scope dispose-fn)
dispose-fn)))))
(define *batch-depth* 0)
(define *batch-queue* (list))
(define
batch
:effects (mutation)
(fn
((thunk :as lambda))
(set! *batch-depth* (+ *batch-depth* 1))
(cek-call thunk nil)
(set! *batch-depth* (- *batch-depth* 1))
(when
(= *batch-depth* 0)
(let
((queue *batch-queue*))
(set! *batch-queue* (list))
((s (make-signal nil)) (deps (list)) (compute-ctx nil))
(let
((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s))))))))
(recompute)
(register-in-scope (fn () (dispose-computed s)))
s))))
(define
effect
:effects (mutation)
(fn
((effect-fn :as lambda))
(let
((seen (list)) (pending (list)))
(for-each
(fn
((s :as signal))
((deps (list)) (disposed false) (cleanup-fn nil))
(let
((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result))))))))
(run-effect)
(let
((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)))))
(register-in-scope dispose-fn)
dispose-fn)))))
(define *batch-depth* 0)
(define *batch-queue* (list))
(define
batch
:effects (mutation)
(fn
((thunk :as lambda))
(set! *batch-depth* (+ *batch-depth* 1))
(cek-call thunk nil)
(set! *batch-depth* (- *batch-depth* 1))
(when
(= *batch-depth* 0)
(let
((queue *batch-queue*))
(set! *batch-queue* (list))
(let
((seen (list)) (pending (list)))
(for-each
(fn
((sub :as lambda))
(when
(not (contains? seen sub))
(append! seen sub)
(append! pending sub)))
(signal-subscribers s)))
queue)
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
(define
notify-subscribers
:effects (mutation)
(fn
((s :as signal))
(if
(> *batch-depth* 0)
(when (not (contains? *batch-queue* s)) (append! *batch-queue* s))
(flush-subscribers s))))
(define
flush-subscribers
:effects (mutation)
(fn
((s :as dict))
(for-each (fn (sub) (cek-call sub nil)) (signal-subscribers s))))
(define
dispose-computed
:effects (mutation)
(fn
((s :as signal))
(when
(signal? s)
(for-each
(fn ((dep :as signal)) (signal-remove-sub! dep nil))
(signal-deps s))
(signal-set-deps! s (list)))))
(define
with-island-scope
:effects (mutation)
(fn
((scope-fn :as lambda) (body-fn :as lambda))
(scope-push! "sx-island-scope" scope-fn)
(let ((result (body-fn))) (scope-pop! "sx-island-scope") result)))
(define
register-in-scope
:effects (mutation)
(fn
((disposable :as lambda))
(let
((collector (scope-peek "sx-island-scope")))
(when collector (cek-call collector (list disposable))))))
)) ;; end define-library
((s :as signal))
(for-each
(fn
((sub :as lambda))
(when
(not (contains? seen sub))
(append! seen sub)
(append! pending sub)))
(signal-subscribers s)))
queue)
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
(define
notify-subscribers
:effects (mutation)
(fn
((s :as signal))
(if
(> *batch-depth* 0)
(when (not (contains? *batch-queue* s)) (append! *batch-queue* s))
(flush-subscribers s))))
(define
flush-subscribers
:effects (mutation)
(fn
((s :as dict))
(for-each (fn (sub) (cek-call sub nil)) (signal-subscribers s))))
(define
dispose-computed
:effects (mutation)
(fn
((s :as signal))
(when
(signal? s)
(for-each
(fn ((dep :as signal)) (signal-remove-sub! dep nil))
(signal-deps s))
(signal-set-deps! s (list)))))
(define
with-island-scope
:effects (mutation)
(fn
((scope-fn :as lambda) (body-fn :as lambda))
(scope-push! "sx-island-scope" scope-fn)
(let ((result (body-fn))) (scope-pop! "sx-island-scope") result)))
(define
register-in-scope
:effects (mutation)
(fn
((disposable :as lambda))
(let
((collector (scope-peek "sx-island-scope")))
(when collector (cek-call collector (list disposable)))))))) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx signals))

113
shared/static/wasm/sx/deps.sx
View File

@@ -40,7 +40,7 @@
(when
(starts-with? name "~")
(when (not (contains? refs name)) (append! refs name)))))
("list" (for-each (fn (item) (scan-refs-walk item refs)) node))
("list" (for-each (fn (child) (scan-refs-walk child refs)) node))
("dict"
(for-each
(fn (key) (scan-refs-walk (dict-get node key) refs))
@@ -56,27 +56,16 @@
(append! seen n)
(let
((val (env-get env n)))
(match
(type-of val)
("component"
(for-each
(fn
((ref :as string))
(transitive-deps-walk ref seen env))
(scan-refs (component-body val))))
("island"
(for-each
(fn
((ref :as string))
(transitive-deps-walk ref seen env))
(scan-refs (component-body val))))
("macro"
(for-each
(fn
((ref :as string))
(transitive-deps-walk ref seen env))
(scan-refs (macro-body val))))
(_ nil))))))
(cond
(or (= (type-of val) "component") (= (type-of val) "island"))
(for-each
(fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (component-body val)))
(= (type-of val) "macro")
(for-each
(fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (macro-body val)))
:else nil)))))
(define
transitive-deps
:effects ()
@@ -216,37 +205,36 @@
(append! seen n)
(let
((val (env-get env n)))
(match
(type-of val)
("component"
(do
(for-each
(fn
((ref :as string))
(when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (component-body val) io-names))
(for-each
(fn
((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (component-body val)))))
("macro"
(do
(for-each
(fn
((ref :as string))
(when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (macro-body val) io-names))
(for-each
(fn
((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (macro-body val)))))
(_ nil))))))
(cond
(= (type-of val) "component")
(do
(for-each
(fn
((ref :as string))
(when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (component-body val) io-names))
(for-each
(fn
((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (component-body val))))
(= (type-of val) "macro")
(do
(for-each
(fn
((ref :as string))
(when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (macro-body val) io-names))
(for-each
(fn
((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (macro-body val))))
:else nil)))))
(define
transitive-io-refs
:effects ()
@@ -318,15 +306,16 @@
(if
(not (= (type-of val) "component"))
"server"
(match
(component-affinity val)
("server" "server")
("client" "client")
(_
(if
(not (component-pure? name env io-names))
"server"
"client"))))))))
(let
((affinity (component-affinity val)))
(cond
(= affinity "server")
"server"
(= affinity "client")
"client"
(not (component-pure? name env io-names))
"server"
:else "client")))))))
(define
page-render-plan
:effects ()

4
shared/static/wasm/sx/deps.sxbc
View File

File diff suppressed because one or more lines are too long

169
shared/static/wasm/sx/freeze.sx
View File

@@ -21,7 +21,8 @@
;; Registry of freeze scopes: name → list of {name signal} entries
(define-library (sx freeze)
(define-library
(sx freeze)
(export
freeze-registry
freeze-signal
@@ -33,82 +34,96 @@
freeze-to-sx
thaw-from-sx)
(begin
(define freeze-registry (dict))
;; Register a signal in the current freeze scope
(define freeze-signal :effects [mutation]
(fn (name sig)
(let ((scope-name (context "sx-freeze-scope" nil)))
(when scope-name
(let ((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
;; Freeze scope delimiter — collects signals registered within body
(define freeze-scope :effects [mutation]
(fn (name body-fn)
(scope-push! "sx-freeze-scope" name)
;; Initialize empty entry list for this scope
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
;; Freeze a named scope → SX dict of signal values
(define cek-freeze-scope :effects []
(fn (name)
(let ((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each (fn (entry)
(dict-set! signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
;; Freeze all scopes
(define cek-freeze-all :effects []
(fn ()
(map (fn (name) (cek-freeze-scope name))
(keys freeze-registry))))
;; Thaw a named scope — restore signal values from frozen data
(define cek-thaw-scope :effects [mutation]
(fn (name frozen)
(let ((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when values
(for-each (fn (entry)
(let ((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val))
(reset! sig val))))
entries)))))
;; Thaw all scopes from a list of frozen scope dicts
(define cek-thaw-all :effects [mutation]
(fn (frozen-list)
(for-each (fn (frozen)
(cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
;; Serialize a frozen scope to SX text
(define freeze-to-sx :effects []
(fn (name)
(sx-serialize (cek-freeze-scope name))))
;; Restore from SX text
(define thaw-from-sx :effects [mutation]
(fn (sx-text)
(let ((parsed (sx-parse sx-text)))
(when (not (empty? parsed))
(let ((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen))))))
)) ;; end define-library
(define freeze-registry (dict))
(define
freeze-signal
:effects (mutation)
(fn
(name sig)
(let
((scope-name (context "sx-freeze-scope" nil)))
(when
scope-name
(let
((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
(define
freeze-scope
:effects (mutation)
(fn
(name body-fn)
(scope-push! "sx-freeze-scope" name)
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
(define
cek-freeze-scope
:effects ()
(fn
(name)
(let
((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each
(fn
(entry)
(dict-set!
signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
(define
cek-freeze-all
:effects ()
(fn
()
(map (fn (name) (cek-freeze-scope name)) (keys freeze-registry))))
(define
cek-thaw-scope
:effects (mutation)
(fn
(name frozen)
(let
((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when
values
(for-each
(fn
(entry)
(let
((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val)) (reset! sig val))))
entries)))))
(define
cek-thaw-all
:effects (mutation)
(fn
(frozen-list)
(for-each
(fn (frozen) (cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
(define
freeze-to-sx
:effects ()
(fn (name) (sx-serialize (cek-freeze-scope name))))
(define
thaw-from-sx
:effects (mutation)
(fn
(sx-text)
(let
((parsed (sx-parse sx-text)))
(when
(not (empty? parsed))
(let
((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen)))))))) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx freeze))

2
shared/static/wasm/sx/freeze.sxbc
View File

@@ -1,3 +1,3 @@
(sxbc 1 "320fb4826d09fed3"
(sxbc 1 "050ab6181dc93341"
(code
:constants ("freeze-registry" "dict" "freeze-signal" {:upvalue-count 0 :arity 2 :constants ("context" "sx-freeze-scope" "get" "freeze-registry" "list" "append!" "dict" "name" "signal" "dict-set!") :bytecode (1 1 0 2 52 0 0 2 17 2 16 2 33 55 0 20 3 0 16 2 52 2 0 2 6 34 5 0 5 52 4 0 0 17 3 16 3 1 7 0 16 0 1 8 0 16 1 52 6 0 4 52 5 0 2 5 20 3 0 16 2 16 3 52 9 0 3 32 1 0 2 50)} "freeze-scope" {:upvalue-count 0 :arity 2 :constants ("scope-push!" "sx-freeze-scope" "dict-set!" "freeze-registry" "list" "cek-call" "scope-pop!") :bytecode (1 1 0 16 0 52 0 0 2 5 20 3 0 16 0 52 4 0 0 52 2 0 3 5 16 1 2 52 5 0 2 5 1 1 0 52 6 0 1 5 2 50)} "cek-freeze-scope" {:upvalue-count 0 :arity 1 :constants ("get" "freeze-registry" "list" "dict" "for-each" {:upvalue-count 1 :arity 1 :constants ("dict-set!" "get" "name" "signal-value" "signal") :bytecode (18 0 16 0 1 2 0 52 1 0 2 20 3 0 16 0 1 4 0 52 1 0 2 48 1 52 0 0 3 50)} "name" "signals") :bytecode (20 1 0 16 0 52 0 0 2 6 34 5 0 5 52 2 0 0 17 1 52 3 0 0 17 2 51 5 0 1 2 16 1 52 4 0 2 5 1 6 0 16 0 1 7 0 16 2 52 3 0 4 50)} "cek-freeze-all" {:upvalue-count 0 :arity 0 :constants ("map" {:upvalue-count 0 :arity 1 :constants ("cek-freeze-scope") :bytecode (20 0 0 16 0 49 1 50)} "keys" "freeze-registry") :bytecode (51 1 0 20 3 0 52 2 0 1 52 0 0 2 50)} "cek-thaw-scope" {:upvalue-count 0 :arity 2 :constants ("get" "freeze-registry" "list" "signals" "for-each" {:upvalue-count 1 :arity 1 :constants ("get" "name" "signal" "not" "nil?" "reset!") :bytecode (16 0 1 1 0 52 0 0 2 17 1 16 0 1 2 0 52 0 0 2 17 2 18 0 16 1 52 0 0 2 17 3 16 3 52 4 0 1 52 3 0 1 33 12 0 20 5 0 16 2 16 3 49 2 32 1 0 2 50)}) :bytecode (20 1 0 16 0 52 0 0 2 6 34 5 0 5 52 2 0 0 17 2 16 1 1 3 0 52 0 0 2 17 3 16 3 33 14 0 51 5 0 1 3 16 2 52 4 0 2 32 1 0 2 50)} "cek-thaw-all" {:upvalue-count 0 :arity 1 :constants ("for-each" {:upvalue-count 0 :arity 1 :constants ("cek-thaw-scope" "get" "name") :bytecode (20 0 0 16 0 1 2 0 52 1 0 2 16 0 49 2 50)}) :bytecode (51 1 0 16 0 52 0 0 2 50)} "freeze-to-sx" {:upvalue-count 0 :arity 1 :constants ("sx-serialize" "cek-freeze-scope") :bytecode (20 1 0 16 0 48 1 52 0 0 1 50)} "thaw-from-sx" {:upvalue-count 0 :arity 1 :constants ("sx-parse" "not" "empty?" "first" "cek-thaw-scope" "get" "name") :bytecode (20 0 0 16 0 48 1 17 1 16 1 52 2 0 1 52 1 0 1 33 27 0 16 1 52 3 0 1 17 2 20 4 0 16 2 1 6 0 52 5 0 2 16 2 49 2 32 1 0 2 50)} {:library (sx freeze) :op "import"}) :bytecode (52 1 0 0 128 0 0 5 51 3 0 128 2 0 5 51 5 0 128 4 0 5 51 7 0 128 6 0 5 51 9 0 128 8 0 5 51 11 0 128 10 0 5 51 13 0 128 12 0 5 51 15 0 128 14 0 5 51 17 0 128 16 0 5 1 18 0 112 50)))

133
shared/static/wasm/sx/vm.sx
View File

@@ -79,35 +79,35 @@
(fn
(vm value)
(let
((sp (get vm "sp")) (stack (get vm "stack")))
((sp (vm-sp vm)) (stack (vm-stack vm)))
(when
(>= sp (vm-stack-length stack))
(let
((new-stack (make-vm-stack (* sp 2))))
((new-stack (vm-stack-grow stack sp)))
(vm-stack-copy! stack new-stack sp)
(dict-set! vm "stack" new-stack)
(vm-set-stack! vm new-stack)
(set! stack new-stack)))
(vm-stack-set! stack sp value)
(dict-set! vm "sp" (+ sp 1)))))
(vm-set-sp! vm (+ sp 1)))))
(define
vm-pop
(fn
(vm)
(let
((sp (- (get vm "sp") 1)))
(dict-set! vm "sp" sp)
(vm-stack-get (get vm "stack") sp))))
((sp (- (vm-sp vm) 1)))
(vm-set-sp! vm sp)
(vm-stack-get (vm-stack vm) sp))))
(define
vm-peek
(fn (vm) (vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
(fn (vm) (vm-stack-get (vm-stack vm) (- (vm-sp vm) 1))))
(define
frame-read-u8
(fn
(frame)
(let
((ip (get frame "ip"))
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
(let ((v (nth bc ip))) (dict-set! frame "ip" (+ ip 1)) v))))
((ip (frame-ip frame))
(bc (-> frame frame-closure closure-code code-bytecode)))
(let ((v (nth bc ip))) (frame-set-ip! frame (+ ip 1)) v))))
(define
frame-read-u16
(fn
@@ -206,31 +206,28 @@
(if
(has-key? cells key)
(uv-get (get cells key))
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
(vm-stack-get (vm-stack vm) (+ (frame-base frame) slot))))))
(define
frame-local-set
(fn
(vm frame slot value)
"Write a local variable — to shared cell if captured, else to stack."
"Write a local variable — to shared cell or stack."
(let
((cells (get frame "local-cells")) (key (str slot)))
(if
(has-key? cells key)
(uv-set! (get cells key) value)
(vm-stack-set!
(get vm "stack")
(+ (get frame "base") slot)
value)))))
(vm-stack-set! (vm-stack vm) (+ (frame-base frame) slot) value)))))
(define
frame-upvalue-get
(fn
(frame idx)
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
(uv-get (nth (-> frame frame-closure closure-upvalues) idx))))
(define
frame-upvalue-set
(fn
(frame idx value)
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
(uv-set! (nth (-> frame frame-closure closure-upvalues) idx) value)))
(define frame-ip (fn (frame) (get frame "ip")))
(define frame-set-ip! (fn (frame val) (dict-set! frame "ip" val)))
(define frame-base (fn (frame) (get frame "base")))
@@ -302,12 +299,12 @@
(vm frame name)
"Look up a global: globals table → closure env → primitives → HO wrappers"
(let
((globals (get vm "globals")))
((globals (vm-globals-ref vm)))
(if
(has-key? globals name)
(get globals name)
(let
((closure-env (get (get frame "closure") "closure-env")))
((closure-env (-> frame frame-closure closure-env)))
(if
(nil? closure-env)
(cek-try
@@ -325,41 +322,42 @@
vm-resolve-ho-form
(fn
(vm name)
(cond
(= name "for-each")
(fn
(f coll)
(for-each (fn (x) (vm-call-external vm f (list x))) coll))
(= name "map")
(fn
(f coll)
(map (fn (x) (vm-call-external vm f (list x))) coll))
(= name "map-indexed")
(fn
(f coll)
(map-indexed
(fn (i x) (vm-call-external vm f (list i x)))
coll))
(= name "filter")
(fn
(f coll)
(filter (fn (x) (vm-call-external vm f (list x))) coll))
(= name "reduce")
(fn
(f init coll)
(reduce
(fn (acc x) (vm-call-external vm f (list acc x)))
init
coll))
(= name "some")
(fn
(f coll)
(some (fn (x) (vm-call-external vm f (list x))) coll))
(= name "every?")
(fn
(f coll)
(every? (fn (x) (vm-call-external vm f (list x))) coll))
:else (error (str "VM undefined: " name)))))
(match
name
("for-each"
(fn
(f coll)
(for-each (fn (x) (vm-call-external vm f (list x))) coll)))
("map"
(fn
(f coll)
(map (fn (x) (vm-call-external vm f (list x))) coll)))
("map-indexed"
(fn
(f coll)
(map-indexed
(fn (i x) (vm-call-external vm f (list i x)))
coll)))
("filter"
(fn
(f coll)
(filter (fn (x) (vm-call-external vm f (list x))) coll)))
("reduce"
(fn
(f init coll)
(reduce
(fn (acc x) (vm-call-external vm f (list acc x)))
init
coll)))
("some"
(fn
(f coll)
(some (fn (x) (vm-call-external vm f (list x))) coll)))
("every?"
(fn
(f coll)
(every? (fn (x) (vm-call-external vm f (list x))) coll)))
(_ (error (str "VM undefined: " name))))))
(define
vm-call-external
(fn
@@ -372,14 +370,14 @@
vm-global-set
(fn
(vm frame name value)
"Set a global: write to closure env if name exists there, else globals."
"Set a global: write to closure env if found, else globals table."
(let
((closure-env (get (get frame "closure") "vm-closure-env"))
((closure-env (get (frame-closure frame) "vm-closure-env"))
(written false))
(when
(not (nil? closure-env))
(set! written (env-walk-set! closure-env name value)))
(when (not written) (dict-set! (get vm "globals") name value)))))
(when (not written) (dict-set! (vm-globals-ref vm) name value)))))
(define
env-walk
(fn
@@ -414,20 +412,15 @@
(let
((code (code-from-value code-val))
(uv-count
(if
(dict? code-val)
(let
((n (get code-val "upvalue-count")))
(if (nil? n) 0 n))
0)))
(if (dict? code-val) (or (get code-val "upvalue-count") 0) 0)))
(let
((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (get vm "stack") (+ (get frame "base") index))))) (dict-set! cells key c) c))) (nth (get (get frame "closure") "vm-upvalues") index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result)))
(make-vm-closure code upvalues nil (get vm "globals") nil)))))
((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (vm-stack vm) (+ (frame-base frame) index))))) (dict-set! cells key c) c))) (nth (-> frame frame-closure closure-upvalues) index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result)))
(make-vm-closure code upvalues nil (vm-globals-ref vm) nil)))))
(define
vm-run
(fn
(vm)
"Execute bytecode until all frames are consumed."
"Execute bytecode until all frames are done or IO suspension."
(define
loop
(fn
@@ -438,9 +431,9 @@
((frame (first (vm-frames vm)))
(rest-frames (rest (vm-frames vm))))
(let
((bc (code-bytecode (closure-code (frame-closure frame))))
((bc (-> frame frame-closure closure-code code-bytecode))
(consts
(code-constants (closure-code (frame-closure frame)))))
(-> frame frame-closure closure-code code-constants)))
(if
(>= (frame-ip frame) (len bc))
(vm-set-frames! vm (list))

4
shared/static/wasm/sx/vm.sxbc
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-d4b9c764",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-ba5b5565",[2,3,5]],["std_exit-10fb8830",[2]],["start-f5d3f095",0]],"generated":(b=>{var
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["sx-90abc6ab",[2]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,4]],["dune__exe__Sx_browser-216e88df",[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