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

JIT: restore re-entrancy guards, compile quasiquote inline, closure env merging

Browse Source 
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) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-23 12:22:54 +00:00
parent 1cc3e761a2
commit 2a5ef0ea09
3 changed files with 118 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -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;

50
hosts/ocaml/lib/sx_vm.ml
View File

@@ -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);

80
spec/compiler.sx
View File

@@ -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))))))))
;; --------------------------------------------------------------------------