Transpiled VM compiles with real native preamble
bootstrap_vm.py preamble now has real implementations for all 48 native OCaml functions: stack ops, frame access, upvalue capture, closure creation, JIT dispatch, CEK fallback, env walking. The transpiled sx_vm_ref.ml (25KB) compiles cleanly alongside sx_vm.ml. 7 logic functions transpiled from vm.sx: vm-call, vm-resolve-ho-form, vm-call-external, vm-run, vm-step, vm-call-closure, vm-execute-module Next: wire callers to use Sx_vm_ref instead of Sx_vm. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -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
|
||||
|
||||
"""
|
||||
|
||||
|
||||
429
hosts/ocaml/lib/sx_vm_ref.ml
Normal file
429
hosts/ocaml/lib/sx_vm_ref.ml
Normal file
File diff suppressed because one or more lines are too long
@@ -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 ())))
|
||||
|
||||
Reference in New Issue
Block a user