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

Fix vm-global-get in native OCaml VM + transpiled VM ref

Browse Source 
The previous commit fixed lib/vm.sx (SX spec) but the server uses
sx_vm.ml (hand-maintained native OCaml) and sx_vm_ref.ml (transpiled).
Both had the same globals-first lookup bug. Now all three implementations
check closure env before vm.globals, matching vm-global-set.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-06 12:14:30 +00:00
parent 3a9d113537
commit 577d09f443
3 changed files with 34 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -410,21 +410,23 @@ and 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
let v = try Hashtbl.find vm.globals name with Not_found -> (* Check closure env first (matches OP_GLOBAL_SET priority) *)
(* Walk the closure env chain for inner functions *) let id = Sx_types.intern name in
let id = Sx_types.intern name in let found_in_env = match frame.closure.vm_closure_env with
let rec env_lookup e = | Some env ->
try Hashtbl.find e.bindings id let rec env_lookup e =
with Not_found -> try Some (Hashtbl.find e.bindings id)
match e.parent with Some p -> env_lookup p | None -> with Not_found ->
try Sx_primitives.get_primitive name match e.parent with Some p -> env_lookup p | None -> None
with _ -> raise (Eval_error ("VM undefined: " ^ name)) in env_lookup env
in | None -> None
match frame.closure.vm_closure_env with in
| Some env -> env_lookup env let v = match found_in_env with
| Some v -> v
| None -> | None ->
try Sx_primitives.get_primitive name try Hashtbl.find vm.globals name with Not_found ->
with _ -> raise (Eval_error ("VM undefined: " ^ name)) try Sx_primitives.get_primitive name
with _ -> raise (Eval_error ("VM undefined: " ^ name))
in in
push vm v push vm v
| 21 (* OP_GLOBAL_SET *) -> | 21 (* OP_GLOBAL_SET *) ->

33
hosts/ocaml/lib/sx_vm_ref.ml
View File

@@ -198,32 +198,31 @@ let vm_globals_ref v = let m = unwrap_vm v in Dict m.vm_globals
let vm_global_get vm_val frame_val name = let vm_global_get vm_val frame_val name =
let m = unwrap_vm vm_val in let m = unwrap_vm vm_val in
let n = value_to_string name in let n = value_to_string name in
(* Try globals table first *) let f = unwrap_frame frame_val in
match Hashtbl.find_opt m.vm_globals n with (* Check closure env first (matches vm_global_set priority) *)
let found_in_env = match f.vf_closure.vm_closure_env with
| Some env ->
let id = intern n in
let rec find_env e =
match Hashtbl.find_opt e.bindings id with
| Some v -> Some v
| None -> (match e.parent with Some p -> find_env p | None -> None)
in find_env env
| None -> None
in
match found_in_env with
| Some v -> v | Some v -> v
| None -> | None ->
(* Walk closure env chain *) match Hashtbl.find_opt m.vm_globals n with
let f = unwrap_frame frame_val in | Some v -> v
let not_found () = | None ->
(* Try evaluator's primitive table *)
try prim_call n [] with _ -> try prim_call n [] with _ ->
(* Try symbol resolve hook — transparent lazy module loading *)
match !_symbol_resolve_hook with match !_symbol_resolve_hook with
| Some hook -> | Some hook ->
(match hook n with (match hook n with
| Some v -> v | Some v -> v
| None -> raise (Eval_error ("VM undefined: " ^ n))) | None -> raise (Eval_error ("VM undefined: " ^ n)))
| None -> raise (Eval_error ("VM undefined: " ^ n)) | None -> raise (Eval_error ("VM undefined: " ^ n))
in
(match f.vf_closure.vm_closure_env with
| Some env ->
let id = intern n in
let rec find_env e =
match Hashtbl.find_opt e.bindings id with
| Some v -> v
| None -> (match e.parent with Some p -> find_env p | None -> not_found ())
in find_env env
| None -> not_found ())
let vm_global_set vm_val frame_val name v = let vm_global_set vm_val frame_val name v =
let m = unwrap_vm vm_val in let m = unwrap_vm vm_val in

4
hosts/ocaml/sx_vm_ref.ml
View File

@@ -432,7 +432,7 @@ let rec vm_call vm f args =
(* vm-resolve-ho-form *) (* vm-resolve-ho-form *)
and vm_resolve_ho_form vm name = and vm_resolve_ho_form vm name =
(if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List.iter (fun x -> ignore ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll); Nil)) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.map (fun x -> (vm_call_external (vm) (f) ((List [x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.mapi (fun i x -> let i = Number (float_of_int i) in (vm_call_external (vm) (f) ((List [i; x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.filter (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; init; coll] -> (fun f init coll -> (List.fold_left (fun acc x -> (vm_call_external (vm) (f) ((List [acc; x])))) init (sx_to_list coll))) f init coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.exists (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.for_all (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM undefined: "); name])))))))))))) (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List.iter (fun x -> ignore ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll); Nil)) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.map (fun x -> (vm_call_external (vm) (f) ((List [x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.mapi (fun i x -> let i = Number (float_of_int i) in (vm_call_external (vm) (f) ((List [i; x])))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (List (List.filter (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; init; coll] -> (fun f init coll -> (List.fold_left (fun acc x -> (vm_call_external (vm) (f) ((List [acc; x])))) init (sx_to_list coll))) f init coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.exists (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (NativeFn ("\206\187", fun _args -> match _args with [f; coll] -> (fun f coll -> (Bool (List.for_all (fun x -> sx_truthy ((vm_call_external (vm) (f) ((List [x]))))) (sx_to_list coll)))) f coll | _ -> Nil)) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM undefined: "); name])))))))))))))
(* vm-call-external *) (* vm-call-external *)
and vm_call_external vm f args = and vm_call_external vm f args =
@@ -440,7 +440,7 @@ and vm_call_external vm f args =
(* vm-run *) (* vm-run *)
and vm_run vm = and vm_run vm =
(let () = ignore ((String "Execute bytecode until all frames are consumed.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (code_bytecode ((closure_code ((frame_closure (frame)))))) in let consts = (code_constants ((closure_code ((frame_closure (frame)))))) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (if sx_truthy ((is_nil ((get ((vm_globals_ref (vm))) ((String "__io_request")))))) then (loop ()) else Nil))))) else Nil)) in (loop ()))) (let () = ignore ((String "Execute bytecode until all frames are done or IO suspension.")) in (let rec loop = (fun () -> (if sx_truthy ((Bool (not (sx_truthy ((empty_p ((vm_frames (vm))))))))) then (let frame = (first ((vm_frames (vm)))) in let rest_frames = (rest ((vm_frames (vm)))) in (let bc = (_> (frame) (frame_closure) (closure_code) (code_bytecode)) in let consts = (_> (frame) (frame_closure) (closure_code) (code_constants)) in (if sx_truthy ((prim_call ">=" [(frame_ip (frame)); (len (bc))])) then (vm_set_frames_b (vm) ((List []))) else (let () = ignore ((vm_step (vm) (frame) (rest_frames) (bc) (consts))) in (if sx_truthy ((is_nil ((get ((vm_globals_ref (vm))) ((String "__io_request")))))) then (loop ()) else Nil))))) else Nil)) in (loop ())))
(* vm-step *) (* vm-step *)
and vm_step vm frame rest_frames bc consts = and vm_step vm frame rest_frames bc consts =