diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 05347b2..6e9ad32 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -820,18 +820,21 @@ let dispatch env cmd = match result with | Dict d when Hashtbl.mem d "bytecode" -> let code = Sx_vm.code_from_value result in - let globals_snapshot = Hashtbl.copy env.bindings in - Hashtbl.iter (fun k v -> - Hashtbl.replace globals_snapshot k v) lam.l_closure.bindings; - (* VM closure with CEK fallback on error *) + (* Live env reference — NOT a snapshot. Functions see + current bindings, including later-defined functions. *) + let live_env = env.bindings in + (* Original lambda for CEK fallback *) let orig_lambda = Lambda lam in let fn = NativeFn ("vm:" ^ name, fun args -> try - Sx_vm.execute_closure - { Sx_vm.code; name = lam.l_name } args globals_snapshot - with _ -> - (* Fall back to CEK machine *) - Sx_ref.cek_call orig_lambda (List args)) in + Sx_vm.call_closure + { Sx_vm.code; upvalues = [||]; name = lam.l_name; + env_ref = live_env } + args live_env + with + | _ -> + (* Any VM error — fall back to CEK *) + Sx_ref.eval_expr (List (orig_lambda :: args)) (Env env)) in Hashtbl.replace env.bindings name fn; incr count | _ -> incr failed diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 99d0e1e..d501302 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -17,17 +17,26 @@ type code = { constants : value array; } -(** Closure — code + captured upvalues. *) +(** 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; + closure : vm_closure; mutable ip : int; - base : int; (* base index in value stack for locals *) + base : int; (* base index in value stack for locals *) } (** VM state. *) @@ -35,13 +44,11 @@ type vm = { mutable stack : value array; mutable sp : int; mutable frames : frame list; - globals : (string, value) Hashtbl.t; + globals : (string, value) Hashtbl.t; (* live reference to kernel env *) } 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 = Array.make 4096 Nil; sp = 0; frames = []; globals } (** Stack ops — inlined for speed. *) let push vm v = @@ -74,13 +81,21 @@ 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 - | [] -> failwith "VM: no frame" + | [] -> () (* 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 () (* ran off end *) + else let op = bc.(frame.ip) in frame.ip <- frame.ip + 1; match op with @@ -104,6 +119,14 @@ let rec run vm = let slot = read_u8 frame in vm.stack.(frame.base + slot) <- peek vm; run vm + | 18 (* OP_UPVALUE_GET *) -> + let idx = read_u8 frame in + 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 @@ -139,30 +162,62 @@ let rec run vm = let argc = read_u8 frame in let args = Array.init argc (fun _ -> pop vm) in let f = pop vm in - vm_call vm f (Array.to_list (Array.of_list (List.rev (Array.to_list args)))); + 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 (Array.to_list (Array.of_list (List.rev (Array.to_list args)))); + 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 to caller — don't recurse *) + (* Return — don't recurse, let caller continue *) + | 51 (* OP_CLOSURE *) -> + let idx = read_u16 frame in + let code_val = consts.(idx) in + let code = code_from_value code_val in + (* 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 + (* Capture from enclosing frame's local slot *) + { uv_value = vm.stack.(frame.base + index) } + else + (* Capture from enclosing frame's upvalue *) + { uv_value = frame.closure.upvalues.(index).uv_value } + ) 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 = (match Sx_primitives.get_primitive name with - NativeFn (_, fn) -> fn args | _ -> Nil) in + let result = + (match Sx_primitives.get_primitive name with + | NativeFn (_, fn) -> fn args + | _ -> Nil) + in push vm result; run vm @@ -200,28 +255,19 @@ let rec run vm = Hashtbl.replace vm.globals name v; run vm - (* ---- 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 - | opcode -> + (* Unknown opcode — fall back to CEK machine *) raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d" opcode (frame.ip - 1))) +(** Call a value as a function — dispatch by type. *) and vm_call vm f args = match f with - | NativeFn (_, fn) -> + | NativeFn (_name, fn) -> let result = fn args in push vm result - | Lambda _ -> - (* Call a CEK-defined lambda through the VM *) + | 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 | _ -> @@ -240,12 +286,9 @@ and code_from_value v = | 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 + | Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *) | _ -> entry ) entries in let arity = match Hashtbl.find_opt d "arity" with @@ -254,8 +297,9 @@ and code_from_value v = { 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 = +(** Execute a closure with arguments — creates a new VM frame. + The closure carries its upvalue cells for captured variables. *) +and call_closure cl args globals = let vm = create globals in let frame = { closure = cl; ip = 0; base = vm.sp } in (* Push args as locals *) @@ -268,10 +312,9 @@ and execute_closure cl args globals = (** Execute a compiled module (top-level bytecode). *) let execute_module code globals = - let cl = { code; name = Some "module" } in + let cl = { code; upvalues = [||]; name = Some "module"; env_ref = globals } 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; diff --git a/shared/sx/ocaml_bridge.py b/shared/sx/ocaml_bridge.py index 076b742..3f80c24 100644 --- a/shared/sx/ocaml_bridge.py +++ b/shared/sx/ocaml_bridge.py @@ -265,9 +265,9 @@ class OcamlBridge: _logger.info("Loaded %d definitions from .sx files into OCaml kernel (%d skipped)", count, skipped) - # VM auto-compile ready but disabled until compiler handles - # all SX features and CEK fallback works correctly. - # Enable with: await self._send('(vm-compile)') + # VM auto-compile: ready when compiler handles all SX features. + # Currently 6/117 compile; fallback fails on closure scope vars. + # await self._send('(vm-compile)') except Exception as e: _logger.error("Failed to load .sx files into OCaml kernel: %s", e) self._components_loaded = False # retry next time diff --git a/spec/compiler.sx b/spec/compiler.sx index 7f5b224..c05b9be 100644 --- a/spec/compiler.sx +++ b/spec/compiler.sx @@ -45,6 +45,7 @@ {:locals (list) ;; list of {name, slot, mutable?} :upvalues (list) ;; list of {name, is-local, index} :parent parent + :is-function false ;; true for fn/lambda scopes (create frames) :next-slot 0})) (define scope-define-local @@ -58,32 +59,42 @@ (define scope-resolve (fn (scope name) - "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}." + "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}. + Upvalue captures only happen at function boundaries (is-function=true). + Let scopes share the enclosing function's frame — their locals are + accessed directly without upvalue indirection." (if (nil? scope) {:type "global" :index name} - ;; Check locals + ;; Check locals in this scope (let ((locals (get scope "locals")) (found (some (fn (l) (= (get l "name") name)) locals))) (if found (let ((local (first (filter (fn (l) (= (get l "name") name)) locals)))) {:type "local" :index (get local "slot")}) - ;; Check upvalues (already captured) + ;; Check upvalues already captured at this scope (let ((upvals (get scope "upvalues")) (uv-found (some (fn (u) (= (get u "name") name)) upvals))) (if uv-found (let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals)))) {:type "upvalue" :index (get uv "index")}) - ;; Try parent scope — if found, capture as upvalue - (let ((parent-result (scope-resolve (get scope "parent") name))) - (if (= (get parent-result "type") "global") - parent-result - ;; Capture from parent as upvalue - (let ((uv-idx (len (get scope "upvalues")))) - (append! (get scope "upvalues") - {:name name - :is-local (= (get parent-result "type") "local") - :index (get parent-result "index")}) - {:type "upvalue" :index uv-idx})))))))))) + ;; Look in parent + (let ((parent (get scope "parent"))) + (if (nil? parent) + {:type "global" :index name} + (let ((parent-result (scope-resolve parent name))) + (if (= (get parent-result "type") "global") + parent-result + ;; Found in parent. Capture as upvalue only at function boundaries. + (if (get scope "is-function") + ;; Function boundary — create upvalue capture + (let ((uv-idx (len (get scope "upvalues")))) + (append! (get scope "upvalues") + {:name name + :is-local (= (get parent-result "type") "local") + :index (get parent-result "index")}) + {:type "upvalue" :index uv-idx}) + ;; Let scope — pass through (same frame) + parent-result)))))))))))) ;; -------------------------------------------------------------------------- @@ -357,6 +368,9 @@ (let ((bindings (first args)) (body (rest args)) (let-scope (make-scope scope))) + ;; Let scopes share the enclosing function's frame. + ;; Continue slot numbering from parent. + (dict-set! let-scope "next-slot" (get scope "next-slot")) ;; Compile each binding (for-each (fn (binding) (let ((name (if (= (type-of (first binding)) "symbol") @@ -378,6 +392,8 @@ (body (rest args)) (fn-scope (make-scope scope)) (fn-em (make-emitter))) + ;; Mark as function boundary — upvalue captures happen here + (dict-set! fn-scope "is-function" true) ;; Define params as locals in fn scope (for-each (fn (p) (let ((name (if (= (type-of p) "symbol") (symbol-name p) p))) @@ -389,13 +405,22 @@ (compile-begin fn-em body fn-scope true) ;; tail position (emit-op fn-em 50) ;; OP_RETURN ;; Add code object to parent constant pool - (let ((code {:arity (len (get fn-scope "locals")) + (let ((upvals (get fn-scope "upvalues")) + (code {:arity (len (get fn-scope "locals")) :bytecode (get fn-em "bytecode") :constants (get (get fn-em "pool") "entries") - :upvalues (get fn-scope "upvalues")}) + :upvalue-count (len upvals)}) (code-idx (pool-add (get em "pool") code))) (emit-op em 51) ;; OP_CLOSURE - (emit-u16 em code-idx))))) + (emit-u16 em code-idx) + ;; Emit upvalue descriptors: for each captured variable, + ;; (is_local, index) — tells the VM where to find the value. + ;; is_local=1: capture from enclosing frame's local slot + ;; is_local=0: capture from enclosing frame's upvalue + (for-each (fn (uv) + (emit-byte em (if (get uv "is-local") 1 0)) + (emit-byte em (get uv "index"))) + upvals))))) (define compile-define