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

VM aser-slot routing: isolated globals, inner code extraction, debug

Browse Source 
aser-slot now routes through the VM when adapter is compiled:
- compile_adapter: compiles each define body, extracts inner code
  from OP_CLOSURE wrapper, stores as NativeFn in separate globals
- vm_adapter_globals: isolated from kernel env (no cross-contamination)
- aser-slot checks vm_adapter_globals, calls VM aser directly

Status: 2/12 adapter functions compile and run on VM. 6 fail during
OCaml-side compilation with "index out of bounds" — likely from
set-nth! silent failure on ListRef during bytecode jump patching.

Debug output shows outer code structure is correct (4 bytes, 1 const).
Inner code_from_value conversion needs fixing for nested closures.

Also: vm-compile-adapter command inside _ensure_components lock
(fixes pipe desync from concurrent requests).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-19 22:18:21 +00:00
parent df256b5607
commit 231bfbecb5
3 changed files with 163 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -647,6 +647,101 @@ let make_server_env () =
env
(* ====================================================================== *)
(* VM adapter — compiled aser functions in isolated globals *)
(* ====================================================================== *)
(** Compiled adapter globals — separate from kernel env.
Contains compiled aser functions + reads from kernel env for
components, helpers, and other runtime bindings. *)
let vm_adapter_globals : (string, value) Hashtbl.t option ref = ref None
(** Compile adapter-sx.sx and store in vm_adapter_globals.
Called from vm-compile-adapter command. *)
let compile_adapter env =
if not (Hashtbl.mem env.bindings "compile") then
raise (Eval_error "compiler not loaded")
else begin
let compile_fn = Hashtbl.find env.bindings "compile" in
(* Find and parse adapter-sx.sx *)
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found ->
try Filename.concat (Sys.getenv "SX_SPEC_DIR") "../web"
with Not_found -> "web" in
let adapter_path = Filename.concat web_dir "adapter-sx.sx" in
if not (Sys.file_exists adapter_path) then
raise (Eval_error ("adapter-sx.sx not found: " ^ adapter_path));
let exprs = Sx_parser.parse_file adapter_path in
(* Compile each define's body *)
let globals = Hashtbl.create 64 in
(* Seed with kernel env for component/helper lookups *)
Hashtbl.iter (fun k v -> Hashtbl.replace globals k v) env.bindings;
let compiled = ref 0 in
List.iter (fun expr ->
match expr with
| List (Symbol "define" :: Symbol name :: rest) ->
(* Find the body — skip :effects annotations *)
let rec find_body = function
| Keyword _ :: _ :: rest -> find_body rest
| body :: _ -> body
| [] -> Nil
in
let body = find_body rest in
(try
let quoted = List [Symbol "quote"; body] in
let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env env) in
match result with
| Dict d when Hashtbl.mem d "bytecode" ->
let outer_code = Sx_vm.code_from_value result in
Printf.eprintf "[vm] %s: outer bc=%d consts=%d inner_type=%s\n%!"
name (Array.length outer_code.Sx_vm.bytecode)
(Array.length outer_code.Sx_vm.constants)
(if Array.length outer_code.Sx_vm.constants > 0 then
type_of outer_code.Sx_vm.constants.(0) else "empty");
(* The compiled define body is (fn ...) which compiles to
OP_CLOSURE + [upvalue descriptors] + OP_RETURN.
Extract the inner code object from constants[idx]. *)
let code =
let bc = outer_code.Sx_vm.bytecode in
if Array.length bc >= 4 && bc.(0) = 51 then begin
let idx = bc.(1) lor (bc.(2) lsl 8) in
if idx < Array.length outer_code.Sx_vm.constants then begin
let inner_val = outer_code.Sx_vm.constants.(idx) in
try Sx_vm.code_from_value inner_val
with e ->
Printf.eprintf "[vm] inner code_from_value failed for %s: %s\n%!"
name (Printexc.to_string e);
Printf.eprintf "[vm] inner val type: %s\n%!" (type_of inner_val);
(match inner_val with
| Dict d ->
Printf.eprintf "[vm] inner keys: %s\n%!"
(String.concat ", " (Hashtbl.fold (fun k _ acc -> k::acc) d []));
(match Hashtbl.find_opt d "bytecode" with
| Some v -> Printf.eprintf "[vm] bytecode type: %s\n%!" (type_of v)
| None -> Printf.eprintf "[vm] NO bytecode key\n%!")
| _ -> ());
raise e
end else outer_code
end else outer_code
in
let cl = { Sx_vm.code; upvalues = [||]; name = Some name;
env_ref = globals } in
Hashtbl.replace globals name
(NativeFn ("vm:" ^ name, fun args ->
Sx_vm.call_closure cl args globals));
incr compiled
| _ -> () (* non-dict result — skip *)
with e ->
Printf.eprintf "[vm] FAIL adapter %s: %s\n%!" name (Printexc.to_string e))
| _ ->
(* Non-define expression — evaluate on CEK to set up constants *)
(try ignore (Sx_ref.eval_expr expr (Env env)) with _ -> ())
) exprs;
vm_adapter_globals := Some globals;
Printf.eprintf "[vm] Compiled adapter: %d functions\n%!" !compiled
end
(* ====================================================================== *)
(* Command dispatch *)
(* ====================================================================== *)
@@ -743,25 +838,53 @@ let dispatch env cmd =
| Eval_error msg -> send_error msg
| exn -> send_error (Printexc.to_string exn))
| List [Symbol "aser-slot"; String src] ->
(* Expand ALL components server-side. Uses batch IO mode for
concurrent highlight calls. Tries VM first, falls back to CEK. *)
| List [Symbol "vm-compile-adapter"] ->
(* Compile adapter-sx.sx to VM bytecode with isolated globals *)
(try
compile_adapter env;
send_ok ()
with
| Eval_error msg -> send_error msg
| exn -> send_error (Printexc.to_string exn))
| List [Symbol "aser-slot"; String src] ->
(* Expand ALL components server-side. Uses batch IO mode.
Routes through VM if adapter is compiled, else CEK. *)
(try
ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true)));
io_batch_mode := true;
io_queue := [];
io_counter := 0;
let exprs = Sx_parser.parse_all src in
let expr = match exprs with
| [e] -> e
| [] -> Nil
| _ -> List (Symbol "<>" :: exprs)
in
let call = List [Symbol "aser";
List [Symbol "quote"; expr];
Env env] in
io_batch_mode := true;
io_queue := [];
io_counter := 0;
let t0 = Unix.gettimeofday () in
let result = Sx_ref.eval_expr call (Env env) in
let result = match !vm_adapter_globals with
| Some globals ->
(* VM path: call compiled aser directly *)
Hashtbl.replace globals "expand-components?"
(NativeFn ("expand-components?", fun _args -> Bool true));
let aser_fn = try Hashtbl.find globals "aser"
with Not_found -> raise (Eval_error "VM: aser not compiled") in
let r = match aser_fn with
| NativeFn (_, fn) -> fn [expr; Env env]
| _ -> raise (Eval_error "VM: aser not a function")
in
Hashtbl.remove globals "expand-components?";
r
| None ->
(* CEK fallback *)
ignore (env_bind env "expand-components?"
(NativeFn ("expand-components?", fun _args -> Bool true)));
let call = List [Symbol "aser";
List [Symbol "quote"; expr];
Env env] in
let r = Sx_ref.eval_expr call (Env env) in
Hashtbl.remove env.bindings "expand-components?";
r
in
let t1 = Unix.gettimeofday () in
io_batch_mode := false;
Hashtbl.remove env.bindings "expand-components?";

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

@@ -95,14 +95,18 @@ let rec run vm =
| 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 *)
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;
match op with
(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
@@ -114,10 +118,14 @@ let rec run vm =
(* ---- Variable access ---- *)
| 16 (* OP_LOCAL_GET *) ->
let slot = read_u8 frame in
(* Check if this local is captured — read from shared cell *)
let v = match Hashtbl.find_opt frame.local_cells slot with
| Some cell -> cell.uv_value
| None -> vm.stack.(frame.base + slot)
| 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
@@ -131,6 +139,10 @@ let rec run vm =
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 *) ->
@@ -279,9 +291,14 @@ let rec run vm =
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)))
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 =