From 2a5ef0ea09fd2b67287c7279bbf7013bff0ed08a Mon Sep 17 00:00:00 2001 From: giles Date: Mon, 23 Mar 2026 12:22:54 +0000 Subject: [PATCH] JIT: restore re-entrancy guards, compile quasiquote inline, closure env merging Fix infinite recursion in VM JIT: restore sentinel pre-mark in vm_call and pre-compile loop so recursive compiler functions don't trigger unbounded compilation cascades. Runtime VM errors fall back to CEK; compile errors surface visibly (not silently swallowed). New: compile-quasiquote emits inline code instead of delegating to qq-expand-runtime. Closure-captured variables merged into VM globals so compiled closures resolve outer bindings via GLOBAL_GET. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/sx_server.ml | 35 ++++------------ hosts/ocaml/lib/sx_vm.ml | 50 +++++++++++++++------- spec/compiler.sx | 80 ++++++++++++++++++++++++++++++++---- 3 files changed, 118 insertions(+), 47 deletions(-) diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index f758702..f335fbf 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -814,24 +814,14 @@ let register_jit_hook env = | Lambda l -> (match l.l_compiled with | Some cl when not (Sx_vm.is_jit_failed cl) -> - (* Cached bytecode — execute on VM, fall back to CEK on error. - Don't invalidate cache — bytecode is correct, error is runtime. *) + (* Cached bytecode — run on VM, fall back to CEK on runtime error *) (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with _ -> None) - | Some _ -> None (* failed sentinel *) + | Some _ -> None (* compile failed — CEK handles *) | None -> - (* Don't try to compile while already compiling (prevents - infinite recursion: compile calls lambdas internally) *) if !_jit_compiling then None else begin let fn_name = match l.l_name with Some n -> n | None -> "?" in - begin - (* Mark as tried BEFORE compiling — prevents other calls to - the same lambda from starting redundant compilations while - this one is running. If compilation succeeds, overwrite. *) - l.l_compiled <- Some Sx_vm.jit_failed_sentinel; - Printf.eprintf "[jit-hook] compiling %s (body size ~%d)...\n%!" - fn_name (String.length (inspect l.l_body)); _jit_compiling := true; let t0 = Unix.gettimeofday () in let compiled = Sx_vm.jit_compile_lambda l env.bindings in @@ -842,16 +832,11 @@ let register_jit_hook env = match compiled with | Some cl -> l.l_compiled <- Some cl; - Printf.eprintf "[jit-hook] executing %s on VM...\n%!" fn_name; - (try - let r = Sx_vm.call_closure cl args cl.vm_env_ref in - Printf.eprintf "[jit-hook] %s execution OK\n%!" fn_name; - Some r - with e -> - Printf.eprintf "[jit-hook] %s VM FAIL: %s\n%!" fn_name (Printexc.to_string e); - l.l_compiled <- Some Sx_vm.jit_failed_sentinel; None) + (* Run on VM, fall back to CEK on runtime error *) + (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) + with _ -> None) | None -> None - end end) + end) | _ -> None) @@ -992,7 +977,8 @@ let rec dispatch env cmd = | Some cl -> l.l_compiled <- Some cl; incr count - | None -> ()) + | None -> + Printf.eprintf "[jit] pre-compile FAIL: %s\n%!" name) | _ -> () ) compiler_fns; let dt = Unix.gettimeofday () -. t0 in @@ -1072,14 +1058,11 @@ let rec dispatch env cmd = let t0 = Unix.gettimeofday () in let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in ignore (env_bind env "expand-components?" expand_fn); - Printf.eprintf "[sx-page-full] starting aser eval...\n%!"; let body_result = let call = List [Symbol "aser"; List [Symbol "quote"; expr]; Env env] in - let r = Sx_ref.eval_expr call (Env env) in - Printf.eprintf "[sx-page-full] aser eval returned\n%!"; - r + Sx_ref.eval_expr call (Env env) in let t1 = Unix.gettimeofday () in io_batch_mode := false; diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 0161553..c13254f 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -81,6 +81,14 @@ let closure_to_value cl = fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args)))) (* Placeholder — actual calls go through vm_call below *) +let _vm_insn_count = ref 0 +let _vm_call_count = ref 0 +let _vm_cek_count = ref 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\n%!" + !_vm_insn_count !_vm_call_count !_vm_cek_count + (** Main execution loop. *) let rec run vm = match vm.frames with @@ -310,21 +318,15 @@ and vm_call vm f args = let result = fn args in push vm result | Lambda l -> - (* Try JIT-compiled path first *) (match l.l_compiled with | Some cl when not (is_jit_failed cl) -> - (* Execute cached bytecode; fall back to CEK on VM error. - Don't mark as failed — the bytecode is correct, the error - is from runtime data (e.g. type mismatch in get). *) + (* Cached bytecode — run on VM, fall back to CEK on runtime error *) (try push vm (call_closure cl args vm.globals) with _ -> push vm (Sx_ref.cek_call f (List args))) | Some _ -> - (* Previously failed or skipped — use CEK *) + (* Compile failed — CEK *) push vm (Sx_ref.cek_call f (List args)) | None -> - (* Only JIT-compile named lambdas (from define). - Anonymous lambdas (map/filter callbacks) are usually one-shot — - compiling them costs more than interpreting. *) if l.l_name <> None then begin (* Pre-mark before compile attempt to prevent re-entrancy *) l.l_compiled <- Some jit_failed_sentinel; @@ -338,13 +340,11 @@ and vm_call vm f args = | None -> push vm (Sx_ref.cek_call f (List args)) end - else begin - (* Mark anonymous lambdas as skipped to avoid re-checking *) - l.l_compiled <- Some jit_failed_sentinel; - push vm (Sx_ref.cek_call f (List args)) - end) + else + push vm (Sx_ref.cek_call f (List args))) | Component _ | Island _ -> (* Components use keyword-arg parsing — CEK handles this *) + incr _vm_cek_count; let result = Sx_ref.cek_call f (List args) in push vm result | _ -> @@ -417,6 +417,28 @@ let jit_compile_lambda (l : lambda) globals = let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in let quoted = List [Symbol "quote"; fn_expr] in let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in + (* If the lambda has closure-captured variables, merge them into globals + so the VM can find them via GLOBAL_GET. The compiler doesn't know + about the enclosing scope, so closure vars get compiled as globals. *) + let effective_globals = + let closure = l.l_closure in + if Hashtbl.length closure.bindings = 0 && closure.parent = None then + globals (* no closure vars — use globals directly *) + else begin + (* Merge: closure bindings layered on top of globals. + Use a shallow copy so we don't pollute the real globals. *) + let merged = Hashtbl.copy globals in + let rec inject env = + Hashtbl.iter (fun k v -> Hashtbl.replace merged k v) env.bindings; + match env.parent with Some p -> inject p | None -> () + in + inject closure; + let n = Hashtbl.length merged - Hashtbl.length globals in + if n > 0 then + Printf.eprintf "[jit] %s: injected %d closure bindings\n%!" fn_name n; + merged + end + in match result with | Dict d when Hashtbl.mem d "bytecode" -> let outer_code = code_from_value result in @@ -427,7 +449,7 @@ let jit_compile_lambda (l : lambda) globals = let inner_val = outer_code.vc_constants.(idx) in let code = code_from_value inner_val in Some { vm_code = code; vm_upvalues = [||]; - vm_name = l.l_name; vm_env_ref = globals } + vm_name = l.l_name; vm_env_ref = effective_globals } else begin Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!" fn_name idx (Array.length outer_code.vc_constants); diff --git a/spec/compiler.sx b/spec/compiler.sx index cbc7533..b40db91 100644 --- a/spec/compiler.sx +++ b/spec/compiler.sx @@ -601,13 +601,79 @@ (define compile-quasiquote (fn (em expr scope) - "Compile quasiquote — look up qq-expand-runtime in globals and call it. - Uses GLOBAL_GET + CALL (not CALL_PRIM) since it's a runtime function." - ;; Stack: push fn first, then arg, then CALL 1 - (let ((name-idx (pool-add (get em "pool") "qq-expand-runtime"))) - (emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn - (emit-const em expr) ;; push template - (emit-op em 48) (emit-byte em 1))) + "Compile quasiquote inline — walks the template at compile time, + emitting code that builds the structure at runtime. Unquoted + expressions are compiled normally (resolving locals/upvalues), + avoiding the qq-expand-runtime env-lookup limitation." + (compile-qq-expr em expr scope))) + +(define compile-qq-expr + (fn (em expr scope) + "Compile a quasiquote sub-expression." + (if (not (= (type-of expr) "list")) + ;; Atom — emit as constant + (emit-const em expr) + (if (empty? expr) + ;; Empty list + (do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0 + (let ((head (first expr))) + (if (and (= (type-of head) "symbol") + (= (symbol-name head) "unquote")) + ;; (unquote expr) — compile the expression + (compile-expr em (nth expr 1) scope false) + ;; List — compile elements, handling splice-unquote + (compile-qq-list em expr scope))))))) + +(define compile-qq-list + (fn (em items scope) + "Compile a quasiquote list. Handles splice-unquote by building + segments and concatenating them." + (let ((has-splice (some (fn (item) + (and (= (type-of item) "list") + (>= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote"))) + items))) + (if (not has-splice) + ;; No splicing — compile each element, then OP_LIST + (do + (for-each (fn (item) (compile-qq-expr em item scope)) items) + (emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N + ;; Has splicing — build segments and concat + ;; Strategy: accumulate non-spliced items into a pending list, + ;; flush as OP_LIST when hitting a splice, concat all segments. + (let ((segment-count 0) + (pending 0)) + (for-each + (fn (item) + (if (and (= (type-of item) "list") + (>= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote")) + ;; Splice-unquote: flush pending, compile spliced expr + (do + (when (> pending 0) + (emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending + (set! segment-count (+ segment-count 1)) + (set! pending 0)) + ;; Compile the spliced expression + (compile-expr em (nth item 1) scope false) + (set! segment-count (+ segment-count 1))) + ;; Normal element — compile and count as pending + (do + (compile-qq-expr em item scope) + (set! pending (+ pending 1))))) + items) + ;; Flush remaining pending items + (when (> pending 0) + (emit-op em 64) (emit-u16 em pending) + (set! segment-count (+ segment-count 1))) + ;; Concat all segments + (when (> segment-count 1) + (let ((concat-idx (pool-add (get em "pool") "concat"))) + ;; concat takes N args — call with all segments + (emit-op em 52) (emit-u16 em concat-idx) + (emit-byte em segment-count)))))))) ;; --------------------------------------------------------------------------