JIT allowlist + integration tests + --test mode + clean up debug logging
JIT allowlist (sx_server.ml): - Replace try-every-lambda strategy with StringSet allowlist. Only functions in the list get JIT compiled (compiler, parser, pure transforms). Render functions that need dynamic scope skip JIT entirely — no retry overhead, no silent fallbacks. - Add (jit-allow name) command for dynamic expansion from Python bridge. - JIT failures log once with "[jit] DISABLED fn — reason" then go silent. Standalone --test mode (sx_server.ml): - New --test flag loads full env (spec + adapters + compiler + signals), supports --eval and --load flags. Quick kernel testing without Docker. Example: dune exec bin/sx_server.exe -- --test --eval '(len HTML_TAGS)' Integration tests (integration_tests.ml): - New binary exercising the full rendering pipeline: loads spec + adapters into a server-like env, renders HTML via both native and SX adapter paths. - 26 tests: HTML tags, special forms (when/if/let), letrec with side effects, component rendering, eval-expr with HTML tag functions. - Would have caught the "Undefined symbol: div/lake/init" issues from the previous commit immediately without Docker. VM cleanup (sx_vm.ml): - Remove temporary debug logging (insn counter, call_closure counter, VmClosure depth tracking) added during debugging. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -1131,7 +1131,12 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["emitted"] = sxEmitted;
|
||||
// Aliases for aser adapter (avoids CEK special form conflict on server)
|
||||
var scopeEmit = sxEmit;
|
||||
var scopePeek = sxEmitted;
|
||||
function scopePeek(name) {
|
||||
if (_scopeStacks[name] && _scopeStacks[name].length) {
|
||||
return _scopeStacks[name][_scopeStacks[name].length - 1].value;
|
||||
}
|
||||
return NIL;
|
||||
}
|
||||
PRIMITIVES["scope-emit!"] = scopeEmit;
|
||||
PRIMITIVES["scope-peek"] = scopePeek;
|
||||
''',
|
||||
|
||||
@@ -1,3 +1,3 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server)
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
|
||||
383
hosts/ocaml/bin/integration_tests.ml
Normal file
383
hosts/ocaml/bin/integration_tests.ml
Normal file
@@ -0,0 +1,383 @@
|
||||
(** Integration tests — exercises the full rendering pipeline.
|
||||
|
||||
Loads spec files + web adapters into a server-like env, then renders
|
||||
HTML expressions. Catches "Undefined symbol" errors that only surface
|
||||
when the full stack is loaded (not caught by spec unit tests).
|
||||
|
||||
Usage:
|
||||
dune exec bin/integration_tests.exe *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if expected = actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s\n expected: %s\n got: %s\n%!" name expected actual
|
||||
end
|
||||
|
||||
let assert_contains name needle haystack =
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in
|
||||
if String.length needle > 0 && find 0 then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected to contain %S in %S\n%!" name needle haystack
|
||||
end
|
||||
|
||||
let assert_no_error name f =
|
||||
try
|
||||
ignore (f ());
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name (Printexc.to_string exn)
|
||||
|
||||
(* Build a server-like env with rendering support *)
|
||||
let make_integration_env () =
|
||||
let env = make_env () in
|
||||
let bind (n : string) fn =
|
||||
ignore (Sx_types.env_bind env n (NativeFn (n, fn)))
|
||||
in
|
||||
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* HTML tag functions — same as sx_server.ml *)
|
||||
List.iter (fun tag ->
|
||||
ignore (env_bind env tag
|
||||
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
||||
) Sx_render.html_tags;
|
||||
|
||||
(* Platform primitives needed by spec/render.sx and adapters *)
|
||||
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 "escape-html" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-attr" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-string" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "is-html-tag?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
||||
bind "is-void-element?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_void s) | _ -> Bool false);
|
||||
bind "is-boolean-attr?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_boolean_attr s) | _ -> Bool false);
|
||||
|
||||
(* Mutable operations needed by adapter code *)
|
||||
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 "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
|
||||
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
|
||||
| _ -> Nil);
|
||||
bind "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (Hashtbl.mem d k)
|
||||
| [Dict d; Keyword k] -> Bool (Hashtbl.mem d k)
|
||||
| _ -> Bool false);
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| _ -> Nil);
|
||||
bind "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
bind "mutable-list" (fun _args -> ListRef (ref []));
|
||||
|
||||
(* Symbol/keyword accessors needed by adapter-html.sx *)
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with [String s] -> Symbol s | _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* Type predicates needed by adapters *)
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args -> match args with [Component _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] -> let d = Hashtbl.create 8 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
|
||||
| _ -> Nil);
|
||||
bind "component-name" (fun args -> match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil);
|
||||
bind "component-params" (fun args -> match args with [Component c] -> List (List.map (fun s -> String s) c.c_params) | _ -> List []);
|
||||
bind "component-body" (fun args -> match args with [Component c] -> c.c_body | _ -> Nil);
|
||||
bind "component-closure" (fun args -> match args with [Component c] -> Env c.c_closure | _ -> Nil);
|
||||
bind "component-has-children?" (fun args -> match args with [Component c] -> Bool c.c_has_children | _ -> Bool false);
|
||||
bind "component-affinity" (fun args -> match args with [Component c] -> String c.c_affinity | _ -> String "auto");
|
||||
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);
|
||||
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
bind "lambda-name" (fun args -> match args with [Lambda l] -> (match l.l_name with Some n -> String n | None -> Nil) | _ -> Nil);
|
||||
bind "set-lambda-name!" (fun args -> match args with [Lambda l; String n] -> l.l_name <- Some n; Nil | _ -> Nil);
|
||||
|
||||
(* Environment operations *)
|
||||
bind "env-extend" (fun args ->
|
||||
match args with [Env e] -> Env (env_extend e) | _ -> Env (env_extend env));
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_bind e k v | _ -> Nil);
|
||||
bind "env-set!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_set e k v | _ -> Nil);
|
||||
bind "env-get" (fun args ->
|
||||
match args with [Env e; String k] -> env_get e k | _ -> Nil);
|
||||
bind "env-has?" (fun args ->
|
||||
match args with [Env e; String k] -> Bool (env_has e k) | _ -> Bool false);
|
||||
bind "env-merge" (fun args ->
|
||||
match args with [Env a; Env b] -> Env (env_merge a b) | _ -> Nil);
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
(* Eval/trampoline — needed by adapters *)
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| _ -> Nil);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (e, env)] -> Sx_ref.eval_expr e (Env env)
|
||||
| [v] -> v | _ -> Nil);
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [f; List a] -> Sx_runtime.sx_call f a
|
||||
| [f; a] -> Sx_runtime.sx_call f [a]
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; _env] ->
|
||||
let local = env_extend m.m_closure in
|
||||
let rec bind_params ps as' = match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with Some rp -> ignore (env_bind local rp (List rest)) | None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a); bind_params ps_rest as_rest
|
||||
| _ :: _, [] -> ()
|
||||
in
|
||||
bind_params m.m_params macro_args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
| _ -> Nil);
|
||||
|
||||
(* Scope/provide — needed by adapter-html.sx and the CEK evaluator.
|
||||
Must be registered as primitives (prim_call) not just env bindings. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_emitted : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_push name v =
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (v :: stack); Nil in
|
||||
let scope_pop name =
|
||||
(match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (_ :: rest) -> Hashtbl.replace scope_stacks name rest
|
||||
| _ -> ()); Nil in
|
||||
let scope_peek name =
|
||||
match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (v :: _) -> v | _ -> Nil in
|
||||
let scope_emit name v =
|
||||
let items = try Hashtbl.find scope_emitted name with Not_found -> [] in
|
||||
Hashtbl.replace scope_emitted name (items @ [v]); Nil in
|
||||
let emitted name =
|
||||
match Hashtbl.find_opt scope_emitted name with Some l -> List l | None -> List [] in
|
||||
(* Register as both env bindings AND primitives *)
|
||||
bind "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
bind "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
(* Also register as primitives for prim_call *)
|
||||
Sx_primitives.register "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
Sx_primitives.register "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
|
||||
(* Render-mode flags *)
|
||||
ignore (env_bind env "*render-active*" (Bool false));
|
||||
bind "set-render-active!" (fun args ->
|
||||
match args with [v] -> ignore (env_set env "*render-active*" v); Nil | _ -> Nil);
|
||||
bind "render-active?" (fun _args ->
|
||||
try env_get env "*render-active*" with _ -> Bool false);
|
||||
bind "definition-form?" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Bool (List.mem s ["define"; "defcomp"; "defisland"; "defmacro";
|
||||
"defstyle"; "defhandler"; "deftype"; "defeffect"; "defquery"; "defaction"; "defrelation"])
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Signal stubs for SSR *)
|
||||
bind "signal" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "computed" (fun args -> match args with [f] -> Sx_runtime.sx_call f [] | _ -> Nil);
|
||||
bind "deref" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "reset!" (fun _args -> Nil);
|
||||
bind "swap!" (fun _args -> Nil);
|
||||
bind "effect" (fun _args -> Nil);
|
||||
bind "batch" (fun _args -> Nil);
|
||||
|
||||
(* DOM stubs *)
|
||||
bind "create-text-node" (fun args -> match args with [String s] -> String s | _ -> Nil);
|
||||
bind "create-fragment" (fun _args -> Nil);
|
||||
bind "dom-create-element" (fun _args -> Nil);
|
||||
bind "dom-append" (fun _args -> Nil);
|
||||
bind "dom-set-attr" (fun _args -> Nil);
|
||||
bind "dom-set-prop" (fun _args -> Nil);
|
||||
bind "dom-get-attr" (fun _args -> Nil);
|
||||
bind "dom-query" (fun _args -> Nil);
|
||||
bind "dom-body" (fun _args -> Nil);
|
||||
|
||||
(* Misc stubs *)
|
||||
bind "random-int" (fun args ->
|
||||
match args with
|
||||
| [Number lo; Number hi] -> Number (lo +. Float.round (Random.float (hi -. lo)))
|
||||
| _ -> Number 0.0);
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "freeze-scope" (fun _args -> Nil);
|
||||
bind "freeze-signal" (fun _args -> Nil);
|
||||
bind "thaw-from-sx" (fun _args -> Nil);
|
||||
bind "local-storage-get" (fun _args -> Nil);
|
||||
bind "local-storage-set" (fun _args -> Nil);
|
||||
bind "schedule-idle" (fun _args -> Nil);
|
||||
bind "run-post-render-hooks" (fun _args -> Nil);
|
||||
bind "freeze-to-sx" (fun _args -> String "");
|
||||
|
||||
env
|
||||
|
||||
|
||||
let () =
|
||||
Printexc.record_backtrace true;
|
||||
|
||||
(* Find project root *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/render.sx" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () else find_root parent
|
||||
in
|
||||
let root = find_root (Sys.getcwd ()) in
|
||||
let spec p = Filename.concat (Filename.concat root "spec") p in
|
||||
let web p = Filename.concat (Filename.concat root "web") p in
|
||||
|
||||
let env = make_integration_env () in
|
||||
|
||||
(* Load spec + adapters *)
|
||||
Printf.printf "Loading spec + adapters...\n%!";
|
||||
let load path =
|
||||
if Sys.file_exists path then begin
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr (Env env))) exprs;
|
||||
Printf.printf " loaded %s (%d defs)\n%!" (Filename.basename path) (List.length exprs)
|
||||
end else
|
||||
Printf.printf " SKIP %s (not found)\n%!" path
|
||||
in
|
||||
load (spec "parser.sx");
|
||||
load (spec "render.sx");
|
||||
load (web "signals.sx");
|
||||
load (web "adapter-html.sx");
|
||||
load (web "adapter-sx.sx");
|
||||
|
||||
(* Helper: render SX source string to HTML *)
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.render_to_html expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
let sx_render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "render-to-html"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | RawHTML s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: native renderer — HTML tags\n%!";
|
||||
assert_eq "div" "<div>hello</div>" (render_html "(div \"hello\")");
|
||||
assert_eq "div with class" "<div class=\"card\">text</div>" (render_html "(div :class \"card\" \"text\")");
|
||||
assert_eq "nested tags" "<div><p>inner</p></div>" (render_html "(div (p \"inner\"))");
|
||||
assert_eq "void element" "<br />" (render_html "(br)");
|
||||
assert_eq "h1" "<h1>Title</h1>" (render_html "(h1 \"Title\")");
|
||||
assert_eq "span with attrs" "<span class=\"bold\">text</span>" (render_html "(span :class \"bold\" \"text\")");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter render-to-html — HTML tags\n%!";
|
||||
assert_no_error "div doesn't throw" (fun () -> sx_render_html "(div \"hello\")");
|
||||
assert_contains "div produces tag" "<div" (sx_render_html "(div \"hello\")");
|
||||
assert_contains "div with class" "class=\"card\"" (sx_render_html "(div :class \"card\" \"text\")");
|
||||
assert_contains "nested tags" "<p>" (sx_render_html "(div (p \"inner\"))");
|
||||
assert_no_error "h1 doesn't throw" (fun () -> sx_render_html "(h1 \"Title\")");
|
||||
assert_no_error "span doesn't throw" (fun () -> sx_render_html "(span :class \"bold\" \"text\")");
|
||||
assert_no_error "table doesn't throw" (fun () -> sx_render_html "(table (tr (td \"cell\")))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — special forms in HTML context\n%!";
|
||||
assert_contains "when true renders" "<p>" (sx_render_html "(when true (p \"yes\"))");
|
||||
assert_eq "when false empty" "" (sx_render_html "(when false (p \"no\"))");
|
||||
assert_contains "if true branch" "yes" (sx_render_html "(if true (span \"yes\") (span \"no\"))");
|
||||
assert_contains "if false branch" "no" (sx_render_html "(if false (span \"yes\") (span \"no\"))");
|
||||
assert_contains "let in render" "hello" (sx_render_html "(let ((x \"hello\")) (p x))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — letrec in HTML context\n%!";
|
||||
assert_no_error "letrec with div body" (fun () ->
|
||||
sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_contains "letrec renders body" "<div>" (sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_no_error "letrec with side effects then div" (fun () ->
|
||||
sx_render_html "(letrec ((x 1) (y 2)) (let ((z (+ x y))) (div (str z))))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — components\n%!";
|
||||
assert_no_error "defcomp + render" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all "(defcomp ~test-card (&key title &rest children) (div :class \"card\" (h2 title) children))"))
|
||||
(Env env));
|
||||
sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders div" "<div" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders title" "Hi" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: eval-expr with HTML tag functions\n%!";
|
||||
assert_no_error "eval (div) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "div"; Keyword "class"; String "foo"; String "hi"]) (Env env));
|
||||
assert_no_error "eval (span) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "span"; String "text"]) (Env env));
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\n";
|
||||
Printf.printf "============================================================\n";
|
||||
Printf.printf "Integration: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "============================================================\n";
|
||||
if !fail_count > 0 then exit 1
|
||||
@@ -908,6 +908,32 @@ let make_server_env () =
|
||||
CEK, cache result). cek_call checks this before CEK dispatch. *)
|
||||
let _jit_compiling = ref false (* re-entrancy guard *)
|
||||
|
||||
(** Functions allowed for JIT compilation. Others go straight to CEK.
|
||||
Populated with compiler internals at registration time; extended
|
||||
dynamically via (jit-allow name) command. *)
|
||||
module StringSet = Set.Make(String)
|
||||
let jit_allowlist = ref (StringSet.of_list [
|
||||
(* Compiler internals *)
|
||||
"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-qq-expr";
|
||||
"compile-qq-list"; "compile-call";
|
||||
"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";
|
||||
(* Parser *)
|
||||
"sx-parse"; "sx-serialize"; "sx-serialize-dict";
|
||||
(* Pure transforms *)
|
||||
"aser"; "resolve-nav-path"; "tw"; "serialize";
|
||||
"render-to-html"; "render-attrs"; "render-html-element";
|
||||
"merge-spread-attrs"; "cssx-process-token";
|
||||
"signal"; "computed"; "freeze-scope"; "freeze-signal";
|
||||
])
|
||||
|
||||
let register_jit_hook env =
|
||||
Sx_ref.jit_call_hook := Some (fun f args ->
|
||||
@@ -920,29 +946,28 @@ let register_jit_hook env =
|
||||
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
||||
with e ->
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[jit-hook] VM FAIL %s: %s (disabling JIT)\n%!" fn_name (Printexc.to_string e);
|
||||
Printf.eprintf "[jit] DISABLED %s — %s\n%!" fn_name (Printexc.to_string e);
|
||||
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
||||
None)
|
||||
| Some _ -> None (* compile failed — CEK handles *)
|
||||
| Some _ -> None (* compile failed or disabled — CEK handles *)
|
||||
| None ->
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
if !_jit_compiling then None
|
||||
else if not (StringSet.mem fn_name !jit_allowlist) then None
|
||||
else begin
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
_jit_compiling := true;
|
||||
let t0 = Unix.gettimeofday () in
|
||||
let compiled = Sx_vm.jit_compile_lambda l env.bindings in
|
||||
let dt = Unix.gettimeofday () -. t0 in
|
||||
_jit_compiling := false;
|
||||
Printf.eprintf "[jit-hook] %s compile %s in %.3fs\n%!"
|
||||
Printf.eprintf "[jit] %s compile %s in %.3fs\n%!"
|
||||
fn_name (match compiled with Some _ -> "OK" | None -> "FAIL") dt;
|
||||
match compiled with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(* Run on VM, fall back to CEK on runtime error *)
|
||||
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
||||
with e ->
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[jit-hook] VM FAIL (first call) %s: %s (disabling JIT)\n%!" fn_name (Printexc.to_string e);
|
||||
Printf.eprintf "[jit] DISABLED %s — %s\n%!" fn_name (Printexc.to_string e);
|
||||
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
||||
None)
|
||||
| None -> None
|
||||
@@ -1106,6 +1131,10 @@ let rec dispatch env cmd =
|
||||
Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs\n%!" !count dt;
|
||||
send_ok ()
|
||||
|
||||
| List [Symbol "jit-allow"; String name] ->
|
||||
jit_allowlist := StringSet.add name !jit_allowlist;
|
||||
send_ok ()
|
||||
|
||||
| List [Symbol "aser-slot"; String src] ->
|
||||
(* Expand ALL components server-side. Uses batch IO mode.
|
||||
Calls aser via CEK — the JIT hook compiles it on first call. *)
|
||||
@@ -1449,10 +1478,69 @@ let cli_mode mode =
|
||||
Printf.eprintf "Error: %s\n" (Printexc.to_string exn); exit 1)
|
||||
|
||||
|
||||
let test_mode () =
|
||||
let env = make_server_env () in
|
||||
(* Load full spec + adapter stack *)
|
||||
let base = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
||||
let web_base = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
||||
let files = [
|
||||
Filename.concat base "parser.sx";
|
||||
Filename.concat base "render.sx";
|
||||
Filename.concat base "compiler.sx";
|
||||
Filename.concat web_base "signals.sx";
|
||||
Filename.concat web_base "adapter-html.sx";
|
||||
Filename.concat web_base "adapter-sx.sx";
|
||||
] in
|
||||
cli_load_files env files;
|
||||
(* Register JIT *)
|
||||
register_jit_hook env;
|
||||
(* Load any --load files *)
|
||||
let load_files = ref [] in
|
||||
let eval_exprs = ref [] in
|
||||
let args = Array.to_list Sys.argv in
|
||||
let rec scan = function
|
||||
| "--load" :: path :: rest -> load_files := path :: !load_files; scan rest
|
||||
| "--eval" :: expr :: rest -> eval_exprs := expr :: !eval_exprs; scan rest
|
||||
| _ :: rest -> scan rest
|
||||
| [] -> ()
|
||||
in scan args;
|
||||
cli_load_files env (List.rev !load_files);
|
||||
if !eval_exprs <> [] then
|
||||
List.iter (fun src ->
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let result = List.fold_left (fun _ e ->
|
||||
Sx_ref.eval_expr e (Env env)) Nil exprs in
|
||||
Printf.printf "%s\n%!" (serialize_value result)
|
||||
with
|
||||
| Eval_error msg -> Printf.eprintf "Error: %s\n%!" msg; exit 1
|
||||
| exn -> Printf.eprintf "Error: %s\n%!" (Printexc.to_string exn); exit 1
|
||||
) (List.rev !eval_exprs)
|
||||
else begin
|
||||
(* Read from stdin *)
|
||||
let buf = Buffer.create 4096 in
|
||||
(try while true do
|
||||
let line = input_line stdin in
|
||||
Buffer.add_string buf line; Buffer.add_char buf '\n'
|
||||
done with End_of_file -> ());
|
||||
let src = String.trim (Buffer.contents buf) in
|
||||
if src <> "" then begin
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let result = List.fold_left (fun _ e ->
|
||||
Sx_ref.eval_expr e (Env env)) Nil exprs in
|
||||
Printf.printf "%s\n%!" (serialize_value result)
|
||||
with
|
||||
| Eval_error msg -> Printf.eprintf "Error: %s\n%!" msg; exit 1
|
||||
| exn -> Printf.eprintf "Error: %s\n%!" (Printexc.to_string exn); exit 1
|
||||
end
|
||||
end
|
||||
|
||||
let () =
|
||||
(* Check for CLI mode flags *)
|
||||
let args = Array.to_list Sys.argv in
|
||||
if List.mem "--render" args then cli_mode "render"
|
||||
if List.mem "--test" args then test_mode ()
|
||||
else if List.mem "--render" args then cli_mode "render"
|
||||
else if List.mem "--aser-slot" args then cli_mode "aser-slot"
|
||||
else if List.mem "--aser" args then cli_mode "aser"
|
||||
else begin
|
||||
|
||||
@@ -84,13 +84,10 @@ let closure_to_value cl =
|
||||
let _vm_insn_count = ref 0
|
||||
let _vm_call_count = ref 0
|
||||
let _vm_cek_count = ref 0
|
||||
let _vm_closure_call_count = ref 0
|
||||
let _vm_max_depth = ref 0
|
||||
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0;
|
||||
_vm_closure_call_count := 0; _vm_max_depth := 0
|
||||
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0
|
||||
let vm_report_counters () =
|
||||
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d vm_closure=%d max_depth=%d\n%!"
|
||||
!_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_closure_call_count !_vm_max_depth
|
||||
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!"
|
||||
!_vm_insn_count !_vm_call_count !_vm_cek_count
|
||||
|
||||
(** Push a VM closure frame onto the current VM — no new VM allocation.
|
||||
This is the fast path for intra-VM closure calls. *)
|
||||
@@ -128,9 +125,6 @@ let code_from_value v =
|
||||
Used for entry points: JIT Lambda calls, module execution, cross-boundary. *)
|
||||
let rec call_closure cl args globals =
|
||||
incr _vm_call_count;
|
||||
if !_vm_call_count mod 10000 = 0 then
|
||||
Printf.eprintf "[vm-debug] call_closure count=%d name=%s\n%!"
|
||||
!_vm_call_count (match cl.vm_name with Some n -> n | None -> "anon");
|
||||
let vm = create globals in
|
||||
push_closure_frame vm cl args;
|
||||
(try run vm with e -> raise e);
|
||||
@@ -144,13 +138,6 @@ and vm_call vm f args =
|
||||
match f with
|
||||
| VmClosure cl ->
|
||||
(* Fast path: push frame on current VM — no allocation, enables TCO *)
|
||||
incr _vm_closure_call_count;
|
||||
let depth = List.length vm.frames + 1 in
|
||||
if depth > !_vm_max_depth then _vm_max_depth := depth;
|
||||
if !_vm_closure_call_count mod 100000 = 0 then
|
||||
Printf.eprintf "[vm-debug] VmClosure calls=%d depth=%d name=%s\n%!"
|
||||
!_vm_closure_call_count depth
|
||||
(match cl.vm_name with Some n -> n | None -> "anon");
|
||||
push_closure_frame vm cl args
|
||||
| NativeFn (_name, fn) ->
|
||||
let result = fn args in
|
||||
@@ -202,12 +189,6 @@ and run vm =
|
||||
if frame.ip >= Array.length bc then
|
||||
vm.frames <- [] (* bytecode exhausted — stop *)
|
||||
else begin
|
||||
incr _vm_insn_count;
|
||||
if !_vm_insn_count mod 1000000 = 0 then begin
|
||||
let fn_name = match frame.closure.vm_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[vm-debug] insns=%dM in=%s ip=%d depth=%d sp=%d\n%!"
|
||||
(!_vm_insn_count / 1000000) fn_name frame.ip (List.length vm.frames) vm.sp
|
||||
end;
|
||||
let saved_ip = frame.ip in
|
||||
let op = bc.(frame.ip) in
|
||||
frame.ip <- frame.ip + 1;
|
||||
|
||||
Reference in New Issue
Block a user