coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

VM upvalue support: closures capture variables from enclosing scopes

Browse Source 
Compiler (compiler.sx):
- Function scopes marked is-function=true; let scopes share parent frame
- scope-resolve only creates upvalue captures at function boundaries
- Let scope locals use parent's slot numbering (same frame)
- OP_CLOSURE emits upvalue descriptors: (is_local, index) per capture

VM (sx_vm.ml):
- upvalue_cell type: shared mutable reference to captured value
- OP_UPVALUE_GET/SET: read/write from closure's upvalue array
- OP_CLOSURE: reads upvalue descriptors, creates cells from
  enclosing frame's locals (is_local=1) or upvalues (is_local=0)
- vm_closure carries live env_ref (not snapshot)
- vm_call falls back to CEK for Lambda/Component/Island values

Verified: (let ((x 10)) (let ((add-x (fn (y) (+ x y)))) (add-x 5)))
  Compiles to: CONST 10, LOC_SET #0, CLOSURE [UV_GET#0 LOC_GET#0 CPRIM+ RET]
  with upvalue descriptor: is_local=1 index=0
  VM executes → 15 ✓

Auto-compile: 6/117 functions compile (up from 3). Disabled until
compiler handles all features — fallback can't reconstruct closure
scope for variables like nav-state bound in caller's let*.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-19 20:13:17 +00:00
parent a62b7c8a5e
commit 1bb40415a8
4 changed files with 135 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
hosts/ocaml/bin/sx_server.ml
View File

@@ -820,18 +820,21 @@ let dispatch env cmd =
match result with match result with
| Dict d when Hashtbl.mem d "bytecode" -> | Dict d when Hashtbl.mem d "bytecode" ->
let code = Sx_vm.code_from_value result in let code = Sx_vm.code_from_value result in
let globals_snapshot = Hashtbl.copy env.bindings in (* Live env reference — NOT a snapshot. Functions see
Hashtbl.iter (fun k v -> current bindings, including later-defined functions. *)
Hashtbl.replace globals_snapshot k v) lam.l_closure.bindings; let live_env = env.bindings in
(* VM closure with CEK fallback on error *) (* Original lambda for CEK fallback *)
let orig_lambda = Lambda lam in let orig_lambda = Lambda lam in
let fn = NativeFn ("vm:" ^ name, fun args -> let fn = NativeFn ("vm:" ^ name, fun args ->
try try
Sx_vm.execute_closure Sx_vm.call_closure
{ Sx_vm.code; name = lam.l_name } args globals_snapshot { Sx_vm.code; upvalues = [||]; name = lam.l_name;
with _ -> env_ref = live_env }
(* Fall back to CEK machine *) args live_env
Sx_ref.cek_call orig_lambda (List args)) in 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; Hashtbl.replace env.bindings name fn;
incr count incr count
| _ -> incr failed | _ -> incr failed

113
hosts/ocaml/lib/sx_vm.ml
View File

@@ -17,17 +17,26 @@ type code = {
constants : value array; 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 = { type vm_closure = {
code : code; code : code;
upvalues : upvalue_cell array;
name : string option; name : string option;
env_ref : (string, value) Hashtbl.t; (* live global env — NOT a snapshot *)
} }
(** Call frame — one per function invocation. *) (** Call frame — one per function invocation. *)
type frame = { type frame = {
closure : vm_closure; closure : vm_closure;
mutable ip : int; mutable ip : int;
base : int; (* base index in value stack for locals *) base : int; (* base index in value stack for locals *)
} }
(** VM state. *) (** VM state. *)
@@ -35,13 +44,11 @@ type vm = {
mutable stack : value array; mutable stack : value array;
mutable sp : int; mutable sp : int;
mutable frames : frame list; mutable frames : frame list;
globals : (string, value) Hashtbl.t; globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
} }
let create globals = let create globals =
let g = Hashtbl.create 256 in { stack = Array.make 4096 Nil; sp = 0; frames = []; globals }
Hashtbl.iter (fun k v -> Hashtbl.replace g k v) globals;
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals = g }
(** Stack ops — inlined for speed. *) (** Stack ops — inlined for speed. *)
let push vm v = let push vm v =
@@ -74,13 +81,21 @@ let[@inline] read_i16 f =
let v = read_u16 f in let v = read_u16 f in
if v >= 32768 then v - 65536 else v 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. *) (** Main execution loop. *)
let rec run vm = let rec run vm =
match vm.frames with match vm.frames with
| [] -> failwith "VM: no frame" | [] -> () (* no frame = done *)
| frame :: rest_frames -> | frame :: rest_frames ->
let bc = frame.closure.code.bytecode in let bc = frame.closure.code.bytecode in
let consts = frame.closure.code.constants 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 let op = bc.(frame.ip) in
frame.ip <- frame.ip + 1; frame.ip <- frame.ip + 1;
match op with match op with
@@ -104,6 +119,14 @@ let rec run vm =
let slot = read_u8 frame in let slot = read_u8 frame in
vm.stack.(frame.base + slot) <- peek vm; vm.stack.(frame.base + slot) <- peek vm;
run 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 *) -> | 20 (* OP_GLOBAL_GET *) ->
let idx = read_u16 frame in let idx = read_u16 frame in
let name = match consts.(idx) with String s -> s | _ -> "" 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 argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in let args = Array.init argc (fun _ -> pop vm) in
let f = 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 run vm
| 49 (* OP_TAIL_CALL *) -> | 49 (* OP_TAIL_CALL *) ->
let argc = read_u8 frame in let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in let args = Array.init argc (fun _ -> pop vm) in
let f = 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 *) (* Tail call: pop current frame, reuse stack space *)
vm.frames <- rest_frames; vm.frames <- rest_frames;
vm.sp <- frame.base; 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 run vm
| 50 (* OP_RETURN *) -> | 50 (* OP_RETURN *) ->
let result = pop vm in let result = pop vm in
vm.frames <- rest_frames; vm.frames <- rest_frames;
vm.sp <- frame.base; vm.sp <- frame.base;
push vm result 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 *) -> | 52 (* OP_CALL_PRIM *) ->
let idx = read_u16 frame in let idx = read_u16 frame in
let argc = read_u8 frame in let argc = read_u8 frame in
let name = match consts.(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 args = List.init argc (fun _ -> pop vm) |> List.rev in
let result = (match Sx_primitives.get_primitive name with let result =
NativeFn (_, fn) -> fn args | _ -> Nil) in (match Sx_primitives.get_primitive name with
| NativeFn (_, fn) -> fn args
| _ -> Nil)
in
push vm result; push vm result;
run vm run vm
@@ -200,28 +255,19 @@ let rec run vm =
Hashtbl.replace vm.globals name v; Hashtbl.replace vm.globals name v;
run vm 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 -> | opcode ->
(* Unknown opcode — fall back to CEK machine *)
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d" raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
opcode (frame.ip - 1))) opcode (frame.ip - 1)))
(** Call a value as a function — dispatch by type. *)
and vm_call vm f args = and vm_call vm f args =
match f with match f with
| NativeFn (_, fn) -> | NativeFn (_name, fn) ->
let result = fn args in let result = fn args in
push vm result push vm result
| Lambda _ -> | Lambda _ | Component _ | Island _ ->
(* Call a CEK-defined lambda through the VM *) (* Fall back to CEK machine for SX-defined functions *)
let result = Sx_ref.cek_call f (List args) in let result = Sx_ref.cek_call f (List args) in
push vm result push vm result
| _ -> | _ ->
@@ -240,12 +286,9 @@ and code_from_value v =
| Some (List l | ListRef { contents = l }) -> Array.of_list l | Some (List l | ListRef { contents = l }) -> Array.of_list l
| _ -> [||] | _ -> [||]
in in
(* Recursively convert nested code objects in the pool *)
let constants = Array.map (fun entry -> let constants = Array.map (fun entry ->
match entry with match entry with
| Dict ed when Hashtbl.mem ed "bytecode" -> | Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *)
(* Nested code object — keep as Dict for lazy conversion *)
entry
| _ -> entry | _ -> entry
) entries in ) entries in
let arity = match Hashtbl.find_opt d "arity" with 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; locals = arity + 16; bytecode = bc_list; constants }
| _ -> { arity = 0; locals = 16; bytecode = [||]; constants = [||] } | _ -> { arity = 0; locals = 16; bytecode = [||]; constants = [||] }
(** Execute a closure with arguments. *) (** Execute a closure with arguments — creates a new VM frame.
and execute_closure cl args globals = The closure carries its upvalue cells for captured variables. *)
and call_closure cl args globals =
let vm = create globals in let vm = create globals in
let frame = { closure = cl; ip = 0; base = vm.sp } in let frame = { closure = cl; ip = 0; base = vm.sp } in
(* Push args as locals *) (* Push args as locals *)
@@ -268,10 +312,9 @@ and execute_closure cl args globals =
(** Execute a compiled module (top-level bytecode). *) (** Execute a compiled module (top-level bytecode). *)
let execute_module code globals = 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 vm = create globals in
let frame = { closure = cl; ip = 0; base = 0 } in let frame = { closure = cl; ip = 0; base = 0 } in
(* Pad locals *)
for _ = 0 to code.locals - 1 do push vm Nil done; for _ = 0 to code.locals - 1 do push vm Nil done;
vm.frames <- [frame]; vm.frames <- [frame];
run vm; run vm;

6
shared/sx/ocaml_bridge.py
View File

@@ -265,9 +265,9 @@ class OcamlBridge:
_logger.info("Loaded %d definitions from .sx files into OCaml kernel (%d skipped)", _logger.info("Loaded %d definitions from .sx files into OCaml kernel (%d skipped)",
count, skipped) count, skipped)
# VM auto-compile ready but disabled until compiler handles # VM auto-compile: ready when compiler handles all SX features.
# all SX features and CEK fallback works correctly. # Currently 6/117 compile; fallback fails on closure scope vars.
# Enable with: await self._send('(vm-compile)') # await self._send('(vm-compile)')
except Exception as e: except Exception as e:
_logger.error("Failed to load .sx files into OCaml kernel: %s", e) _logger.error("Failed to load .sx files into OCaml kernel: %s", e)
self._components_loaded = False # retry next time self._components_loaded = False # retry next time

59
spec/compiler.sx
View File

@@ -45,6 +45,7 @@
{:locals (list) ;; list of {name, slot, mutable?} {:locals (list) ;; list of {name, slot, mutable?}
:upvalues (list) ;; list of {name, is-local, index} :upvalues (list) ;; list of {name, is-local, index}
:parent parent :parent parent
:is-function false ;; true for fn/lambda scopes (create frames)
:next-slot 0})) :next-slot 0}))
(define scope-define-local (define scope-define-local
@@ -58,32 +59,42 @@
(define scope-resolve (define scope-resolve
(fn (scope name) (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) (if (nil? scope)
{:type "global" :index name} {:type "global" :index name}
;; Check locals ;; Check locals in this scope
(let ((locals (get scope "locals")) (let ((locals (get scope "locals"))
(found (some (fn (l) (= (get l "name") name)) locals))) (found (some (fn (l) (= (get l "name") name)) locals)))
(if found (if found
(let ((local (first (filter (fn (l) (= (get l "name") name)) locals)))) (let ((local (first (filter (fn (l) (= (get l "name") name)) locals))))
{:type "local" :index (get local "slot")}) {:type "local" :index (get local "slot")})
;; Check upvalues (already captured) ;; Check upvalues already captured at this scope
(let ((upvals (get scope "upvalues")) (let ((upvals (get scope "upvalues"))
(uv-found (some (fn (u) (= (get u "name") name)) upvals))) (uv-found (some (fn (u) (= (get u "name") name)) upvals)))
(if uv-found (if uv-found
(let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals)))) (let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
{:type "upvalue" :index (get uv "index")}) {:type "upvalue" :index (get uv "index")})
;; Try parent scope — if found, capture as upvalue ;; Look in parent
(let ((parent-result (scope-resolve (get scope "parent") name))) (let ((parent (get scope "parent")))
(if (= (get parent-result "type") "global") (if (nil? parent)
parent-result {:type "global" :index name}
;; Capture from parent as upvalue (let ((parent-result (scope-resolve parent name)))
(let ((uv-idx (len (get scope "upvalues")))) (if (= (get parent-result "type") "global")
(append! (get scope "upvalues") parent-result
{:name name ;; Found in parent. Capture as upvalue only at function boundaries.
:is-local (= (get parent-result "type") "local") (if (get scope "is-function")
:index (get parent-result "index")}) ;; Function boundary — create upvalue capture
{:type "upvalue" :index uv-idx})))))))))) (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)) (let ((bindings (first args))
(body (rest args)) (body (rest args))
(let-scope (make-scope scope))) (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 ;; Compile each binding
(for-each (fn (binding) (for-each (fn (binding)
(let ((name (if (= (type-of (first binding)) "symbol") (let ((name (if (= (type-of (first binding)) "symbol")
@@ -378,6 +392,8 @@
(body (rest args)) (body (rest args))
(fn-scope (make-scope scope)) (fn-scope (make-scope scope))
(fn-em (make-emitter))) (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 ;; Define params as locals in fn scope
(for-each (fn (p) (for-each (fn (p)
(let ((name (if (= (type-of p) "symbol") (symbol-name p) 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 (compile-begin fn-em body fn-scope true) ;; tail position
(emit-op fn-em 50) ;; OP_RETURN (emit-op fn-em 50) ;; OP_RETURN
;; Add code object to parent constant pool ;; 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") :bytecode (get fn-em "bytecode")
:constants (get (get fn-em "pool") "entries") :constants (get (get fn-em "pool") "entries")
:upvalues (get fn-scope "upvalues")}) :upvalue-count (len upvals)})
(code-idx (pool-add (get em "pool") code))) (code-idx (pool-add (get em "pool") code)))
(emit-op em 51) ;; OP_CLOSURE (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 (define compile-define