giles
8dd3eaa1d9
Root cause of for-each failure: CALL_PRIM checked globals before primitives. Globals had ho_via_cek wrappers that routed for-each through the CEK machine — which couldn't call VM closures correctly. Fix: check Sx_primitives.get_primitive FIRST (native call_any that handles NativeFn directly), fall back to globals for env-specific bindings like set-render-active!. Result: (for-each (fn (x) (+ x 1)) (list 1 2 3)) on VM → 42 ✓ Full adapter aser chain executing: aser → aser-list → aser-call → for-each callback Fails at UPVALUE_GET idx=6 (have 6) — compiler upvalue count off by one. Next fix: compiler scope analysis. Also: floor(0)=-1 bug found and fixed (was round(x-0.5), now uses OCaml's native floor). This was causing all compile failures. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
381 lines
13 KiB
OCaml
381 lines
13 KiB
OCaml
(** SX bytecode VM — stack-based interpreter.
|
|
|
|
Executes bytecode produced by compiler.sx.
|
|
Designed for speed: array-based stack, direct dispatch,
|
|
no allocation per step (unlike the CEK machine).
|
|
|
|
This is the platform-native execution engine. The same bytecode
|
|
runs on all platforms (OCaml, JS, WASM). *)
|
|
|
|
open Sx_types
|
|
|
|
(** Code object — compiled function body. *)
|
|
type code = {
|
|
arity : int;
|
|
locals : int;
|
|
bytecode : int array;
|
|
constants : value array;
|
|
}
|
|
|
|
(** Upvalue cell — shared mutable reference to a captured variable.
|
|
Open when the variable is still on the stack; closed when the
|
|
enclosing frame returns and the value is moved to the heap. *)
|
|
type upvalue_cell = {
|
|
mutable uv_value : value;
|
|
}
|
|
|
|
(** Closure — code + captured upvalues + live env reference. *)
|
|
type vm_closure = {
|
|
code : code;
|
|
upvalues : upvalue_cell array;
|
|
name : string option;
|
|
env_ref : (string, value) Hashtbl.t; (* live global env — NOT a snapshot *)
|
|
}
|
|
|
|
(** Call frame — one per function invocation. *)
|
|
type frame = {
|
|
closure : vm_closure;
|
|
mutable ip : int;
|
|
base : int; (* base index in value stack for locals *)
|
|
local_cells : (int, upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *)
|
|
}
|
|
|
|
(** VM state. *)
|
|
type vm = {
|
|
mutable stack : value array;
|
|
mutable sp : int;
|
|
mutable frames : frame list;
|
|
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
|
|
}
|
|
|
|
let create globals =
|
|
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals }
|
|
|
|
(** Stack ops — inlined for speed. *)
|
|
let push vm v =
|
|
if vm.sp >= Array.length vm.stack then begin
|
|
let ns = Array.make (vm.sp * 2) Nil in
|
|
Array.blit vm.stack 0 ns 0 vm.sp;
|
|
vm.stack <- ns
|
|
end;
|
|
vm.stack.(vm.sp) <- v;
|
|
vm.sp <- vm.sp + 1
|
|
|
|
let[@inline] pop vm =
|
|
vm.sp <- vm.sp - 1;
|
|
vm.stack.(vm.sp)
|
|
|
|
let[@inline] peek vm = vm.stack.(vm.sp - 1)
|
|
|
|
(** Read operands. *)
|
|
let[@inline] read_u8 f =
|
|
let v = f.closure.code.bytecode.(f.ip) in
|
|
f.ip <- f.ip + 1; v
|
|
|
|
let[@inline] read_u16 f =
|
|
let lo = f.closure.code.bytecode.(f.ip) in
|
|
let hi = f.closure.code.bytecode.(f.ip + 1) in
|
|
f.ip <- f.ip + 2;
|
|
lo lor (hi lsl 8)
|
|
|
|
let[@inline] read_i16 f =
|
|
let v = read_u16 f in
|
|
if v >= 32768 then v - 65536 else v
|
|
|
|
(** Wrap a VM closure as an SX value (NativeFn). *)
|
|
let closure_to_value cl =
|
|
NativeFn ("vm:" ^ (match cl.name with Some n -> n | None -> "anon"),
|
|
fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args))))
|
|
(* Placeholder — actual calls go through vm_call below *)
|
|
|
|
(** Main execution loop. *)
|
|
let rec run vm =
|
|
match vm.frames with
|
|
| [] -> () (* no frame = done *)
|
|
| frame :: rest_frames ->
|
|
let bc = frame.closure.code.bytecode in
|
|
let consts = frame.closure.code.constants in
|
|
if frame.ip >= Array.length bc then ()
|
|
else
|
|
let saved_ip = frame.ip in
|
|
let op = bc.(frame.ip) in
|
|
frame.ip <- frame.ip + 1;
|
|
(try match op with
|
|
(* ---- Constants ---- *)
|
|
| 1 (* OP_CONST *) ->
|
|
let idx = read_u16 frame in
|
|
if idx >= Array.length consts then
|
|
raise (Eval_error (Printf.sprintf "VM: CONST index %d out of bounds (pool size %d)"
|
|
idx (Array.length consts)));
|
|
push vm consts.(idx);
|
|
run vm
|
|
| 2 (* OP_NIL *) -> push vm Nil; run vm
|
|
| 3 (* OP_TRUE *) -> push vm (Bool true); run vm
|
|
| 4 (* OP_FALSE *) -> push vm (Bool false); run vm
|
|
| 5 (* OP_POP *) -> ignore (pop vm); run vm
|
|
| 6 (* OP_DUP *) -> push vm (peek vm); run vm
|
|
|
|
(* ---- Variable access ---- *)
|
|
| 16 (* OP_LOCAL_GET *) ->
|
|
let slot = read_u8 frame in
|
|
let v = match Hashtbl.find_opt frame.local_cells slot with
|
|
| Some cell -> cell.uv_value
|
|
| None ->
|
|
let idx = frame.base + slot in
|
|
if idx >= vm.sp then
|
|
raise (Eval_error (Printf.sprintf
|
|
"VM: LOCAL_GET slot=%d base=%d sp=%d out of bounds" slot frame.base vm.sp));
|
|
vm.stack.(idx)
|
|
in
|
|
push vm v;
|
|
run vm
|
|
| 17 (* OP_LOCAL_SET *) ->
|
|
let slot = read_u8 frame in
|
|
let v = peek vm in
|
|
(* Write to shared cell if captured, else to stack *)
|
|
(match Hashtbl.find_opt frame.local_cells slot with
|
|
| Some cell -> cell.uv_value <- v
|
|
| None -> vm.stack.(frame.base + slot) <- v);
|
|
run vm
|
|
| 18 (* OP_UPVALUE_GET *) ->
|
|
let idx = read_u8 frame in
|
|
if idx >= Array.length frame.closure.upvalues then
|
|
raise (Eval_error (Printf.sprintf
|
|
"VM: UPVALUE_GET idx=%d out of bounds (have %d)" idx
|
|
(Array.length frame.closure.upvalues)));
|
|
push vm frame.closure.upvalues.(idx).uv_value;
|
|
run vm
|
|
| 19 (* OP_UPVALUE_SET *) ->
|
|
let idx = read_u8 frame in
|
|
frame.closure.upvalues.(idx).uv_value <- peek vm;
|
|
run vm
|
|
| 20 (* OP_GLOBAL_GET *) ->
|
|
let idx = read_u16 frame in
|
|
let name = match consts.(idx) with String s -> s | _ -> "" in
|
|
let v = try Hashtbl.find vm.globals name with Not_found ->
|
|
try Sx_primitives.get_primitive name
|
|
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
|
in
|
|
push vm v; run vm
|
|
| 21 (* OP_GLOBAL_SET *) ->
|
|
let idx = read_u16 frame in
|
|
let name = match consts.(idx) with String s -> s | _ -> "" in
|
|
Hashtbl.replace vm.globals name (peek vm);
|
|
run vm
|
|
|
|
(* ---- Control flow ---- *)
|
|
| 32 (* OP_JUMP *) ->
|
|
let offset = read_i16 frame in
|
|
frame.ip <- frame.ip + offset;
|
|
run vm
|
|
| 33 (* OP_JUMP_IF_FALSE *) ->
|
|
let offset = read_i16 frame in
|
|
let v = pop vm in
|
|
if not (sx_truthy v) then frame.ip <- frame.ip + offset;
|
|
run vm
|
|
| 34 (* OP_JUMP_IF_TRUE *) ->
|
|
let offset = read_i16 frame in
|
|
let v = pop vm in
|
|
if sx_truthy v then frame.ip <- frame.ip + offset;
|
|
run vm
|
|
|
|
(* ---- Function calls ---- *)
|
|
| 48 (* OP_CALL *) ->
|
|
let argc = read_u8 frame in
|
|
let args = Array.init argc (fun _ -> pop vm) in
|
|
let f = pop vm in
|
|
let args_list = List.rev (Array.to_list args) in
|
|
vm_call vm f args_list;
|
|
run vm
|
|
| 49 (* OP_TAIL_CALL *) ->
|
|
let argc = read_u8 frame in
|
|
let args = Array.init argc (fun _ -> pop vm) in
|
|
let f = pop vm in
|
|
let args_list = List.rev (Array.to_list args) in
|
|
(* Tail call: pop current frame, reuse stack space *)
|
|
vm.frames <- rest_frames;
|
|
vm.sp <- frame.base;
|
|
vm_call vm f args_list;
|
|
run vm
|
|
| 50 (* OP_RETURN *) ->
|
|
let result = pop vm in
|
|
vm.frames <- rest_frames;
|
|
vm.sp <- frame.base;
|
|
push vm result
|
|
(* Return — don't recurse, let caller continue *)
|
|
| 51 (* OP_CLOSURE *) ->
|
|
let idx = read_u16 frame in
|
|
if idx >= Array.length consts then
|
|
raise (Eval_error (Printf.sprintf "VM: CLOSURE idx %d >= consts %d" idx (Array.length consts)));
|
|
let code_val = consts.(idx) in
|
|
let code = code_from_value code_val in
|
|
Printf.eprintf "[vm-closure] idx=%d type=%s bc_len=%d consts=%d sp_before=%d\n%!"
|
|
idx (type_of code_val)
|
|
(Array.length code.bytecode) (Array.length code.constants) vm.sp;
|
|
(* Read upvalue descriptors from bytecode *)
|
|
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 = read_u8 frame in
|
|
let index = read_u8 frame in
|
|
if is_local = 1 then begin
|
|
(* Capture from enclosing frame's local slot.
|
|
Create a shared cell — both parent and closure
|
|
read/write through this cell. *)
|
|
let cell = match Hashtbl.find_opt frame.local_cells index with
|
|
| Some existing -> existing (* reuse existing cell *)
|
|
| None ->
|
|
let c = { uv_value = vm.stack.(frame.base + index) } in
|
|
Hashtbl.replace frame.local_cells index c;
|
|
c
|
|
in
|
|
cell
|
|
end else
|
|
(* Capture from enclosing frame's upvalue — already a shared cell *)
|
|
frame.closure.upvalues.(index)
|
|
) in
|
|
let cl = { code; upvalues; name = None; env_ref = vm.globals } in
|
|
(* Wrap as NativeFn that calls back into the VM *)
|
|
let fn = NativeFn ("vm-closure", fun args ->
|
|
call_closure cl args vm.globals)
|
|
in
|
|
push vm fn;
|
|
run vm
|
|
| 52 (* OP_CALL_PRIM *) ->
|
|
let idx = read_u16 frame in
|
|
let argc = read_u8 frame in
|
|
let name = match consts.(idx) with String s -> s | _ -> "" in
|
|
let args = List.init argc (fun _ -> pop vm) |> List.rev in
|
|
let result =
|
|
try
|
|
(* Check primitives FIRST (native implementations of map/filter/etc.),
|
|
then globals (which may have ho_via_cek wrappers that route
|
|
through the CEK — these can't call VM closures). *)
|
|
let fn_val = try Sx_primitives.get_primitive name with _ ->
|
|
try Hashtbl.find vm.globals name with Not_found ->
|
|
raise (Eval_error ("VM: unknown primitive " ^ name))
|
|
in
|
|
(match fn_val with
|
|
| NativeFn (_, fn) -> fn args
|
|
| _ -> Nil)
|
|
with Eval_error msg ->
|
|
raise (Eval_error (Printf.sprintf "%s (in CALL_PRIM \"%s\" with %d args)"
|
|
msg name argc))
|
|
in
|
|
push vm result;
|
|
run vm
|
|
|
|
(* ---- Collections ---- *)
|
|
| 64 (* OP_LIST *) ->
|
|
let count = read_u16 frame in
|
|
let items = List.init count (fun _ -> pop vm) |> List.rev in
|
|
push vm (List items);
|
|
run vm
|
|
| 65 (* OP_DICT *) ->
|
|
let count = read_u16 frame in
|
|
let d = Hashtbl.create count in
|
|
for _ = 1 to count do
|
|
let v = pop vm in
|
|
let k = pop vm in
|
|
let key = match k with String s -> s | Keyword s -> s | _ -> Sx_runtime.value_to_str k in
|
|
Hashtbl.replace d key v
|
|
done;
|
|
push vm (Dict d);
|
|
run vm
|
|
|
|
(* ---- String ops ---- *)
|
|
| 144 (* OP_STR_CONCAT *) ->
|
|
let count = read_u8 frame in
|
|
let parts = List.init count (fun _ -> pop vm) |> List.rev in
|
|
let s = String.concat "" (List.map Sx_runtime.value_to_str parts) in
|
|
push vm (String s);
|
|
run vm
|
|
|
|
(* ---- Define ---- *)
|
|
| 128 (* OP_DEFINE *) ->
|
|
let idx = read_u16 frame in
|
|
let name = match consts.(idx) with String s -> s | _ -> "" in
|
|
let v = peek vm in
|
|
Hashtbl.replace vm.globals name v;
|
|
run vm
|
|
|
|
| opcode ->
|
|
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
|
|
opcode (frame.ip - 1)))
|
|
with Invalid_argument msg ->
|
|
let fn_name = match frame.closure.name with Some n -> n | None -> "?" in
|
|
raise (Eval_error (Printf.sprintf
|
|
"VM: %s at ip=%d op=%d in %s (base=%d sp=%d bc_len=%d consts=%d)"
|
|
msg saved_ip op fn_name frame.base vm.sp
|
|
(Array.length bc) (Array.length consts))))
|
|
|
|
(** Call a value as a function — dispatch by type. *)
|
|
and vm_call vm f args =
|
|
match f with
|
|
| NativeFn (_name, fn) ->
|
|
let result = fn args in
|
|
push vm result
|
|
| Lambda _ | Component _ | Island _ ->
|
|
(* Fall back to CEK machine for SX-defined functions *)
|
|
let result = Sx_ref.cek_call f (List args) in
|
|
push vm result
|
|
| _ ->
|
|
raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f))
|
|
|
|
(** Convert compiler output (SX dict) to a code object. *)
|
|
and code_from_value v =
|
|
match v with
|
|
| Dict d ->
|
|
let bc_list = match Hashtbl.find_opt d "bytecode" with
|
|
| Some (List l | ListRef { contents = l }) ->
|
|
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
|
|
| _ -> [||]
|
|
in
|
|
let entries = match Hashtbl.find_opt d "constants" with
|
|
| Some (List l | ListRef { contents = l }) -> Array.of_list l
|
|
| _ -> [||]
|
|
in
|
|
let constants = Array.map (fun entry ->
|
|
match entry with
|
|
| Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *)
|
|
| _ -> entry
|
|
) entries in
|
|
let arity = match Hashtbl.find_opt d "arity" with
|
|
| Some (Number n) -> int_of_float n | _ -> 0
|
|
in
|
|
{ arity; locals = arity + 16; bytecode = bc_list; constants }
|
|
| _ -> { arity = 0; locals = 16; bytecode = [||]; constants = [||] }
|
|
|
|
(** Execute a closure with arguments.
|
|
If called from within a VM (via NativeFn wrapper from for-each/map),
|
|
the upvalue cells already contain the captured values — no parent
|
|
frame needed. The fresh VM is fine because upvalues are heap-allocated
|
|
cells, not stack references. *)
|
|
and call_closure cl args globals =
|
|
let vm = create globals in
|
|
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
|
|
List.iter (fun a -> push vm a) args;
|
|
for _ = List.length args to cl.code.locals - 1 do push vm Nil done;
|
|
vm.frames <- [frame];
|
|
(try run vm
|
|
with e ->
|
|
Printf.eprintf "[vm-call-closure] FAIL in %s: %s (bc_len=%d args=%d sp=%d)\n%!"
|
|
(match cl.name with Some n -> n | None -> "?")
|
|
(Printexc.to_string e)
|
|
(Array.length cl.code.bytecode) (List.length args) vm.sp;
|
|
raise e);
|
|
pop vm
|
|
|
|
(** Execute a compiled module (top-level bytecode). *)
|
|
let execute_module code globals =
|
|
let cl = { code; upvalues = [||]; name = Some "module"; env_ref = globals } in
|
|
let vm = create globals in
|
|
let frame = { closure = cl; ip = 0; base = 0; local_cells = Hashtbl.create 4 } in
|
|
for _ = 0 to code.locals - 1 do push vm Nil done;
|
|
vm.frames <- [frame];
|
|
run vm;
|
|
pop vm
|