diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 9dbb5ff..6cdd4da 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -20,6 +20,7 @@ module Sx_primitives = Sx.Sx_primitives module Sx_runtime = Sx.Sx_runtime module Sx_ref = Sx.Sx_ref module Sx_render = Sx.Sx_render +module Sx_vm = Sx.Sx_vm open Sx_types @@ -778,6 +779,19 @@ let dispatch env cmd = | Eval_error msg -> send_error msg | exn -> send_error (Printexc.to_string exn)) + | List [Symbol "vm-exec"; code_val] -> + (* Execute a bytecode module on the VM. + code_val is a dict with {bytecode, pool} from compiler.sx *) + (try + let code = Sx_vm.code_from_value code_val in + let globals = Hashtbl.create 256 in + Hashtbl.iter (fun k v -> Hashtbl.replace globals k v) env.bindings; + let result = Sx_vm.execute_module code globals in + send_ok_value result + with + | Eval_error msg -> send_error msg + | exn -> send_error (Printexc.to_string exn)) + | List [Symbol "reset"] -> (* Clear all bindings and rebuild env. We can't reassign env, so clear and re-populate. *) diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 3e477e1..99d0e1e 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -9,227 +9,270 @@ open Sx_types -(** Bytecode instruction stream. *) -type bytecode = int array - (** Code object — compiled function body. *) type code = { arity : int; locals : int; - bytecode : bytecode; + bytecode : int array; constants : value array; } -(** Upvalue — reference to a captured variable. *) -type upvalue_ref = - | Open of int (* index into enclosing frame's locals *) - | Closed of value ref (* heap-allocated after frame returns *) - (** Closure — code + captured upvalues. *) -type closure = { +type vm_closure = { code : code; - upvalues : upvalue_ref array; name : string option; } (** Call frame — one per function invocation. *) type frame = { - closure : closure; + closure : vm_closure; mutable ip : int; - base : int; (* base index in value stack *) + base : int; (* base index in value stack for locals *) } (** VM state. *) type vm = { mutable stack : value array; - mutable sp : int; (* stack pointer — next free slot *) + mutable sp : int; mutable frames : frame list; globals : (string, value) Hashtbl.t; } -(** Create a new VM. *) -let create () = { - stack = Array.make 1024 Nil; - sp = 0; - frames = []; - globals = Hashtbl.create 256; -} +let create globals = + let g = Hashtbl.create 256 in + Hashtbl.iter (fun k v -> Hashtbl.replace g k v) globals; + { stack = Array.make 4096 Nil; sp = 0; frames = []; globals = g } -(** Stack operations. *) +(** Stack ops — inlined for speed. *) let push vm v = if vm.sp >= Array.length vm.stack then begin - let new_stack = Array.make (vm.sp * 2) Nil in - Array.blit vm.stack 0 new_stack 0 vm.sp; - vm.stack <- new_stack + 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 pop vm = +let[@inline] pop vm = vm.sp <- vm.sp - 1; vm.stack.(vm.sp) -let peek vm = - vm.stack.(vm.sp - 1) +let[@inline] peek vm = vm.stack.(vm.sp - 1) -(** Read operands from bytecode. *) -let read_u8 frame = - let v = frame.closure.code.bytecode.(frame.ip) in - frame.ip <- frame.ip + 1; v +(** Read operands. *) +let[@inline] read_u8 f = + let v = f.closure.code.bytecode.(f.ip) in + f.ip <- f.ip + 1; v -let read_u16 frame = - let lo = frame.closure.code.bytecode.(frame.ip) in - let hi = frame.closure.code.bytecode.(frame.ip + 1) in - frame.ip <- frame.ip + 2; +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 read_i16 frame = - let v = read_u16 frame in +let[@inline] read_i16 f = + let v = read_u16 f in if v >= 32768 then v - 65536 else v -(** Execute bytecode until OP_RETURN. *) +(** Main execution loop. *) let rec run vm = match vm.frames with | [] -> failwith "VM: no frame" - | frame :: _ -> - let code = frame.closure.code in - let bc = code.bytecode in + | frame :: rest_frames -> + let bc = frame.closure.code.bytecode in + let consts = frame.closure.code.constants in let op = bc.(frame.ip) in frame.ip <- frame.ip + 1; match op with - (* ---- Stack / Constants ---- *) - | 0x01 -> (* OP_CONST *) + (* ---- Constants ---- *) + | 1 (* OP_CONST *) -> let idx = read_u16 frame in - push vm code.constants.(idx); + push vm consts.(idx); run vm - | 0x02 -> push vm Nil; run vm (* OP_NIL *) - | 0x03 -> push vm (Bool true); run vm (* OP_TRUE *) - | 0x04 -> push vm (Bool false); run vm (* OP_FALSE *) - | 0x05 -> ignore (pop vm); run vm (* OP_POP *) - | 0x06 -> push vm (peek vm); run vm (* OP_DUP *) + | 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 ---- *) - | 0x10 -> (* OP_LOCAL_GET *) + | 16 (* OP_LOCAL_GET *) -> let slot = read_u8 frame in push vm vm.stack.(frame.base + slot); run vm - | 0x11 -> (* OP_LOCAL_SET *) + | 17 (* OP_LOCAL_SET *) -> let slot = read_u8 frame in vm.stack.(frame.base + slot) <- peek vm; run vm - | 0x14 -> (* OP_GLOBAL_GET *) + | 20 (* OP_GLOBAL_GET *) -> let idx = read_u16 frame in - let name = match code.constants.(idx) with String s -> s | _ -> "" in + let name = match consts.(idx) with String s -> s | _ -> "" in let v = try Hashtbl.find vm.globals name with Not_found -> - (* Fall back to primitives *) - try Sx_primitives.get name - with _ -> raise (Eval_error ("Undefined: " ^ name)) + try Sx_primitives.get_primitive name + with _ -> raise (Eval_error ("VM undefined: " ^ name)) in push vm v; run vm - | 0x15 -> (* OP_GLOBAL_SET *) + | 21 (* OP_GLOBAL_SET *) -> let idx = read_u16 frame in - let name = match code.constants.(idx) with String s -> s | _ -> "" in + let name = match consts.(idx) with String s -> s | _ -> "" in Hashtbl.replace vm.globals name (peek vm); run vm (* ---- Control flow ---- *) - | 0x20 -> (* OP_JUMP *) + | 32 (* OP_JUMP *) -> let offset = read_i16 frame in frame.ip <- frame.ip + offset; run vm - | 0x21 -> (* OP_JUMP_IF_FALSE *) + | 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 - | 0x22 -> (* OP_JUMP_IF_TRUE *) + | 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 ---- *) - | 0x30 -> (* OP_CALL *) + | 48 (* OP_CALL *) -> let argc = read_u8 frame in let args = Array.init argc (fun _ -> pop vm) in let f = pop vm in - call vm f (Array.to_list (Array.of_list (List.rev (Array.to_list args)))); + vm_call vm f (Array.to_list (Array.of_list (List.rev (Array.to_list args)))); run vm - | 0x31 -> (* OP_TAIL_CALL *) + | 49 (* OP_TAIL_CALL *) -> let argc = read_u8 frame in let args = Array.init argc (fun _ -> pop vm) in - let _f = pop vm in - (* TODO: tail call optimization — reuse frame *) - let args_list = List.rev (Array.to_list args) in - call vm _f args_list; + let f = pop vm in + (* Tail call: pop current frame, reuse stack space *) + vm.frames <- rest_frames; + vm.sp <- frame.base; + vm_call vm f (Array.to_list (Array.of_list (List.rev (Array.to_list args)))); run vm - | 0x32 -> (* OP_RETURN *) + | 50 (* OP_RETURN *) -> let result = pop vm in - vm.frames <- List.tl vm.frames; + vm.frames <- rest_frames; vm.sp <- frame.base; push vm result - (* Don't recurse — return to caller *) - | 0x34 -> (* OP_CALL_PRIM *) + (* Return to caller — don't recurse *) + | 52 (* OP_CALL_PRIM *) -> let idx = read_u16 frame in let argc = read_u8 frame in - let name = match code.constants.(idx) with String s -> s | _ -> "" in + let name = match consts.(idx) with String s -> s | _ -> "" in let args = List.init argc (fun _ -> pop vm) |> List.rev in - let result = Sx_primitives.call name args in + let result = (match Sx_primitives.get_primitive name with + NativeFn (_, fn) -> fn args | _ -> Nil) in push vm result; run vm (* ---- Collections ---- *) - | 0x40 -> (* OP_LIST *) + | 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 - | 0x41 -> (* OP_DICT *) + | 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 | _ -> "" 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 ---- *) - | 0x90 -> (* OP_STR_CONCAT *) + | 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 value_to_str parts) in + let s = String.concat "" (List.map Sx_runtime.value_to_str parts) in push vm (String s); run vm (* ---- Define ---- *) - | 0x80 -> (* OP_DEFINE *) + | 128 (* OP_DEFINE *) -> let idx = read_u16 frame in - let name = match code.constants.(idx) with String s -> s | _ -> "" 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 0x%02x at ip=%d" opcode (frame.ip - 1))) + (* ---- Closure ---- *) + | 51 (* OP_CLOSURE *) -> + let idx = read_u16 frame in + (* The constant pool entry is a code dict from the compiler *) + let code_val = consts.(idx) in + let code = code_from_value code_val in + let cl = { code; name = None } in + push vm (NativeFn ("vm-closure", fun args -> + execute_closure cl args vm.globals)); + run vm -and call vm f args = + | opcode -> + raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d" + opcode (frame.ip - 1))) + +and vm_call vm f args = match f with | NativeFn (_, fn) -> let result = fn args in push vm result + | Lambda _ -> + (* Call a CEK-defined lambda through the VM *) + let result = Sx_ref.cek_call f (List args) in + push vm result | _ -> - raise (Eval_error ("VM: not callable: " ^ value_to_str f)) + raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f)) -(** Execute a code object in a fresh VM. *) -let execute code globals = - let vm = create () in - (* Copy globals *) - Hashtbl.iter (fun k v -> Hashtbl.replace vm.globals k v) globals; - let closure = { code; upvalues = [||]; name = None } in - let frame = { closure; ip = 0; base = 0 } in +(** 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 + (* Recursively convert nested code objects in the pool *) + let constants = Array.map (fun entry -> + match entry with + | Dict ed when Hashtbl.mem ed "bytecode" -> + (* Nested code object — keep as Dict for lazy conversion *) + entry + | _ -> 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. *) +and execute_closure cl args globals = + let vm = create globals in + let frame = { closure = cl; ip = 0; base = vm.sp } in + (* Push args as locals *) + List.iter (fun a -> push vm a) args; + (* Pad remaining locals with nil *) + for _ = List.length args to cl.code.locals - 1 do push vm Nil done; + vm.frames <- [frame]; + run vm; + pop vm + +(** Execute a compiled module (top-level bytecode). *) +let execute_module code globals = + let cl = { code; name = Some "module" } in + let vm = create globals in + let frame = { closure = cl; ip = 0; base = 0 } in + (* Pad locals *) + for _ = 0 to code.locals - 1 do push vm Nil done; vm.frames <- [frame]; run vm; pop vm diff --git a/spec/compiler.sx b/spec/compiler.sx index 8947eda..301b642 100644 --- a/spec/compiler.sx +++ b/spec/compiler.sx @@ -375,7 +375,7 @@ ;; Add code object to parent constant pool (let ((code {:arity (len (get fn-scope "locals")) :bytecode (get fn-em "bytecode") - :pool (get fn-em "pool") + :constants (get (get fn-em "pool") "entries") :upvalues (get fn-scope "upvalues")}) (code-idx (pool-add (get em "pool") code))) (emit-op em 51) ;; OP_CLOSURE @@ -466,7 +466,7 @@ (compile-expr em expr scope false) (emit-op em 50) ;; OP_RETURN {:bytecode (get em "bytecode") - :pool (get em "pool")}))) + :constants (get (get em "pool") "entries")}))) (define compile-module (fn (exprs) @@ -481,4 +481,4 @@ (compile-expr em (last exprs) scope false) (emit-op em 50) ;; OP_RETURN {:bytecode (get em "bytecode") - :pool (get em "pool")}))) + :constants (get (get em "pool") "entries")})))