rose-ash/hosts/ocaml/sx_vm_ref.ml

(* sx_vm_ref.ml — Auto-generated from lib/vm.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *)

[@@@warning "-26-27-39"]

open Sx_types
open Sx_runtime

(* ================================================================
   Forward references for CEK interop
   ================================================================ *)

let cek_call = Sx_ref.cek_call
let eval_expr = Sx_ref.eval_expr
let trampoline v = match v with
  | Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
  | other -> other

(* SX List → OCaml list *)
let to_ocaml_list v = match v with List l -> l | Nil -> [] | _ -> [v]

(* str as NativeFn value — transpiled code passes it to sx_apply *)
let str = NativeFn ("str", fun args -> String (sx_str args))

(* Primitive call dispatch — transpiled code uses this for CALL_PRIM *)
let call_primitive name args =
  let n = value_to_string name in
  prim_call n (to_ocaml_list args)

(* ================================================================
   Preamble: 48 native OCaml functions for VM type access.
   These are SKIPPED from transpilation — the transpiled logic
   functions call them for all type construction and field access.
   ================================================================ *)

(* --- Unwrap helpers --- *)
let unwrap_vm v = match v with VmMachine m -> m | _ -> raise (Eval_error "not a vm")
let unwrap_frame v = match v with VmFrame f -> f | _ -> raise (Eval_error "not a frame")
let unwrap_closure v = match v with VmClosure c -> c | _ -> raise (Eval_error "not a closure")

(* --- Upvalue cells (internal to preamble — never SX values) --- *)
let _make_uv_cell v : vm_upvalue_cell = { uv_value = v }
let _uv_get (c : vm_upvalue_cell) = c.uv_value
let _uv_set (c : vm_upvalue_cell) v = c.uv_value <- v

(* SX-facing stubs (in skip set, never called from transpiled code) *)
let make_upvalue_cell v = Nil
let uv_get _ = Nil
let uv_set_b _ _ = Nil

(* --- VM code construction --- *)
let code_from_value v = Sx_vm.code_from_value v

let make_vm_code arity locals bytecode constants =
  (* Build a Dict that code_from_value can parse *)
  let d = Hashtbl.create 4 in
  Hashtbl.replace d "arity" arity;
  Hashtbl.replace d "bytecode" bytecode;
  Hashtbl.replace d "constants" constants;
  Dict d

(* --- VM closure --- *)
let make_vm_closure code upvalues name globals closure_env =
  let uv = match upvalues with
    | List l -> Array.of_list (List.map (fun v -> { uv_value = v }) l)
    | _ -> [||] in
  VmClosure { vm_code = code_from_value code;
              vm_upvalues = uv;
              vm_name = (match name with String s -> Some s | Nil -> None | _ -> None);
              vm_env_ref = (match globals with Dict d -> d | _ -> Hashtbl.create 0);
              vm_closure_env = (match closure_env with Env e -> Some e | _ -> None) }

(* --- VM frame --- *)
let make_vm_frame closure base =
  let cl = unwrap_closure closure in
  VmFrame { vf_closure = cl; vf_ip = 0;
            vf_base = val_to_int base;
            vf_local_cells = Hashtbl.create 4 }

(* --- VM machine --- *)
let make_vm globals =
  let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
  VmMachine { vm_stack = Array.make 4096 Nil; vm_sp = 0;
              vm_frames = []; vm_globals = g; vm_pending_cek = None }

(* --- Stack ops --- *)
let vm_push vm_val v =
  let m = unwrap_vm vm_val in
  if m.vm_sp >= Array.length m.vm_stack then begin
    let ns = Array.make (m.vm_sp * 2) Nil in
    Array.blit m.vm_stack 0 ns 0 m.vm_sp;
    m.vm_stack <- ns
  end;
  m.vm_stack.(m.vm_sp) <- v;
  m.vm_sp <- m.vm_sp + 1;
  Nil

let vm_pop vm_val =
  let m = unwrap_vm vm_val in
  m.vm_sp <- m.vm_sp - 1;
  m.vm_stack.(m.vm_sp)

let vm_peek vm_val =
  let m = unwrap_vm vm_val in
  m.vm_stack.(m.vm_sp - 1)

(* --- Frame operand reading --- *)
let frame_read_u8 frame_val =
  let f = unwrap_frame frame_val in
  let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
  f.vf_ip <- f.vf_ip + 1;
  Number (float_of_int v)

let frame_read_u16 frame_val =
  let f = unwrap_frame frame_val in
  let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
  let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
  f.vf_ip <- f.vf_ip + 2;
  Number (float_of_int (lo lor (hi lsl 8)))

let frame_read_i16 frame_val =
  let f = unwrap_frame frame_val in
  let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
  let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
  f.vf_ip <- f.vf_ip + 2;
  let v = lo lor (hi lsl 8) in
  Number (float_of_int (if v >= 32768 then v - 65536 else v))

(* --- Local variable access --- *)
let frame_local_get vm_val frame_val slot =
  let m = unwrap_vm vm_val in
  let f = unwrap_frame frame_val in
  let idx = f.vf_base + val_to_int slot in
  (* Check for shared upvalue cell *)
  match Hashtbl.find_opt f.vf_local_cells (val_to_int slot) with
  | Some cell -> cell.uv_value
  | None -> m.vm_stack.(idx)

let frame_local_set vm_val frame_val slot v =
  let m = unwrap_vm vm_val in
  let f = unwrap_frame frame_val in
  let s = val_to_int slot in
  (* If slot has a shared cell, write through cell *)
  (match Hashtbl.find_opt f.vf_local_cells s with
   | Some cell -> cell.uv_value <- v
   | None -> m.vm_stack.(f.vf_base + s) <- v);
  Nil

(* --- Upvalue access --- *)
let frame_upvalue_get frame_val idx =
  let f = unwrap_frame frame_val in
  f.vf_closure.vm_upvalues.(val_to_int idx).uv_value

let frame_upvalue_set frame_val idx v =
  let f = unwrap_frame frame_val in
  f.vf_closure.vm_upvalues.(val_to_int idx).uv_value <- v;
  Nil

(* --- Field accessors --- *)
let frame_ip f = let fr = unwrap_frame f in Number (float_of_int fr.vf_ip)
let frame_set_ip_b f v = let fr = unwrap_frame f in fr.vf_ip <- val_to_int v; Nil
let frame_base f = let fr = unwrap_frame f in Number (float_of_int fr.vf_base)
let frame_closure f = let fr = unwrap_frame f in VmClosure fr.vf_closure

let closure_code cl = let c = unwrap_closure cl in
  (* Return as Dict for code_bytecode/code_constants/code_locals *)
  let d = Hashtbl.create 4 in
  Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
  Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
  Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
  Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
  Dict d

let closure_upvalues cl = let c = unwrap_closure cl in
  List (Array.to_list (Array.map (fun cell -> cell.uv_value) c.vm_upvalues))

let closure_env cl = match cl with
  | VmClosure c -> (match c.vm_closure_env with Some e -> Env e | None -> Nil)
  | _ -> Nil

let code_bytecode code = get_val code (String "vc-bytecode")
let code_constants code = get_val code (String "vc-constants")
let code_locals code = get_val code (String "vc-locals")

let vm_sp v = let m = unwrap_vm v in Number (float_of_int m.vm_sp)
let vm_set_sp_b v s = let m = unwrap_vm v in m.vm_sp <- val_to_int s; Nil
let vm_stack v = let _m = unwrap_vm v in Nil  (* opaque — use vm_push/pop *)
let vm_set_stack_b v _s = Nil
let vm_frames v = let m = unwrap_vm v in List (List.map (fun f -> VmFrame f) m.vm_frames)
let vm_set_frames_b v fs = let m = unwrap_vm v in
  m.vm_frames <- (match fs with
    | List l -> List.map unwrap_frame l
    | _ -> []);
  Nil
let vm_globals_ref v = let m = unwrap_vm v in Dict m.vm_globals

(* --- Global variable access --- *)
let vm_global_get vm_val frame_val name =
  let m = unwrap_vm vm_val in
  let n = value_to_string name in
  (* Try globals table first *)
  match Hashtbl.find_opt m.vm_globals n with
  | Some v -> v
  | None ->
    (* Walk closure env chain *)
    let f = unwrap_frame frame_val in
    (match f.vf_closure.vm_closure_env with
     | Some env ->
       let id = intern n in
       let rec find_env e =
         match Hashtbl.find_opt e.bindings id with
         | Some v -> v
         | None -> (match e.parent with Some p -> find_env p | None ->
           (* Try evaluator's primitive table as last resort *)
           (try prim_call n [] with _ ->
             raise (Eval_error ("VM undefined: " ^ n))))
       in find_env env
     | None ->
       (try prim_call n [] with _ ->
         raise (Eval_error ("VM undefined: " ^ n))))

let vm_global_set vm_val frame_val name v =
  let m = unwrap_vm vm_val in
  let n = value_to_string name in
  let f = unwrap_frame frame_val in
  (* Write to closure env if name exists there *)
  let written = match f.vf_closure.vm_closure_env with
    | Some env ->
      let id = intern n in
      let rec find_env e =
        if Hashtbl.mem e.bindings id then
          (Hashtbl.replace e.bindings id v; true)
        else match e.parent with Some p -> find_env p | None -> false
      in find_env env
    | None -> false
  in
  if not written then begin
    Hashtbl.replace m.vm_globals n v;
    (match !_vm_global_set_hook with Some f -> f n v | None -> ())
  end;
  Nil

(* --- Frame push --- *)
let vm_push_frame vm_val closure_val args =
  let m = unwrap_vm vm_val in
  let cl = unwrap_closure closure_val in
  let f = { vf_closure = cl; vf_ip = 0; vf_base = m.vm_sp; vf_local_cells = Hashtbl.create 4 } in
  let arg_list = to_ocaml_list args in
  List.iter (fun a ->
    m.vm_stack.(m.vm_sp) <- a; m.vm_sp <- m.vm_sp + 1
  ) arg_list;
  (* Pad remaining locals *)
  for _ = List.length arg_list to cl.vm_code.vc_locals - 1 do
    m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
  done;
  m.vm_frames <- f :: m.vm_frames;
  Nil

(* --- Closure type check --- *)
let vm_closure_p v = match v with VmClosure _ -> Bool true | _ -> Bool false

(* --- Closure creation (upvalue capture) --- *)
let vm_create_closure vm_val frame_val code_val =
  let m = unwrap_vm vm_val in
  let f = unwrap_frame frame_val in
  let uv_count = match code_val with
    | Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
        | Some (Number n) -> int_of_float n | _ -> 0)
    | _ -> 0
  in
  let upvalues = Array.init uv_count (fun _ ->
    let is_local = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
    let index = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
    if is_local = 1 then begin
      match Hashtbl.find_opt f.vf_local_cells index with
      | Some existing -> existing
      | None ->
        let c = { uv_value = m.vm_stack.(f.vf_base + index) } in
        Hashtbl.replace f.vf_local_cells index c;
        c
    end else
      f.vf_closure.vm_upvalues.(index)
  ) in
  let code = code_from_value code_val in
  VmClosure { vm_code = code; vm_upvalues = upvalues; vm_name = None;
              vm_env_ref = m.vm_globals; vm_closure_env = f.vf_closure.vm_closure_env }

(* --- JIT sentinel --- *)
let _jit_failed_sentinel = {
  vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
              vc_bytecode_list = None; vc_constants_list = None };
  vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let _is_jit_failed cl = cl.vm_code.vc_arity = -1

(* --- Lambda accessors --- *)
let is_lambda v = match v with Lambda _ -> Bool true | _ -> Bool false
let lambda_compiled v = match v with
  | Lambda l -> (match l.l_compiled with Some c -> VmClosure c | None -> Nil)
  | _ -> Nil
let lambda_set_compiled_b v c = match v with
  | Lambda l -> (match c with
    | VmClosure cl -> l.l_compiled <- Some cl; Nil
    | String "jit-failed" -> l.l_compiled <- Some _jit_failed_sentinel; Nil
    | _ -> l.l_compiled <- None; Nil)
  | _ -> Nil
let lambda_name v = match v with
  | Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
  | _ -> Nil

(* --- CEK call with suspension awareness --- *)
let cek_call_or_suspend vm_val f args =
  let a = to_ocaml_list args in
  let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
  let final = Sx_ref.cek_step_loop state in
  match get_val final (String "phase") with
  | String "io-suspended" ->
    let m = unwrap_vm vm_val in
    m.vm_pending_cek <- Some final;
    raise (Sx_vm.VmSuspended (get_val final (String "request"), Sx_vm.create m.vm_globals))
  | _ -> Sx_ref.cek_value final

(* --- Env walking (for global variable resolution) --- *)
let rec env_walk env name =
  match env with
  | Env e ->
    let id = intern (value_to_string name) in
    let rec find e =
      match Hashtbl.find_opt e.bindings id with
      | Some v -> v
      | None -> (match e.parent with Some p -> find p | None -> Nil)
    in find e
  | Nil -> Nil
  | _ -> Nil

let env_walk_set_b env name value =
  match env with
  | Env e ->
    let id = intern (value_to_string name) in
    let rec find e =
      if Hashtbl.mem e.bindings id then
        (Hashtbl.replace e.bindings id value; true)
      else match e.parent with Some p -> find p | None -> false
    in
    if find e then Nil else Nil
  | _ -> Nil

(* --- Active VM tracking (module-level mutable state) --- *)
let _active_vm : vm_machine option ref = ref None

(* Forward ref — resolved after transpiled let rec block *)
let _vm_run_fn : (value -> value) ref = ref (fun _ -> Nil)
let _vm_call_fn : (value -> value -> value -> value) ref = ref (fun _ _ _ -> Nil)

(* vm-call-closure: creates fresh VM, runs closure, returns result *)
let vm_call_closure closure_val args globals =
  let cl = unwrap_closure closure_val in
  let prev_vm = !_active_vm in
  let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
  let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
            vm_frames = []; vm_globals = g; vm_pending_cek = None } in
  let vm_val = VmMachine m in
  _active_vm := Some m;
  ignore (vm_push_frame vm_val closure_val args);
  (try ignore (!_vm_run_fn vm_val) with e -> _active_vm := prev_vm; raise e);
  _active_vm := prev_vm;
  vm_pop vm_val

(* --- JIT dispatch (platform-specific) --- *)
let try_jit_call vm_val f args =
  let m = unwrap_vm vm_val in
  match f with
  | Lambda l ->
    (match l.l_compiled with
     | Some cl when not (_is_jit_failed cl) ->
       (try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
        with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
     | Some _ ->
       vm_push vm_val (cek_call_or_suspend vm_val f args)
     | None ->
       if l.l_name <> None then begin
         l.l_compiled <- Some _jit_failed_sentinel;
         match !Sx_vm.jit_compile_ref l m.vm_globals with
         | Some cl ->
           l.l_compiled <- Some cl;
           (try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
            with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
         | None ->
           vm_push vm_val (cek_call_or_suspend vm_val f args)
       end else
         vm_push vm_val (cek_call_or_suspend vm_val f args))
  | _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)

(* --- Collection helpers --- *)
let collect_n_from_stack vm_val n =
  let m = unwrap_vm vm_val in
  let count = val_to_int n in
  let result = ref [] in
  for _ = 1 to count do
    m.vm_sp <- m.vm_sp - 1;
    result := m.vm_stack.(m.vm_sp) :: !result
  done;
  List !result

let collect_n_pairs vm_val n =
  let m = unwrap_vm vm_val in
  let count = val_to_int n in
  let d = Hashtbl.create count in
  for _ = 1 to count do
    m.vm_sp <- m.vm_sp - 1;
    let v = m.vm_stack.(m.vm_sp) in
    m.vm_sp <- m.vm_sp - 1;
    let k = value_to_string m.vm_stack.(m.vm_sp) in
    Hashtbl.replace d k v
  done;
  Dict d

let pad_n_nils vm_val n =
  let m = unwrap_vm vm_val in
  let count = val_to_int n in
  for _ = 1 to count do
    m.vm_stack.(m.vm_sp) <- Nil;
    m.vm_sp <- m.vm_sp + 1
  done;
  Nil


(* === Transpiled from lib/vm.sx === *)
(* vm-call *)
let rec vm_call vm f args =
  (if sx_truthy ((vm_closure_p (f))) then (vm_push_frame (vm) (f) (args)) else (if sx_truthy ((is_lambda (f))) then (try_jit_call (vm) (f) (args)) else (if sx_truthy ((let _or = (prim_call "=" [(type_of (f)); (String "component")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (f)); (String "island")]))) then (vm_push (vm) ((cek_call_or_suspend (vm) (f) (args)))) else (if sx_truthy ((is_callable (f))) then (vm_push (vm) ((sx_apply f args))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: not callable: "); (type_of (f))])))))))))

(* vm-resolve-ho-form *)
and vm_resolve_ho_form vm name =
  (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List.iter (fun x -> ignore ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll); Nil)) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.map (fun x -> (vm_call_external (vm) (f) ((List [x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.mapi (fun i x -> let i = Number (float_of_int i) in (vm_call_external (vm) (f) ((List [i; x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.filter (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; init; coll] -> (fun f init coll -> (List.fold_left (fun acc x -> (vm_call_external (vm) (f) ((List [acc; x])))) init (sx_to_list coll))) f init coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.exists (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.for_all (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM undefined: "); name])))))))))))))

(* vm-call-external *)
and vm_call_external vm f args =
  (if sx_truthy ((vm_closure_p (f))) then (vm_call_closure (f) (args) ((vm_globals_ref (vm)))) else (cek_call (f) (args)))

(* vm-run *)
and vm_run vm =
  (let () = ignore ((String "Execute bytecode until all frames are done or IO suspension.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (_> (frame) (frame_closure) (closure_code) (code_bytecode)) in let consts = (_> (frame) (frame_closure) (closure_code) (code_constants)) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (if sx_truthy ((is_nil ((get ((vm_globals_ref (vm))) ((String "__io_request")))))) then (loop ()) else Nil))))) else Nil)) in (loop ())))

(* vm-step *)
and vm_step vm frame rest_frames bc consts =
  (let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (sx_dict_set_b (vm_globals_ref (vm)) (String "__io_request") request)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op])))))))))))))))))))))))))))))))))))))))))))))))



(* Wire forward references to transpiled functions *)
let () = _vm_run_fn := vm_run
let () = _vm_call_fn := vm_call

(* ================================================================
   Public API — matches Sx_vm interface for drop-in replacement
   ================================================================ *)

(** Build a suspension dict from __io_request in globals. *)
let check_io_suspension globals vm_val =
  match Hashtbl.find_opt globals "__io_request" with
  | Some req when sx_truthy req ->
    let d = Hashtbl.create 4 in
    Hashtbl.replace d "suspended" (Bool true);
    Hashtbl.replace d "op" (String "import");
    Hashtbl.replace d "request" req;
    Hashtbl.replace d "vm" vm_val;
    Some (Dict d)
  | _ -> None

(** Execute a compiled module — entry point for load-sxbc, compile-blob.
    Returns the result value, or a suspension dict if OP_PERFORM fired. *)
let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
  let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module";
             vm_env_ref = globals; vm_closure_env = None } in
  let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
            vm_frames = []; vm_globals = globals; vm_pending_cek = None } in
  let vm_val = VmMachine m in
  let frame = { vf_closure = cl; vf_ip = 0; vf_base = 0; vf_local_cells = Hashtbl.create 4 } in
  for _ = 0 to code.vc_locals - 1 do
    m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
  done;
  m.vm_frames <- [frame];
  ignore (vm_run vm_val);
  match check_io_suspension globals vm_val with
  | Some suspension -> suspension
  | None -> vm_pop vm_val

(** Resume a suspended module. Clears __io_request, pushes nil, re-runs. *)
let resume_module (suspended : value) =
  match suspended with
  | Dict d ->
    let vm_val = Hashtbl.find d "vm" in
    let globals = match vm_val with
      | VmMachine m -> m.vm_globals
      | _ -> raise (Eval_error "resume_module: expected VmMachine") in
    Hashtbl.replace globals "__io_request" Nil;
    ignore (vm_push vm_val Nil);
    ignore (vm_run vm_val);
    (match check_io_suspension globals vm_val with
     | Some suspension -> suspension
     | None -> vm_pop vm_val)
  | _ -> raise (Eval_error "resume_module: expected suspension dict")

(** Execute a closure with args — entry point for JIT Lambda calls. *)
let call_closure (cl : vm_closure) (args : value list) (globals : (string, value) Hashtbl.t) =
  vm_call_closure (VmClosure cl) (List args) (Dict globals)

(** Reexport code_from_value for callers *)
let code_from_value = code_from_value

(** Reexport jit refs *)
let jit_compile_ref = Sx_vm.jit_compile_ref
let jit_failed_sentinel = _jit_failed_sentinel
let is_jit_failed = _is_jit_failed