diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index d3366afd..32cc2cee 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -2095,54 +2095,53 @@ let run_spec_tests env test_files = | _ -> Nil) | "reset" -> (* Reset form elements to their default values *) - let rec reset_element el = + let get_attrs (dd : (string, Sx_types.value) Hashtbl.t) = + match Hashtbl.find_opt dd "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0 + in + let reset_input (ed : (string, Sx_types.value) Hashtbl.t) = + let attrs = get_attrs ed in + let typ = match Hashtbl.find_opt attrs "type" with Some (String t) -> String.lowercase_ascii t | _ -> "text" in + if typ = "checkbox" || typ = "radio" then + Hashtbl.replace ed "checked" (Bool (Hashtbl.mem attrs "checked")) + else + let dv = match Hashtbl.find_opt attrs "value" with Some v -> v | None -> String "" in + Hashtbl.replace ed "value" dv + in + let reset_textarea (ed : (string, Sx_types.value) Hashtbl.t) = + let attrs = get_attrs ed in + let dv = match Hashtbl.find_opt attrs "value" with + | Some v -> v + | None -> (match Hashtbl.find_opt ed "textContent" with Some v -> v | None -> String "") + in + Hashtbl.replace ed "value" dv + in + let reset_select (ed : (string, Sx_types.value) Hashtbl.t) = + let kids = match Hashtbl.find_opt ed "children" with Some (List l) -> l | _ -> [] in + let v = List.fold_left (fun (acc : string) (k : Sx_types.value) -> + match k with + | Dict od -> + let a = get_attrs od in + let ov = match Hashtbl.find_opt a "value" with Some (String s) -> s | _ -> "" in + if acc = "" then ov + else if Hashtbl.mem a "selected" then ov + else acc + | _ -> acc + ) "" kids in + Hashtbl.replace ed "value" (String v) + in + let rec reset_el (el : Sx_types.value) = match el with | Dict ed -> let tag = match Hashtbl.find_opt ed "tagName" with Some (String t) -> String.lowercase_ascii t | _ -> "" in - let attrs = match Hashtbl.find_opt ed "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0 in - (match tag with - | "input" -> - let typ = match Hashtbl.find_opt attrs "type" with Some (String t) -> String.lowercase_ascii t | _ -> "text" in - (match typ with - | "checkbox" | "radio" -> - let default_checked = Hashtbl.mem attrs "checked" in - Hashtbl.replace ed "checked" (Bool default_checked) - | _ -> - let default_value = match Hashtbl.find_opt attrs "value" with Some v -> v | None -> String "" in - Hashtbl.replace ed "value" default_value) - | "textarea" -> - (* Textarea default is from innerHTML/textContent, not value attr *) - let default_value = match Hashtbl.find_opt attrs "value" with - | Some v -> v - | None -> (match Hashtbl.find_opt ed "textContent" with Some v -> v - | None -> (match Hashtbl.find_opt ed "innerHTML" with Some v -> v | None -> String "")) in - Hashtbl.replace ed "value" default_value - | "select" -> - (* Restore first option or defaultSelected *) - let kids = match Hashtbl.find_opt ed "children" with Some (List l) -> l | _ -> [] in - let rec find_default = function - | [] -> None - | Dict od :: _ when Hashtbl.mem (match Hashtbl.find_opt od "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0) "selected" -> - Some (match Hashtbl.find_opt (match Hashtbl.find_opt od "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0) "value" with Some (String v) -> v | _ -> "") - | _ :: rest -> find_default rest in - (match find_default kids with - | Some v -> Hashtbl.replace ed "value" (String v) - | None -> - (match kids with - | Dict od :: _ -> - let v = match Hashtbl.find_opt (match Hashtbl.find_opt od "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0) "value" with Some (String v) -> v | _ -> "" in - Hashtbl.replace ed "value" (String v) - | _ -> ())) - | "form" -> - let kids = match Hashtbl.find_opt ed "children" with Some (List l) -> l | _ -> [] in - List.iter reset_element kids - | _ -> - (* Recurse into children for generic containers *) - let kids = match Hashtbl.find_opt ed "children" with Some (List l) -> l | _ -> [] in - List.iter reset_element kids); + if tag = "input" then reset_input ed + else if tag = "textarea" then reset_textarea ed + else if tag = "select" then reset_select ed + else + let kids = match Hashtbl.find_opt ed "children" with Some (List l) -> l | _ -> [] in + List.iter reset_el kids | _ -> () in - reset_element (Dict d); Nil + reset_el (Dict d); Nil | _ -> Nil) | _ -> Nil); @@ -2600,7 +2599,15 @@ let () = if l.l_name = None then None else begin l.l_compiled <- Some Sx_vm.jit_failed_sentinel; - match Sx_vm.jit_compile_lambda l globals with + (* Catch TIMEOUT during compile so the first test in a suite + doesn't time out just from JIT-compiling a large top-level + function. Sentinel is already set, so subsequent calls skip + JIT; this ensures the FIRST call falls back to CEK too. *) + match (try Sx_vm.jit_compile_lambda l globals + with Eval_error msg when + String.length msg >= 7 + && String.sub msg 0 7 = "TIMEOUT" -> None) + with | Some cl -> l.l_compiled <- Some cl; (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 4cb9c865..520f8785 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -673,6 +673,11 @@ and run vm = Primitives are seeded into vm.globals at init as NativeFn values. OP_DEFINE and registerNative naturally override them. *) let fn_val = try Hashtbl.find vm.globals name with Not_found -> + (* Fallback to Sx_primitives — primitives registered AFTER JIT + setup (e.g. host-global, host-get registered inside the test + runner's bind/register path) are not in vm.globals. *) + try Sx_primitives.get_primitive name + with _ -> raise (Eval_error ("VM: unknown primitive " ^ name)) in (match fn_val with @@ -935,6 +940,36 @@ let execute_module_safe code globals = The compilation cost is a single CEK evaluation of the compiler — microseconds per function. The result is cached in the lambda/component record so subsequent calls go straight to the VM. *) +(* Functions whose JIT bytecode is known broken (see project_jit_bytecode_bug): + parser combinators drop intermediate results, the hyperscript parse/compile + stack corrupts ASTs when compiled, and test-orchestration helpers have + call-count/arg-shape mismatches vs CEK. These must run under CEK. *) +let _jit_is_broken_name n = + (* Parser combinators *) + n = "parse-bind" || n = "seq" || n = "seq2" || n = "many" || n = "many1" + || n = "satisfy" || n = "fmap" || n = "alt" || n = "alt2" + || n = "skip-left" || n = "skip-right" || n = "skip-many" || n = "optional" + || n = "between" || n = "sep-by" || n = "sep-by1" || n = "parse-char" + || n = "parse-string" || n = "lazy-parser" || n = "label" + || n = "not-followed-by" || n = "look-ahead" + (* Hyperscript orchestrators — call parser combinators *) + || n = "hs-tokenize" || n = "hs-parse" || n = "hs-compile" + || n = "hs-to-sx" || n = "hs-to-sx-from-source" + (* Test orchestration helpers *) + || n = "eval-hs" || n = "eval-hs-inner" || n = "eval-hs-with-me" + || n = "run-hs-fixture" + (* Large top-level functions whose JIT compile exceeds the 5s test + deadline — tw-resolve-style, tw-resolve-layout, graphql parse. *) + || n = "tw-resolve-style" || n = "tw-resolve-layout" + || n = "gql-ws?" || n = "gql-parse-tokens" || n = "gql-execute-operation" + (* Hyperscript loop runtime: uses `guard` to catch hs-break/hs-continue + exceptions. JIT-compiled guard drops the exception handler such that + break propagates out of the click handler instead of exiting the loop. + See hs-upstream-repeat/hs-upstream-put tests. *) + || n = "hs-repeat-times" || n = "hs-repeat-forever" + || n = "hs-repeat-while" || n = "hs-repeat-until" + || n = "hs-for-each" || n = "hs-put!" + let jit_compile_lambda (l : lambda) globals = let fn_name = match l.l_name with Some n -> n | None -> "" in if !_jit_compiling then ( @@ -944,6 +979,12 @@ let jit_compile_lambda (l : lambda) globals = (* &key/:as require complex runtime argument processing that the compiler doesn't emit. These functions must run via CEK. *) None + ) else if l.l_name = None || l.l_closure.Sx_types.parent <> None then ( + (* Anonymous or nested lambdas: skip JIT. Nested defines get re-created + on each outer call, so per-call compile cost is pure overhead. *) + None + ) else if _jit_is_broken_name fn_name then ( + None ) else try _jit_compiling := true;