giles
2f3e727a6f
When the VM or CEK hits an undefined symbol, it checks a symbol→library index (built from manifest exports at boot), loads the library that exports it, and returns the value. Execution continues as if the module was always loaded. No import statements, no load-library! calls, no Suspense boundaries — just call the function. This is the same mechanism as IO suspension for data fetching. The programmer doesn't distinguish between calling a local function and calling one that needs its module fetched first. The runtime treats code as just another resource. Implementation: - _symbol_resolve_hook in sx_types.ml — called by env_get_id (CEK path) and vm_global_get (VM path) when a symbol isn't found - Symbol→library index built from manifest exports in sx-platform.js - __resolve-symbol native calls __sxLoadLibrary, module loads, symbol appears in globals, execution resumes - compile-modules.js extracts export lists into module-manifest.json - Playground page demonstrates: (freeze-scope) triggers freeze.sxbc download transparently on first use 2650/2650 tests pass. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
523 lines
28 KiB
OCaml
523 lines
28 KiB
OCaml
(* 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
|
|
let not_found () =
|
|
(* Try evaluator's primitive table *)
|
|
try prim_call n [] with _ ->
|
|
(* Try symbol resolve hook — transparent lazy module loading *)
|
|
match !_symbol_resolve_hook with
|
|
| Some hook ->
|
|
(match hook n with
|
|
| Some v -> v
|
|
| None -> raise (Eval_error ("VM undefined: " ^ n)))
|
|
| None -> raise (Eval_error ("VM undefined: " ^ n))
|
|
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 -> not_found ())
|
|
in find_env env
|
|
| None -> not_found ())
|
|
|
|
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 =
|
|
(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 (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
|
|
|