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

Split make_server_env, eliminate all runtime sx_ref imports, fix auth-menu tests

Browse Source 
make_server_env split into 7 focused setup functions:
- setup_browser_stubs (22 DOM no-ops)
- setup_scope_env (18 scope primitives from sx_scope.ml)
- setup_evaluator_bridge (CEK eval-expr, trampoline, expand-macro, etc.)
- setup_introspection (type predicates, component/lambda accessors)
- setup_type_operations (string/env/dict/equality/parser helpers)
- setup_html_tags (~100 HTML tag functions)
- setup_io_env (query, action, helper IO bridge)

Eliminate ALL runtime sx_ref.py imports:
- sx/sxc/pages/helpers.py: 24 imports → _ocaml_helpers.py bridge
- sx/sxc/pages/sx_router.py: remove SX_USE_REF fallback
- shared/sx/query_registry.py: use register_components instead of eval

Unify JIT compilation: pre-compile list derived from allowlist
(no manual duplication), only compiler internals pre-compiled.

Fix test_components auth-menu: ~auth-menu → ~shared:fragments/auth-menu

Tests: 1114 OCaml, 29/29 components, 35/35 regression, 6/6 Playwright

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-24 17:23:09 +00:00
parent 6ef9688bd2
commit 3df8c41ca1
6 changed files with 439 additions and 445 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -313,44 +313,9 @@ let setup_io_env env =
(* Environment setup *)
(* ====================================================================== *)
let make_server_env () =
let env = make_env () in
(* Evaluator bindings — same as run_tests.ml's make_test_env,
but only the ones needed for rendering (not test helpers). *)
let bind name fn =
ignore (env_bind env name (NativeFn (name, fn)))
in
bind "assert" (fun args ->
match args with
| [cond] ->
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
Bool true
| [cond; String msg] ->
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
Bool true
| [cond; msg] ->
if not (sx_truthy cond) then
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
Bool true
| _ -> raise (Eval_error "assert: expected 1-2 args"));
bind "append!" (fun args ->
match args with
| [ListRef r; v] -> r := !r @ [v]; ListRef r
| [List items; v] -> List (items @ [v])
| _ -> raise (Eval_error "append!: expected list and value"));
(* HTML renderer — OCaml render module provides the shell renderer;
adapter-html.sx provides the SX-level render-to-html *)
Sx_render.setup_render_env env;
(* Render-mode flags *)
bind "set-render-active!" (fun _args -> Nil);
bind "render-active?" (fun _args -> Bool true);
(* Browser APIs — no-op stubs for SSR *)
(* ---- Browser API stubs (no-op for SSR) ---- *)
let setup_browser_stubs env =
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
bind "local-storage-get" (fun _args -> Nil);
bind "local-storage-set" (fun _args -> Nil);
bind "dom-listen" (fun _args -> NativeFn ("noop", fun _ -> Nil));
@@ -359,9 +324,6 @@ let make_server_env () =
bind "dom-get-data" (fun _args -> Nil);
bind "event-detail" (fun _args -> Nil);
bind "promise-then" (fun _args -> Nil);
bind "thunk?" (fun args -> match args with [Thunk _] -> Bool true | _ -> Bool false);
bind "thunk-expr" (fun args -> match args with [v] -> thunk_expr v | _ -> Nil);
bind "thunk-env" (fun args -> match args with [v] -> thunk_env v | _ -> Nil);
bind "schedule-idle" (fun _args -> Nil);
bind "dom-query" (fun _args -> Nil);
bind "dom-query-all" (fun _args -> List []);
@@ -375,28 +337,11 @@ let make_server_env () =
bind "dom-append" (fun _args -> Nil);
bind "create-text-node" (fun _args -> Nil);
bind "render-to-dom" (fun _args -> Nil);
bind "set-render-active!" (fun _args -> Nil);
bind "render-active?" (fun _args -> Bool true)
(* Raw HTML — platform primitives for adapter-html.sx *)
bind "make-raw-html" (fun args ->
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
bind "raw-html-content" (fun args ->
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
bind "empty-dict?" (fun args ->
match args with [Dict d] -> Bool (Hashtbl.length d = 0) | _ -> Bool true);
bind "for-each-indexed" (fun args ->
match args with
| [fn_val; List items] | [fn_val; ListRef { contents = items }] ->
List.iteri (fun i item ->
ignore (Sx_ref.eval_expr (List [fn_val; Number (float_of_int i); item]) (Env env))
) items; Nil
| _ -> Nil);
(* Scope stack — platform primitives for render-time dynamic scope.
Used by aser for spread/provide/emit patterns.
Module-level so step-sf-context can check it via get-primitive. *)
(* Scope primitives are registered globally in sx_scope.ml.
Bind them into the env so the JIT VM can find them via vm.globals
(OP_GLOBAL_GET checks env.bindings before the primitives table). *)
(* ---- Scope primitives: bind into env for VM visibility ---- *)
let setup_scope_env env =
List.iter (fun name ->
try ignore (env_bind env name (Sx_primitives.get_primitive name))
with _ -> ()
@@ -406,23 +351,11 @@ let make_server_env () =
"scope-collected"; "scope-clear-collected!";
"provide-push!"; "provide-pop!";
"get-cookie"; "set-cookie"];
(* sx-context is an env alias for context *)
let context_prim = Sx_primitives.get_primitive "context" in
ignore (env_bind env "sx-context" context_prim);
ignore (env_bind env "sx-context" (Sx_primitives.get_primitive "context"))
(* qq-expand-runtime — quasiquote expansion at runtime.
The bytecode compiler emits CALL_PRIM "qq-expand-runtime" for
backtick expressions. Expands the template with the calling env. *)
bind "qq-expand-runtime" (fun args ->
match args with
| [template] ->
(* qq_expand needs an env — use the kernel env *)
Sx_ref.qq_expand template (Env env)
| [template; Env e] -> Sx_ref.qq_expand template (Env e)
| _ -> Nil);
(* Evaluator bridge — aser calls these spec functions.
Route to the OCaml CEK machine. *)
(* ---- CEK evaluator bridge ---- *)
let setup_evaluator_bridge env =
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
bind "eval-expr" (fun args ->
match args with
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
@@ -431,7 +364,6 @@ let make_server_env () =
bind "trampoline" (fun args ->
match args with
| [v] ->
(* sf-letrec returns thunks — resolve them *)
let rec resolve v = match v with
| Thunk (expr, env) -> resolve (Sx_ref.eval_expr expr (Env env))
| _ -> v
@@ -460,152 +392,151 @@ let make_server_env () =
) m.m_params;
Sx_ref.eval_expr m.m_body (Env body_env)
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
(* Expose register-special-form! and *custom-special-forms* to SX code
(used by web-forms.sx and adapter form-classification functions) *)
bind "qq-expand-runtime" (fun args ->
match args with
| [template] -> Sx_ref.qq_expand template (Env env)
| [template; Env e] -> Sx_ref.qq_expand template (Env e)
| _ -> Nil);
bind "register-special-form!" (fun args ->
match args with
| [String name; handler] ->
ignore (Sx_ref.register_special_form (String name) handler);
Nil
ignore (Sx_ref.register_special_form (String name) handler); Nil
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
(* Register <> as a special form — evaluates all children, returns list *)
ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))));
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
(* Missing primitives that may be referenced *)
bind "upcase" (fun args ->
match args with
| [String s] -> String (String.uppercase_ascii s)
| _ -> raise (Eval_error "upcase: expected string"));
bind "downcase" (fun args ->
match args with
| [String s] -> String (String.lowercase_ascii s)
| _ -> raise (Eval_error "downcase: expected string"));
bind "make-keyword" (fun args ->
match args with
| [String s] -> Keyword s
| _ -> raise (Eval_error "make-keyword: expected string"));
(* Type predicates and accessors — platform interface for aser *)
bind "lambda?" (fun args ->
match args with [Lambda _] -> Bool true | _ -> Bool false);
bind "macro?" (fun args ->
match args with [Macro _] -> Bool true | _ -> Bool false);
bind "island?" (fun args ->
match args with [Island _] -> Bool true | _ -> Bool false);
(* ---- Type predicates and introspection ---- *)
let setup_introspection env =
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
bind "thunk?" (fun args -> match args with [Thunk _] -> Bool true | _ -> Bool false);
bind "thunk-expr" (fun args -> match args with [v] -> thunk_expr v | _ -> Nil);
bind "thunk-env" (fun args -> match args with [v] -> thunk_env v | _ -> Nil);
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
bind "component?" (fun args ->
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
bind "callable?" (fun args ->
match args with
| [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
| _ -> Bool false);
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
bind "continuation?" (fun args ->
match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
bind "lambda-params" (fun args ->
match args with
| [Lambda l] -> List (List.map (fun s -> String s) l.l_params)
| _ -> List []);
bind "lambda-body" (fun args ->
match args with
| [Lambda l] -> l.l_body
| _ -> Nil);
match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
bind "lambda-closure" (fun args ->
match args with
| [Lambda l] -> Env l.l_closure
| _ -> Dict (Hashtbl.create 0));
match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
bind "component-name" (fun args ->
match args with
| [Component c] -> String c.c_name
| [Island i] -> String i.i_name
| _ -> String "");
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
bind "component-closure" (fun args ->
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
bind "component-params" (fun args ->
match args with
| [Component c] -> Env c.c_closure
| [Island i] -> Env i.i_closure
| _ -> Dict (Hashtbl.create 0));
bind "spread?" (fun args ->
match args with [Spread _] -> Bool true | _ -> Bool false);
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
| _ -> Nil);
bind "component-body" (fun args ->
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
let has_children_impl = NativeFn ("component-has-children?", fun args ->
match args with [Component c] -> Bool c.c_has_children | [Island i] -> Bool i.i_has_children | _ -> Bool false) in
ignore (env_bind env "component-has-children" has_children_impl);
ignore (env_bind env "component-has-children?" has_children_impl);
bind "component-affinity" (fun args ->
match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto");
bind "spread-attrs" (fun args ->
match args with
| [Spread pairs] ->
let d = Hashtbl.create 4 in
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs;
Dict d
let d = Hashtbl.create 4 in List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
| _ -> Dict (Hashtbl.create 0));
bind "make-spread" (fun args ->
match args with
| [Dict d] ->
let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [] in
Spread pairs
| _ -> Nil);
bind "is-html-tag?" (fun args ->
| [Dict d] -> Spread (Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [])
| _ -> Nil)
(* ---- Type operations, string/number/env helpers ---- *)
let setup_type_operations env =
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
bind "assert" (fun args ->
match args with
| [String s] -> Bool (Sx_render.is_html_tag s)
| [cond] -> if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); Bool true
| [cond; String msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg)); Bool true
| [cond; msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ value_to_string msg)); Bool true
| _ -> raise (Eval_error "assert: expected 1-2 args"));
bind "append!" (fun args ->
match args with
| [ListRef r; v] -> r := !r @ [v]; ListRef r
| [List items; v] -> List (items @ [v])
| _ -> raise (Eval_error "append!: expected list and value"));
bind "make-raw-html" (fun args ->
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
bind "raw-html-content" (fun args ->
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
bind "empty-dict?" (fun args ->
match args with [Dict d] -> Bool (Hashtbl.length d = 0) | _ -> Bool true);
bind "for-each-indexed" (fun args ->
match args with
| [fn_val; List items] | [fn_val; ListRef { contents = items }] ->
List.iteri (fun i item ->
ignore (Sx_ref.eval_expr (List [fn_val; Number (float_of_int i); item]) (Env env))
) items; Nil
| _ -> Nil);
bind "upcase" (fun args -> match args with [String s] -> String (String.uppercase_ascii s) | _ -> raise (Eval_error "upcase: expected string"));
bind "downcase" (fun args -> match args with [String s] -> String (String.lowercase_ascii s) | _ -> raise (Eval_error "downcase: expected string"));
bind "make-keyword" (fun args -> match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
bind "keyword-name" (fun args -> match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
bind "symbol-name" (fun args -> match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
bind "make-symbol" (fun args -> match args with [String s] -> Symbol s | [v] -> Symbol (value_to_string v) | _ -> raise (Eval_error "make-symbol: expected 1 arg"));
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
bind "make-continuation" (fun args ->
match args with [f] -> Continuation ((fun v -> Sx_runtime.sx_call f [v]), None) | _ -> raise (Eval_error "make-continuation: expected 1 arg"));
bind "sx-serialize" (fun args -> match args with [v] -> String (inspect v) | _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
bind "equal?" (fun args -> match args with [a; b] -> Bool (a = b) | _ -> raise (Eval_error "equal?: expected 2 args"));
bind "identical?" (fun args -> match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: expected 2 args"));
bind "apply" (fun args ->
match args with
| f :: rest ->
let all_args = match List.rev rest with List last :: prefix -> List.rev prefix @ last | _ -> rest in
Sx_runtime.sx_call f all_args
| _ -> raise (Eval_error "apply: expected function and args"));
bind "cond-scheme?" (fun args -> match args with [clauses] -> Sx_ref.cond_scheme_p clauses | _ -> Bool false);
bind "is-else-clause?" (fun args -> match args with [test] -> Sx_ref.is_else_clause test | _ -> Bool false);
bind "primitive?" (fun args ->
match args with
| [String name] -> Bool (Sx_primitives.is_primitive name ||
(try (match env_get env name with NativeFn _ -> true | _ -> false) with _ -> false))
| _ -> Bool false);
(* HTML tag functions — when eval-expr encounters (div :class "foo" ...),
it calls the tag function which returns the list as-is. The render path
then handles it. Same approach as the DOM adapter in the browser. *)
List.iter (fun tag ->
ignore (env_bind env tag
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
) Sx_render.html_tags;
(* Spec evaluator helpers needed by render.sx when loaded at runtime *)
bind "get-primitive" (fun args ->
match args with
| [String name] -> (try Sx_primitives.get_primitive name with _ -> try env_get env name with _ -> Nil)
| _ -> Nil);
bind "random-int" (fun args ->
match args with
| [Number lo; Number hi] ->
let lo = int_of_float lo and hi = int_of_float hi in
Number (float_of_int (lo + Random.int (max 1 (hi - lo + 1))))
| _ -> raise (Eval_error "random-int: expected (low high)"));
bind "parse-int" (fun args ->
match args with
| [String s] -> (try Number (float_of_int (int_of_string s)) with _ -> Nil)
| [String s; default_val] ->
(try Number (float_of_int (int_of_string s)) with _ -> default_val)
| [String s; default_val] -> (try Number (float_of_int (int_of_string s)) with _ -> default_val)
| [Number n] | [Number n; _] -> Number (Float.round n)
| [_; default_val] -> default_val
| _ -> Nil);
bind "json-encode" (fun args -> io_request "helper" (String "json-encode" :: args));
bind "into" (fun args -> io_request "helper" (String "into" :: args));
bind "sleep" (fun args -> io_request "sleep" args);
bind "set-response-status" (fun args -> io_request "set-response-status" args);
bind "set-response-header" (fun args -> io_request "set-response-header" args);
(* defhandler/defpage/defquery/defaction/defrelation are registered by
web-forms.sx via register-special-form!, no longer hardcoded here. *)
bind "cond-scheme?" (fun args ->
| [_; default_val] -> default_val | _ -> Nil);
bind "parse-number" (fun args -> match args with [String s] -> (try Number (float_of_string s) with _ -> Nil) | _ -> Nil);
bind "escape-string" (fun args ->
match args with
| [clauses] -> Sx_ref.cond_scheme_p clauses
| _ -> Bool false);
bind "is-else-clause?" (fun args ->
match args with
| [test] -> Sx_ref.is_else_clause test
| _ -> Bool false);
bind "primitive?" (fun args ->
match args with
| [String name] ->
(* Check both the primitives table and the env *)
Bool (Sx_primitives.is_primitive name ||
(try (match env_get env name with NativeFn _ -> true | _ -> false)
with _ -> false))
| _ -> Bool false);
bind "get-primitive" (fun args ->
match args with
| [String name] ->
(* Check primitives table first, then env *)
(try Sx_primitives.get_primitive name
with _ -> try env_get env name with _ -> Nil)
| _ -> Nil);
| [String s] ->
let buf = Buffer.create (String.length s) in
String.iter (fun c -> match c with
| '"' -> Buffer.add_string buf "\\\"" | '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n" | '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t" | c -> Buffer.add_char buf c) s;
String (Buffer.contents buf)
| _ -> raise (Eval_error "escape-string: expected string"));
bind "string-length" (fun args -> match args with [String s] -> Number (float_of_int (String.length s)) | _ -> raise (Eval_error "string-length: expected string"));
bind "dict-get" (fun args -> match args with [Dict d; String k] -> dict_get d k | [Dict d; Keyword k] -> dict_get d k | _ -> raise (Eval_error "dict-get: expected dict and key"));
(* Character classification — platform primitives for spec/parser.sx *)
bind "ident-start?" (fun args ->
match args with
@@ -627,201 +558,58 @@ let make_server_env () =
|| c >= '0' && c <= '9' || c = '.' || c = ':')
| _ -> Bool false);
bind "char-numeric?" (fun args ->
match args with
| [String s] when String.length s = 1 ->
Bool (s.[0] >= '0' && s.[0] <= '9')
| _ -> Bool false);
bind "parse-number" (fun args ->
match args with
| [String s] ->
(try Number (float_of_string s)
with _ -> Nil)
| _ -> Nil);
bind "escape-string" (fun args ->
match args with
| [String s] ->
let buf = Buffer.create (String.length s) in
String.iter (fun c -> match c with
| '"' -> Buffer.add_string buf "\\\""
| '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n"
| '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c) s;
String (Buffer.contents buf)
| _ -> raise (Eval_error "escape-string: expected string"));
bind "string-length" (fun args ->
match args with
| [String s] -> Number (float_of_int (String.length s))
| _ -> raise (Eval_error "string-length: expected string"));
bind "dict-get" (fun args ->
match args with
| [Dict d; String k] -> dict_get d k
| [Dict d; Keyword k] -> dict_get d k
| _ -> raise (Eval_error "dict-get: expected dict and key"));
bind "apply" (fun args ->
match args with
| f :: rest ->
let all_args = match List.rev rest with
| List last :: prefix -> List.rev prefix @ last
| _ -> rest
in
Sx_runtime.sx_call f all_args
| _ -> raise (Eval_error "apply: expected function and args"));
bind "equal?" (fun args ->
match args with
| [a; b] -> Bool (a = b)
| _ -> raise (Eval_error "equal?: expected 2 args"));
bind "identical?" (fun args ->
match args with
| [a; b] -> Bool (a == b)
| _ -> raise (Eval_error "identical?: expected 2 args"));
bind "make-sx-expr" (fun args ->
match args with
| [String s] -> SxExpr s
| _ -> raise (Eval_error "make-sx-expr: expected string"));
bind "sx-expr-source" (fun args ->
match args with
| [SxExpr s] -> String s
| [String s] -> String s
| _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
bind "make-continuation" (fun args ->
match args with
| [f] ->
let k v = Sx_runtime.sx_call f [v] in
Continuation (k, None)
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
bind "continuation?" (fun args ->
match args with
| [Continuation _] -> Bool true
| [_] -> Bool false
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
bind "make-symbol" (fun args ->
match args with
| [String s] -> Symbol s
| [v] -> Symbol (value_to_string v)
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
bind "sx-serialize" (fun args ->
match args with
| [v] -> String (inspect v)
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
(* Env operations — accept both Env and Dict (adapter-html.sx passes dicts) *)
match args with [String s] when String.length s = 1 -> Bool (s.[0] >= '0' && s.[0] <= '9') | _ -> Bool false);
(* Env operations *)
let uw = Sx_runtime.unwrap_env in
bind "env-get" (fun args ->
match args with
| [e; String k] -> Sx_types.env_get (uw e) k
| [e; Keyword k] -> Sx_types.env_get (uw e) k
| _ -> raise (Eval_error "env-get: expected env and string"));
bind "env-has?" (fun args ->
match args with
| [e; String k] -> Bool (Sx_types.env_has (uw e) k)
| [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k)
| _ -> raise (Eval_error "env-has?: expected env and string"));
bind "env-bind!" (fun args ->
match args with
| [e; String k; v] -> Sx_types.env_bind (uw e) k v
| [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
bind "env-set!" (fun args ->
match args with
| [e; String k; v] -> Sx_types.env_set (uw e) k v
| [e; Keyword k; v] -> Sx_types.env_set (uw e) k v
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
bind "env-extend" (fun args ->
match args with
| [e] -> Env (Sx_types.env_extend (uw e))
| _ -> raise (Eval_error "env-extend: expected env"));
bind "env-merge" (fun args ->
match args with
| [a; b] -> Sx_runtime.env_merge a b
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
(* Strict mode state *)
bind "env-get" (fun args -> match args with [e; String k] -> Sx_types.env_get (uw e) k | [e; Keyword k] -> Sx_types.env_get (uw e) k | _ -> raise (Eval_error "env-get: expected env and string"));
bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"));
(* Strict mode *)
ignore (env_bind env "*strict*" (Bool false));
ignore (env_bind env "*prim-param-types*" Nil);
bind "set-strict!" (fun args ->
match args with
| [v] ->
Sx_ref._strict_ref := v;
ignore (env_set env "*strict*" v); Nil
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
bind "set-prim-param-types!" (fun args ->
match args with
| [v] ->
Sx_ref._prim_param_types_ref := v;
ignore (env_set env "*prim-param-types*" v); Nil
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
bind "set-strict!" (fun args -> match args with [v] -> Sx_ref._strict_ref := v; ignore (env_set env "*strict*" v); Nil | _ -> raise (Eval_error "set-strict!: expected 1 arg"));
bind "set-prim-param-types!" (fun args -> match args with [v] -> Sx_ref._prim_param_types_ref := v; ignore (env_set env "*prim-param-types*" v); Nil | _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
bind "component-param-types" (fun _args -> Nil);
bind "component-set-param-types!" (fun _args -> Nil);
(* IO helpers routed to Python bridge *)
bind "json-encode" (fun args -> io_request "helper" (String "json-encode" :: args));
bind "into" (fun args -> io_request "helper" (String "into" :: args));
bind "sleep" (fun args -> io_request "sleep" args);
bind "set-response-status" (fun args -> io_request "set-response-status" args);
bind "set-response-header" (fun args -> io_request "set-response-header" args)
bind "component-params" (fun args ->
match args with
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
| _ -> Nil);
(* ---- HTML tag functions (div, span, h1, ...) ---- *)
let setup_html_tags env =
List.iter (fun tag ->
ignore (env_bind env tag
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
) Sx_render.html_tags
bind "component-body" (fun args ->
match args with
| [Component c] -> c.c_body
| [Island i] -> i.i_body
| _ -> Nil);
let has_children_impl = NativeFn ("component-has-children?", fun args ->
match args with
| [Component c] -> Bool c.c_has_children
| [Island i] -> Bool i.i_has_children
| _ -> Bool false) in
ignore (env_bind env "component-has-children" has_children_impl);
ignore (env_bind env "component-has-children?" has_children_impl);
(* ====================================================================== *)
(* Compose environment *)
(* ====================================================================== *)
bind "component-affinity" (fun args ->
match args with
| [Component c] -> String c.c_affinity
| [Island _] -> String "client"
| _ -> String "auto");
bind "keyword-name" (fun args ->
match args with
| [Keyword k] -> String k
| _ -> raise (Eval_error "keyword-name: expected keyword"));
bind "symbol-name" (fun args ->
match args with
| [Symbol s] -> String s
| _ -> raise (Eval_error "symbol-name: expected symbol"));
(* IO primitives *)
let make_server_env () =
let env = make_env () in
Sx_render.setup_render_env env;
setup_browser_stubs env;
setup_scope_env env;
setup_evaluator_bridge env;
setup_introspection env;
setup_type_operations env;
setup_html_tags env;
setup_io_env env;
(* Initialize trampoline ref so HO primitives (map, filter, etc.)
can call SX lambdas. Must be done here (not sx_runtime.ml)
because Sx_ref is only available at the binary level. *)
can call SX lambdas. Must be done here because Sx_ref is only
available at the binary level, not in the library. *)
Sx_primitives._sx_trampoline_fn := (fun v ->
match v with
| Thunk (body, closure_env) -> Sx_ref.eval_expr body (Env closure_env)
| other -> other);
env
@@ -1040,37 +828,30 @@ let rec dispatch env cmd =
| exn -> send_error (Printexc.to_string exn))
| List [Symbol "vm-compile-adapter"] ->
(* Register JIT hook and pre-compile the compiler itself.
The compile function running on the VM makes all subsequent
JIT compilations near-instant (VM speed vs CEK speed). *)
(* Register JIT hook — all functions in the allowlist compile lazily
on first call. Pre-compile the compiler itself so subsequent
JIT compilations run at VM speed, not CEK speed. *)
register_jit_hook env;
Printf.eprintf "[jit] JIT hook registered (lazy compilation active)\n%!";
(* Pre-compile the compiler: compile → make-emitter → make-pool
and other compiler internals so they run on VM from the start *)
let compiler_fns = ["compile"; "compile-module"; "compile-expr";
"compile-symbol"; "compile-dict"; "compile-list"; "compile-if";
"compile-when"; "compile-and"; "compile-or"; "compile-begin";
"compile-let"; "compile-letrec"; "compile-lambda"; "compile-define"; "compile-set";
"compile-quote"; "compile-cond"; "compile-case"; "compile-case-clauses";
"compile-thread"; "compile-thread-step"; "compile-defcomp";
"compile-defmacro"; "compile-quasiquote"; "compile-call";
"make-emitter"; "make-pool"; "emit-byte"; "emit-u16"; "emit-i16";
"pool-add"; "resolve-scope"; "scope-resolve"] in
let t0 = Unix.gettimeofday () in
let count = ref 0 in
List.iter (fun name ->
match Hashtbl.find_opt env.bindings name with
| Some (Lambda l) when l.l_compiled = None ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
(match Sx_vm.jit_compile_lambda l env.bindings with
| Some cl ->
l.l_compiled <- Some cl;
incr count
| None -> ())
| _ -> ()
) compiler_fns;
(* Pre-compile compiler internals only — these bootstrap the JIT.
Everything else (render, aser, parser) compiles lazily on first call. *)
StringSet.iter (fun name ->
if String.length name >= 7 && String.sub name 0 7 = "compile"
|| List.mem name ["make-emitter"; "make-pool"; "make-scope"; "pool-add";
"scope-define-local"; "scope-resolve";
"emit-byte"; "emit-u16"; "emit-i16"; "emit-op"; "emit-const";
"current-offset"; "patch-i16"] then
match Hashtbl.find_opt env.bindings name with
| Some (Lambda l) when l.l_compiled = None ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
(match Sx_vm.jit_compile_lambda l env.bindings with
| Some cl -> l.l_compiled <- Some cl; incr count
| None -> ())
| _ -> ()
) !jit_allowlist;
let dt = Unix.gettimeofday () -. t0 in
Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs\n%!" !count dt;
Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs (lazy JIT active)\n%!" !count dt;
send_ok ()
| List [Symbol "jit-allow"; String name] ->