diff --git a/hosts/ocaml/bootstrap_vm.py b/hosts/ocaml/bootstrap_vm.py index 10f17f40..f2ecbe48 100644 --- a/hosts/ocaml/bootstrap_vm.py +++ b/hosts/ocaml/bootstrap_vm.py @@ -72,6 +72,11 @@ SKIP = { "vm-create-closure", # Lambda accessors (native type) "lambda?", "lambda-compiled", "lambda-set-compiled!", "lambda-name", + # JIT dispatch (platform-specific) + "*active-vm*", "*jit-compile-fn*", + "try-jit-call", + # Env access (used by env-walk) + "env-walk", "env-walk-set!", # CEK interop "cek-call-or-suspend", # Collection helpers (use mutable state + recursion) @@ -83,139 +88,401 @@ PREAMBLE = """\ (* sx_vm_ref.ml — Auto-generated from lib/vm.sx *) (* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *) -[@@@warning "-26-27"] +[@@@warning "-26-27-39"] open Sx_types open Sx_runtime -(* Forward references for CEK interop *) +(* ================================================================ + 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 -(* Primitive call dispatch *) +(* 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 = - Sx_primitives.prim_call (value_to_string name) (list_to_ocaml_list args) + let n = value_to_string name in + prim_call n (to_ocaml_list args) (* ================================================================ - Preamble: native OCaml type construction + field access + 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. ================================================================ *) -(* --- Upvalue cells --- *) -let make_upvalue_cell v = let c = { uv_value = v } in UvCell c -let uv_get c = match c with UvCell cell -> cell.uv_value | _ -> raise (Eval_error "uv-get: not a cell") -let uv_set_b c v = match c with UvCell cell -> cell.uv_value <- v | _ -> raise (Eval_error "uv-set!: not a cell") +(* --- 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 -(* --- VM code --- *) let make_vm_code arity locals bytecode constants = - let bc = match bytecode with - | List l -> Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l) - | _ -> [||] in - let cs = match constants with - | List l -> Array.of_list l - | _ -> [||] in - let code = { vc_arity = val_to_int arity; vc_locals = val_to_int locals; - vc_bytecode = bc; vc_constants = cs } in - (* Return as a Dict wrapper so SX code can pass it around *) + (* Build a Dict that code_from_value can parse *) let d = Hashtbl.create 4 in - Hashtbl.replace d "vc-bytecode" bytecode; - Hashtbl.replace d "vc-constants" constants; - Hashtbl.replace d "vc-arity" arity; - Hashtbl.replace d "vc-locals" locals; - Hashtbl.replace d "__native_code" (NativeFn ("code", fun _ -> Nil)); + 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 = - VmClosure { vm_code = Sx_vm.code_from_value code; - vm_upvalues = (match upvalues with List l -> Array.of_list l | _ -> [||]); - vm_name = (match name with String s -> Some s | _ -> None); + 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 --- *) -type frame = Sx_vm.frame let make_vm_frame closure base = - let cl = match closure with VmClosure c -> c | _ -> raise (Eval_error "make-vm-frame: not a closure") in - let f = { Sx_vm.closure = cl; ip = 0; - base = val_to_int base; - local_cells = Hashtbl.create 4 } in - (* Wrap as Dict for SX code *) - let d = Hashtbl.create 4 in - Hashtbl.replace d "__native_frame" (NativeFn ("frame", fun _ -> Nil)); - Dict d + 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 - let vm = Sx_vm.create g in - (* Wrap as Dict for SX code *) + 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 "__native_vm" (NativeFn ("vm", fun _ -> Nil)); + 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 -(* NOTE: The transpiled VM functions call these accessors. - For now, the transpiled code delegates to the existing Sx_vm module. - Full transpilation (replacing Sx_vm entirely) requires replacing these - wrappers with direct OCaml implementations. *) +let closure_upvalues cl = let c = unwrap_closure cl in + List (Array.to_list (Array.map (fun cell -> cell.uv_value) c.vm_upvalues)) -(* --- Delegate to existing Sx_vm for now --- *) -let vm_step vm frame rest_frames bc consts = Nil (* placeholder *) -let vm_run vm = Nil (* placeholder *) -let vm_call vm f args = Nil (* placeholder *) -let vm_call_closure closure args globals = Nil (* placeholder *) -let vm_execute_module code globals = - Sx_vm.execute_module (Sx_vm.code_from_value code) - (match globals with Dict d -> d | _ -> Hashtbl.create 0) +let closure_env cl = match cl with + | VmClosure c -> (match c.vm_closure_env with Some e -> Env e | None -> Nil) + | _ -> Nil -(* Stack ops delegate *) -let vm_push vm v = Nil -let vm_pop vm = Nil -let vm_peek vm = 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") -(* Frame ops delegate *) -let frame_read_u8 frame = Nil -let frame_read_u16 frame = Nil -let frame_read_i16 frame = Nil -let frame_local_get vm frame slot = Nil -let frame_local_set vm frame slot v = Nil -let frame_upvalue_get frame idx = Nil -let frame_upvalue_set frame idx v = Nil +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 -(* Accessors *) -let frame_ip frame = Nil -let frame_set_ip_b frame v = Nil -let frame_base frame = Nil -let frame_closure frame = Nil -let closure_code cl = Nil -let closure_upvalues cl = Nil -let closure_env cl = Nil -let code_bytecode code = Nil -let code_constants code = Nil -let code_locals code = Nil -let vm_sp vm = Nil -let vm_set_sp_b vm v = Nil -let vm_stack vm = Nil -let vm_set_stack_b vm v = Nil -let vm_frames vm = Nil -let vm_set_frames_b vm v = Nil -let vm_globals_ref vm = Nil +(* --- 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)))) -(* Global ops *) -let vm_global_get vm frame name = Nil -let vm_global_set vm frame name v = Nil +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 -(* Complex ops *) -let vm_push_frame vm closure args = Nil -let code_from_value v = Sx_vm.code_from_value v |> fun _ -> 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 -let vm_create_closure vm frame code_val = Nil -(* Collection helpers *) -let collect_n_from_stack vm n = Nil -let pad_n_nils vm n = Nil +(* --- 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 } + +(* --- 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 Sx_vm.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 + +(* --- 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 (Sx_vm.is_jit_failed cl) -> + (* Already compiled — run on VM *) + (try vm_push vm_val (Sx_vm.call_closure cl (to_ocaml_list args) cl.vm_env_ref) + with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)) + | Some _ -> + (* Compile failed before — CEK fallback *) + vm_push vm_val (cek_call_or_suspend vm_val f args) + | None -> + if l.l_name <> None then begin + l.l_compiled <- Some Sx_vm.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 (Sx_vm.call_closure cl (to_ocaml_list args) 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 """ diff --git a/hosts/ocaml/lib/sx_vm_ref.ml b/hosts/ocaml/lib/sx_vm_ref.ml new file mode 100644 index 00000000..49d026a2 --- /dev/null +++ b/hosts/ocaml/lib/sx_vm_ref.ml @@ -0,0 +1,429 @@ +(* 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 } + +(* --- 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 Sx_vm.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 + +(* --- 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 (Sx_vm.is_jit_failed cl) -> + (* Already compiled — run on VM *) + (try vm_push vm_val (Sx_vm.call_closure cl (to_ocaml_list args) cl.vm_env_ref) + with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)) + | Some _ -> + (* Compile failed before — CEK fallback *) + vm_push vm_val (cek_call_or_suspend vm_val f args) + | None -> + if l.l_name <> None then begin + l.l_compiled <- Some Sx_vm.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 (Sx_vm.call_closure cl (to_ocaml_list args) 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 = + (if sx_truthy ((prim_call "=" [name; (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 "=" [name; (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 "=" [name; (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 "=" [name; (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 "=" [name; (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 "=" [name; (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 "=" [name; (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 consumed.")) 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 = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) 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 (loop ()))))) 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 (raise (Eval_error (value_to_str (String (sx_str [(String "VM: IO suspension (OP_PERFORM) — request: "); request])))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op]))))))))))))))))))))))))))))))))))))))))))))))) + +(* vm-call-closure *) +and vm_call_closure closure args globals = + let _active_vm_ = ref Nil in (let prev_vm = !_active_vm_ in let vm = (make_vm (globals)) in (let () = ignore ((_active_vm_ := vm; Nil)) in (let () = ignore ((vm_push_frame (vm) (closure) (args))) in (let () = ignore ((vm_run (vm))) in (let () = ignore ((_active_vm_ := prev_vm; Nil)) in (vm_pop (vm))))))) + +(* vm-execute-module *) +and vm_execute_module code globals = + (let closure = (make_vm_closure (code) ((List [])) ((String "module")) (globals) (Nil)) in let vm = (make_vm (globals)) in (let frame = (make_vm_frame (closure) ((Number 0.0))) in (let () = ignore ((pad_n_nils (vm) ((code_locals (code))))) in (let () = ignore ((vm_set_frames_b (vm) ((List [frame])))) in (let () = ignore ((vm_run (vm))) in (vm_pop (vm))))))) + diff --git a/hosts/ocaml/sx_vm_ref.ml b/hosts/ocaml/sx_vm_ref.ml index 878e0d40..49d026a2 100644 --- a/hosts/ocaml/sx_vm_ref.ml +++ b/hosts/ocaml/sx_vm_ref.ml @@ -1,156 +1,406 @@ (* sx_vm_ref.ml — Auto-generated from lib/vm.sx *) (* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *) -[@@@warning "-26-27"] +[@@@warning "-26-27-39"] open Sx_types open Sx_runtime -(* Forward references for CEK interop *) +(* ================================================================ + 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 -(* Primitive call dispatch *) +(* 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 = - Sx_primitives.prim_call (value_to_string name) (list_to_ocaml_list args) + let n = value_to_string name in + prim_call n (to_ocaml_list args) (* ================================================================ - Preamble: native OCaml type construction + field access + 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. ================================================================ *) -(* --- Upvalue cells --- *) -let make_upvalue_cell v = let c = { uv_value = v } in UvCell c -let uv_get c = match c with UvCell cell -> cell.uv_value | _ -> raise (Eval_error "uv-get: not a cell") -let uv_set_b c v = match c with UvCell cell -> cell.uv_value <- v | _ -> raise (Eval_error "uv-set!: not a cell") +(* --- 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 -(* --- VM code --- *) let make_vm_code arity locals bytecode constants = - let bc = match bytecode with - | List l -> Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l) - | _ -> [||] in - let cs = match constants with - | List l -> Array.of_list l - | _ -> [||] in - let code = { vc_arity = val_to_int arity; vc_locals = val_to_int locals; - vc_bytecode = bc; vc_constants = cs } in - (* Return as a Dict wrapper so SX code can pass it around *) + (* Build a Dict that code_from_value can parse *) let d = Hashtbl.create 4 in - Hashtbl.replace d "vc-bytecode" bytecode; - Hashtbl.replace d "vc-constants" constants; - Hashtbl.replace d "vc-arity" arity; - Hashtbl.replace d "vc-locals" locals; - Hashtbl.replace d "__native_code" (NativeFn ("code", fun _ -> Nil)); + 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 = - VmClosure { vm_code = Sx_vm.code_from_value code; - vm_upvalues = (match upvalues with List l -> Array.of_list l | _ -> [||]); - vm_name = (match name with String s -> Some s | _ -> None); + 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 --- *) -type frame = Sx_vm.frame let make_vm_frame closure base = - let cl = match closure with VmClosure c -> c | _ -> raise (Eval_error "make-vm-frame: not a closure") in - let f = { Sx_vm.closure = cl; ip = 0; - base = val_to_int base; - local_cells = Hashtbl.create 4 } in - (* Wrap as Dict for SX code *) - let d = Hashtbl.create 4 in - Hashtbl.replace d "__native_frame" (NativeFn ("frame", fun _ -> Nil)); - Dict d + 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 - let vm = Sx_vm.create g in - (* Wrap as Dict for SX code *) + 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 "__native_vm" (NativeFn ("vm", fun _ -> Nil)); + 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 -(* NOTE: The transpiled VM functions call these accessors. - For now, the transpiled code delegates to the existing Sx_vm module. - Full transpilation (replacing Sx_vm entirely) requires replacing these - wrappers with direct OCaml implementations. *) +let closure_upvalues cl = let c = unwrap_closure cl in + List (Array.to_list (Array.map (fun cell -> cell.uv_value) c.vm_upvalues)) -(* --- Delegate to existing Sx_vm for now --- *) -let vm_step vm frame rest_frames bc consts = Nil (* placeholder *) -let vm_run vm = Nil (* placeholder *) -let vm_call vm f args = Nil (* placeholder *) -let vm_call_closure closure args globals = Nil (* placeholder *) -let vm_execute_module code globals = - Sx_vm.execute_module (Sx_vm.code_from_value code) - (match globals with Dict d -> d | _ -> Hashtbl.create 0) +let closure_env cl = match cl with + | VmClosure c -> (match c.vm_closure_env with Some e -> Env e | None -> Nil) + | _ -> Nil -(* Stack ops delegate *) -let vm_push vm v = Nil -let vm_pop vm = Nil -let vm_peek vm = 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") -(* Frame ops delegate *) -let frame_read_u8 frame = Nil -let frame_read_u16 frame = Nil -let frame_read_i16 frame = Nil -let frame_local_get vm frame slot = Nil -let frame_local_set vm frame slot v = Nil -let frame_upvalue_get frame idx = Nil -let frame_upvalue_set frame idx v = Nil +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 -(* Accessors *) -let frame_ip frame = Nil -let frame_set_ip_b frame v = Nil -let frame_base frame = Nil -let frame_closure frame = Nil -let closure_code cl = Nil -let closure_upvalues cl = Nil -let closure_env cl = Nil -let code_bytecode code = Nil -let code_constants code = Nil -let code_locals code = Nil -let vm_sp vm = Nil -let vm_set_sp_b vm v = Nil -let vm_stack vm = Nil -let vm_set_stack_b vm v = Nil -let vm_frames vm = Nil -let vm_set_frames_b vm v = Nil -let vm_globals_ref vm = Nil +(* --- 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)))) -(* Global ops *) -let vm_global_get vm frame name = Nil -let vm_global_set vm frame name v = Nil +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 -(* Complex ops *) -let vm_push_frame vm closure args = Nil -let code_from_value v = Sx_vm.code_from_value v |> fun _ -> 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 -let vm_create_closure vm frame code_val = Nil -(* Collection helpers *) -let collect_n_from_stack vm n = Nil -let pad_n_nils vm n = Nil +(* --- 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 } + +(* --- 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 Sx_vm.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 + +(* --- 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 (Sx_vm.is_jit_failed cl) -> + (* Already compiled — run on VM *) + (try vm_push vm_val (Sx_vm.call_closure cl (to_ocaml_list args) cl.vm_env_ref) + with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)) + | Some _ -> + (* Compile failed before — CEK fallback *) + vm_push vm_val (cek_call_or_suspend vm_val f args) + | None -> + if l.l_name <> None then begin + l.l_compiled <- Some Sx_vm.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 (Sx_vm.call_closure cl (to_ocaml_list args) 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 === *) -(* *active-vm* *) -let rec _active_vm_ = - Nil - -(* *jit-compile-fn* *) -and _jit_compile_fn_ = - Nil - -(* try-jit-call *) -and try_jit_call vm f args = - (let compiled = (lambda_compiled (f)) in (if sx_truthy ((vm_closure_p (compiled))) then (vm_push (vm) ((vm_call_closure (compiled) (args) ((vm_globals_ref (vm)))))) else (if sx_truthy ((prim_call "=" [compiled; (String "jit-failed")])) then (vm_push (vm) ((cek_call_or_suspend (vm) (f) (args)))) else (if sx_truthy ((let _and = _jit_compile_fn_ in if not (sx_truthy _and) then _and else (lambda_name (f)))) then (let () = ignore ((lambda_set_compiled_b (f) ((String "jit-failed")))) in (let result' = (_jit_compile_fn_ (f) ((vm_globals_ref (vm)))) in (if sx_truthy ((vm_closure_p (result'))) then (let () = ignore ((lambda_set_compiled_b (f) (result'))) in (vm_push (vm) ((vm_call_closure (result') (args) ((vm_globals_ref (vm))))))) else (vm_push (vm) ((cek_call_or_suspend (vm) (f) (args))))))) else (vm_push (vm) ((cek_call_or_suspend (vm) (f) (args)))))))) - (* vm-call *) -and vm_call vm f args = +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 *) @@ -161,14 +411,6 @@ and vm_resolve_ho_form vm name = 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))) -(* env-walk *) -and env_walk env name = - (if sx_truthy ((is_nil (env))) then Nil else (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (let parent = (env_parent (env)) in (if sx_truthy ((is_nil (parent))) then Nil else (env_walk (parent) (name)))))) - -(* env-walk-set! *) -and env_walk_set_b env name value = - (if sx_truthy ((is_nil (env))) then (Bool false) else (if sx_truthy ((env_has (env) (name))) then (let () = ignore ((env_set env (sx_to_string name) value)) in (Bool true)) else (let parent = (env_parent (env)) in (if sx_truthy ((is_nil (parent))) then (Bool false) else (env_walk_set_b (parent) (name) (value)))))) - (* vm-run *) and vm_run vm = (let () = ignore ((String "Execute bytecode until all frames are consumed.")) 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 = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) 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 (loop ()))))) else Nil)) in (loop ())))