Fix WASM browser click handlers: 8 bugs, 50 new VM tests
The sx-get links were doing full page refreshes because click handlers never attached. Root causes: VM frame management bug, missing primitives, CEK/VM type dispatch mismatch, and silent error swallowing. Fixes: - VM frame exhaustion: frames <- [] now properly pops to rest_frames - length primitive: add alias for len in OCaml primitives - call_sx_fn: use sx_call directly instead of eval_expr (CEK checks for type "lambda" but VmClosure reports "function") - Boot error surfacing: Sx.init() now has try/catch + failure summary - Callback error surfacing: catch-all handler for non-Eval_error exceptions - Silent JIT failures: log before CEK fallback instead of swallowing - vm→env sync: loadModule now calls sync_vm_to_env() - sx_build_bytecode MCP tool added for bytecode compilation Tests: 50 new tests across test-vm.sx and test-vm-primitives.sx covering nested VM calls, frame integrity, CEK bridge, primitive availability, cross-module symbol resolution, and callback dispatch. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -58,7 +58,8 @@ let global_env = make_env ()
|
||||
let _sx_render_mode = ref false
|
||||
|
||||
let call_sx_fn (fn : value) (args : value list) : value =
|
||||
Sx_ref.eval_expr (List (fn :: args)) (Env global_env)
|
||||
let result = Sx_runtime.sx_call fn args in
|
||||
!Sx_primitives._sx_trampoline_fn result
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Value conversion: OCaml <-> JS *)
|
||||
@@ -107,10 +108,18 @@ let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
let args = match arg with Nil -> [] | _ -> [arg] in
|
||||
let result = call_sx_fn v args in
|
||||
value_to_js result
|
||||
with Eval_error msg ->
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] " ^ msg)) |]);
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] " ^ msg ^ fn_info)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] UNCAUGHT: " ^ Printexc.to_string exn ^ fn_info)) |]);
|
||||
Js.Unsafe.inject Js.null) in
|
||||
Js.Unsafe.fun_call _tag_fn [|
|
||||
Js.Unsafe.inject inner;
|
||||
@@ -189,6 +198,31 @@ and js_to_value (js : Js.Unsafe.any) : value =
|
||||
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v; v
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Persistent VM globals — synced with global_env *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* String-keyed mirror of global_env.bindings for VmClosures.
|
||||
VmClosures from bytecode modules hold vm_env_ref pointing here.
|
||||
Must stay in sync so VmClosures see post-boot definitions. *)
|
||||
let _vm_globals : (string, value) Hashtbl.t = Hashtbl.create 512
|
||||
let _in_batch = ref false
|
||||
|
||||
(* Sync env→VM: copy all bindings from global_env.bindings to _vm_globals.
|
||||
Called after CEK eval/load so VmClosures can see new definitions. *)
|
||||
let sync_env_to_vm () =
|
||||
Hashtbl.iter (fun id v ->
|
||||
Hashtbl.replace _vm_globals (unintern id) v
|
||||
) global_env.bindings
|
||||
|
||||
(* Hook: intercept env_bind on global_env to also update _vm_globals.
|
||||
This ensures VmClosures see new definitions immediately, even during
|
||||
a single boot-init call that loads page scripts and components. *)
|
||||
let () =
|
||||
Sx_types._env_bind_hook := Some (fun env name v ->
|
||||
if env == global_env then
|
||||
Hashtbl.replace _vm_globals name v)
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Core API *)
|
||||
(* ================================================================== *)
|
||||
@@ -207,6 +241,7 @@ let api_eval src_js =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let result = List.fold_left (fun _acc expr -> Sx_ref.eval_expr expr env) Nil exprs in
|
||||
sync_env_to_vm ();
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
@@ -215,7 +250,9 @@ let api_eval src_js =
|
||||
let api_eval_expr expr_js _env_js =
|
||||
let expr = js_to_value expr_js in
|
||||
try
|
||||
return_via_side_channel (value_to_js (Sx_ref.eval_expr expr (Env global_env)))
|
||||
let result = Sx_ref.eval_expr expr (Env global_env) in
|
||||
sync_env_to_vm ();
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
@@ -226,56 +263,66 @@ let api_load src_js =
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr env); incr count) exprs;
|
||||
sync_env_to_vm ();
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(* Shared globals table for batch module loading.
|
||||
Created by beginModuleLoad, accumulated across loadModule calls,
|
||||
flushed to env by endModuleLoad. Ensures closures from early
|
||||
modules can see definitions from later modules. *)
|
||||
let _module_globals : (string, value) Hashtbl.t option ref = ref None
|
||||
|
||||
let api_begin_module_load () =
|
||||
let g = Hashtbl.create 512 in
|
||||
Hashtbl.iter (fun id v -> Hashtbl.replace g (unintern id) v) global_env.bindings;
|
||||
_module_globals := Some g;
|
||||
(* Snapshot current env into the persistent VM globals table *)
|
||||
Hashtbl.clear _vm_globals;
|
||||
Hashtbl.iter (fun id v -> Hashtbl.replace _vm_globals (unintern id) v) global_env.bindings;
|
||||
_in_batch := true;
|
||||
Js.Unsafe.inject true
|
||||
|
||||
let api_end_module_load () =
|
||||
(match !_module_globals with
|
||||
| Some g ->
|
||||
Hashtbl.iter (fun k v ->
|
||||
Hashtbl.replace global_env.bindings (intern k) v
|
||||
) g;
|
||||
_module_globals := None
|
||||
| None -> ());
|
||||
if !_in_batch then begin
|
||||
(* Copy VM globals back to env (bytecode modules defined new symbols) *)
|
||||
Hashtbl.iter (fun k v ->
|
||||
Hashtbl.replace global_env.bindings (intern k) v
|
||||
) _vm_globals;
|
||||
_in_batch := false
|
||||
end;
|
||||
Js.Unsafe.inject true
|
||||
|
||||
let sync_vm_to_env () =
|
||||
Hashtbl.iter (fun name v ->
|
||||
let id = intern name in
|
||||
if not (Hashtbl.mem global_env.bindings id) then
|
||||
Hashtbl.replace global_env.bindings id v
|
||||
else begin
|
||||
(* Update existing binding if the VM has a newer value *)
|
||||
let existing = Hashtbl.find global_env.bindings id in
|
||||
match existing, v with
|
||||
| VmClosure _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
|
||||
| _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
|
||||
| _ -> ()
|
||||
end
|
||||
) _vm_globals
|
||||
|
||||
let api_load_module module_js =
|
||||
try
|
||||
let code_val = js_to_value module_js in
|
||||
let code = Sx_vm.code_from_value code_val in
|
||||
let globals = match !_module_globals with
|
||||
| Some g -> g (* use shared table *)
|
||||
| None ->
|
||||
(* standalone mode: create temp table *)
|
||||
let g = Hashtbl.create 256 in
|
||||
Hashtbl.iter (fun id v -> Hashtbl.replace g (unintern id) v) global_env.bindings;
|
||||
g
|
||||
in
|
||||
let _result = Sx_vm.execute_module code globals in
|
||||
(* If standalone (no batch), copy back immediately *)
|
||||
if !_module_globals = None then
|
||||
Hashtbl.iter (fun k v ->
|
||||
Hashtbl.replace global_env.bindings (intern k) v
|
||||
) globals;
|
||||
Js.Unsafe.inject (Hashtbl.length globals)
|
||||
let _result = Sx_vm.execute_module code _vm_globals in
|
||||
sync_vm_to_env ();
|
||||
Js.Unsafe.inject (Hashtbl.length _vm_globals)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
||||
|
||||
let api_debug_env name_js =
|
||||
let name = Js.to_string name_js in
|
||||
let id = intern name in
|
||||
let found_env = Hashtbl.find_opt global_env.bindings id in
|
||||
let found_vm = Hashtbl.find_opt _vm_globals name in
|
||||
let total_env = Hashtbl.length global_env.bindings in
|
||||
let total_vm = Hashtbl.length _vm_globals in
|
||||
let env_s = match found_env with Some v -> "env:" ^ type_of v | None -> "env:MISSING" in
|
||||
let vm_s = match found_vm with Some v -> "vm:" ^ type_of v | None -> "vm:MISSING" in
|
||||
Js.Unsafe.inject (Js.string (Printf.sprintf "%s %s (env=%d vm=%d)" env_s vm_s total_env total_vm))
|
||||
|
||||
let api_compile_module src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
@@ -318,7 +365,9 @@ let api_register_native name_js callback_js =
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
js_to_value (Js.Unsafe.fun_call callback_js [| Js.Unsafe.inject (Js.array js_args) |])
|
||||
in
|
||||
ignore (env_bind global_env name (NativeFn (name, native_fn)));
|
||||
let v = NativeFn (name, native_fn) in
|
||||
ignore (env_bind global_env name v);
|
||||
Hashtbl.replace _vm_globals name v;
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
let api_call_fn fn_js args_js =
|
||||
@@ -627,18 +676,12 @@ let _jit_compiling = ref false
|
||||
let _jit_enabled = ref false
|
||||
|
||||
let () =
|
||||
(* Convert int-keyed env.bindings to string-keyed Hashtbl for VM globals *)
|
||||
let env_to_vm_globals env =
|
||||
let g = Hashtbl.create (Hashtbl.length env.bindings) in
|
||||
Hashtbl.iter (fun id v -> Hashtbl.replace g (unintern id) v) env.bindings;
|
||||
g
|
||||
in
|
||||
Sx_ref.jit_call_hook := Some (fun f args ->
|
||||
match f with
|
||||
| Lambda l when !_jit_enabled ->
|
||||
(match l.l_compiled with
|
||||
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
||||
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
||||
(try Some (Sx_vm.call_closure cl args _vm_globals)
|
||||
with Eval_error msg ->
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[jit] DISABLED %s — %s\n%!" fn_name msg;
|
||||
@@ -649,13 +692,12 @@ let () =
|
||||
if !_jit_compiling then None
|
||||
else begin
|
||||
_jit_compiling := true;
|
||||
let globals = env_to_vm_globals global_env in
|
||||
let compiled = Sx_vm.jit_compile_lambda l globals in
|
||||
let compiled = Sx_vm.jit_compile_lambda l _vm_globals in
|
||||
_jit_compiling := false;
|
||||
(match compiled with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
||||
(try Some (Sx_vm.call_closure cl args _vm_globals)
|
||||
with _ ->
|
||||
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
||||
None)
|
||||
@@ -693,5 +735,6 @@ let () =
|
||||
Js.Unsafe.set sx (Js.string "callFn") (wrap api_call_fn);
|
||||
Js.Unsafe.set sx (Js.string "isCallable") (Js.wrap_callback api_is_callable);
|
||||
Js.Unsafe.set sx (Js.string "fnArity") (Js.wrap_callback api_fn_arity);
|
||||
Js.Unsafe.set sx (Js.string "debugEnv") (Js.wrap_callback api_debug_env);
|
||||
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||
|
||||
Reference in New Issue
Block a user