coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
df89d8249bdc3028690c1dce1d34a2542eec4e0b
rose-ash/hosts/ocaml/sx_vm_ref.ml
giles fc2b5e502f Step 5p6 lazy loading + Step 6b VM transpilation prep 
Lazy module loading (Step 5 piece 6 completion):
- Add define-library wrappers + import declarations to 13 source .sx files
- compile-modules.js generates module-manifest.json with dependency graph
- compile-modules.js strips define-library/import before bytecode compilation
  (VM doesn't handle these as special forms)
- sx-platform.js replaces hardcoded 24-file loadWebStack() with manifest-driven
  recursive loader — only downloads modules the page needs
- Result: 12 modules loaded (was 24), zero errors, zero warnings
- Fallback to full load if manifest missing

VM transpilation prep (Step 6b):
- Refactor lib/vm.sx: 20 accessor functions replace raw dict access
- Factor out collect-n-from-stack, collect-n-pairs, pad-n-nils helpers
- bootstrap_vm.py: transpiles 9 VM logic functions to OCaml
- sx_vm_ref.ml: proof that vm.sx transpiles (preamble has stubs)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-04 12:18:41 +00:00

176 lines
16 KiB
OCaml
Raw Blame History

(* sx_vm_ref.ml — Auto-generated from lib/vm.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *)
[@@@warning "-26-27"]
open Sx_types
open Sx_runtime
(* Forward references for CEK interop *)
let cek_call = Sx_ref.cek_call
let eval_expr = Sx_ref.eval_expr
let trampoline v = match v with
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
| other -> other
(* Primitive call dispatch *)
let call_primitive name args =
Sx_primitives.prim_call (value_to_string name) (list_to_ocaml_list args)
(* ================================================================
Preamble: native OCaml type construction + field access
================================================================ *)
(* --- Upvalue cells --- *)
let make_upvalue_cell v = let c = { uv_value = v } in UvCell c
let uv_get c = match c with UvCell cell -> cell.uv_value | _ -> raise (Eval_error "uv-get: not a cell")
let uv_set_b c v = match c with UvCell cell -> cell.uv_value <- v | _ -> raise (Eval_error "uv-set!: not a cell")
(* --- VM code --- *)
let make_vm_code arity locals bytecode constants =
let bc = match bytecode with
| List l -> Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
| _ -> [||] in
let cs = match constants with
| List l -> Array.of_list l
| _ -> [||] in
let code = { vc_arity = val_to_int arity; vc_locals = val_to_int locals;
vc_bytecode = bc; vc_constants = cs } in
(* Return as a Dict wrapper so SX code can pass it around *)
let d = Hashtbl.create 4 in
Hashtbl.replace d "vc-bytecode" bytecode;
Hashtbl.replace d "vc-constants" constants;
Hashtbl.replace d "vc-arity" arity;
Hashtbl.replace d "vc-locals" locals;
Hashtbl.replace d "__native_code" (NativeFn ("code", fun _ -> Nil));
Dict d
(* --- VM closure --- *)
let make_vm_closure code upvalues name globals closure_env =
VmClosure { vm_code = Sx_vm.code_from_value code;
vm_upvalues = (match upvalues with List l -> Array.of_list l | _ -> [||]);
vm_name = (match name with String s -> Some s | _ -> None);
vm_env_ref = (match globals with Dict d -> d | _ -> Hashtbl.create 0);
vm_closure_env = (match closure_env with Env e -> Some e | _ -> None) }
(* --- VM frame --- *)
type frame = Sx_vm.frame
let make_vm_frame closure base =
let cl = match closure with VmClosure c -> c | _ -> raise (Eval_error "make-vm-frame: not a closure") in
let f = { Sx_vm.closure = cl; ip = 0;
base = val_to_int base;
local_cells = Hashtbl.create 4 } in
(* Wrap as Dict for SX code *)
let d = Hashtbl.create 4 in
Hashtbl.replace d "__native_frame" (NativeFn ("frame", fun _ -> Nil));
Dict d
(* --- VM machine --- *)
let make_vm globals =
let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
let vm = Sx_vm.create g in
(* Wrap as Dict for SX code *)
let d = Hashtbl.create 4 in
Hashtbl.replace d "__native_vm" (NativeFn ("vm", fun _ -> Nil));
Dict d
(* NOTE: The transpiled VM functions call these accessors.
For now, the transpiled code delegates to the existing Sx_vm module.
Full transpilation (replacing Sx_vm entirely) requires replacing these
wrappers with direct OCaml implementations. *)
(* --- Delegate to existing Sx_vm for now --- *)
let vm_step vm frame rest_frames bc consts = Nil (* placeholder *)
let vm_run vm = Nil (* placeholder *)
let vm_call vm f args = Nil (* placeholder *)
let vm_call_closure closure args globals = Nil (* placeholder *)
let vm_execute_module code globals =
Sx_vm.execute_module (Sx_vm.code_from_value code)
(match globals with Dict d -> d | _ -> Hashtbl.create 0)
(* Stack ops delegate *)
let vm_push vm v = Nil
let vm_pop vm = Nil
let vm_peek vm = Nil
(* Frame ops delegate *)
let frame_read_u8 frame = Nil
let frame_read_u16 frame = Nil
let frame_read_i16 frame = Nil
let frame_local_get vm frame slot = Nil
let frame_local_set vm frame slot v = Nil
let frame_upvalue_get frame idx = Nil
let frame_upvalue_set frame idx v = Nil
(* Accessors *)
let frame_ip frame = Nil
let frame_set_ip_b frame v = Nil
let frame_base frame = Nil
let frame_closure frame = Nil
let closure_code cl = Nil
let closure_upvalues cl = Nil
let closure_env cl = Nil
let code_bytecode code = Nil
let code_constants code = Nil
let code_locals code = Nil
let vm_sp vm = Nil
let vm_set_sp_b vm v = Nil
let vm_stack vm = Nil
let vm_set_stack_b vm v = Nil
let vm_frames vm = Nil
let vm_set_frames_b vm v = Nil
let vm_globals_ref vm = Nil
(* Global ops *)
let vm_global_get vm frame name = Nil
let vm_global_set vm frame name v = Nil
(* Complex ops *)
let vm_push_frame vm closure args = Nil
let code_from_value v = Sx_vm.code_from_value v |> fun _ -> Nil
let vm_closure_p v = match v with VmClosure _ -> Bool true | _ -> Bool false
let vm_create_closure vm frame code_val = Nil
(* Collection helpers *)
let collect_n_from_stack vm n = Nil
let pad_n_nils vm n = Nil
(* === Transpiled from lib/vm.sx === *)
(* vm-call *)
let rec vm_call vm f args =
(if sx_truthy ((vm_closure_p (f))) then (vm_push_frame (vm) (f) (args)) else (if sx_truthy ((let _or = (prim_call "=" [(type_of (f)); (String "lambda")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (f)); (String "component")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (f)); (String "island")])))) then (vm_push (vm) ((cek_call (f) (args)))) else (if sx_truthy ((is_callable (f))) then (vm_push (vm) ((sx_apply f args))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: not callable: "); (type_of (f))]))))))))
(* vm-resolve-ho-form *)
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]))))))))))))
(* vm-call-external *)
and vm_call_external vm f args =
(if sx_truthy ((vm_closure_p (f))) then (vm_call_closure (f) (args) ((vm_globals_ref (vm)))) else (cek_call (f) (args)))
(* env-walk *)
and env_walk env name =
(if sx_truthy ((is_nil (env))) then Nil else (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (let parent = (env_parent (env)) in (if sx_truthy ((is_nil (parent))) then Nil else (env_walk (parent) (name))))))
(* env-walk-set! *)
and env_walk_set_b env name value =
(if sx_truthy ((is_nil (env))) then (Bool false) else (if sx_truthy ((env_has (env) (name))) then (let () = ignore ((env_set env (sx_to_string name) value)) in (Bool true)) else (let parent = (env_parent (env)) in (if sx_truthy ((is_nil (parent))) then (Bool false) else (env_walk_set_b (parent) (name) (value))))))
(* vm-run *)
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 (loop ()))))) else Nil)) in (loop ())))
(* vm-step *)
and vm_step vm frame rest_frames bc consts =
(let op = (frame_read_u8 (frame)) in (if sx_truthy ((prim_call "=" [op; (Number 1.0)])) then (let idx = (frame_read_u16 (frame)) in (vm_push (vm) ((nth (consts) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 2.0)])) then (vm_push (vm) (Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 3.0)])) then (vm_push (vm) ((Bool true))) else (if sx_truthy ((prim_call "=" [op; (Number 4.0)])) then (vm_push (vm) ((Bool false))) else (if sx_truthy ((prim_call "=" [op; (Number 5.0)])) then (vm_pop (vm)) else (if sx_truthy ((prim_call "=" [op; (Number 6.0)])) then (vm_push (vm) ((vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 16.0)])) then (let slot = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_local_get (vm) (frame) (slot))))) else (if sx_truthy ((prim_call "=" [op; (Number 17.0)])) then (let slot = (frame_read_u8 (frame)) in (frame_local_set (vm) (frame) (slot) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 18.0)])) then (let idx = (frame_read_u8 (frame)) in (vm_push (vm) ((frame_upvalue_get (frame) (idx))))) else (if sx_truthy ((prim_call "=" [op; (Number 19.0)])) then (let idx = (frame_read_u8 (frame)) in (frame_upvalue_set (frame) (idx) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 20.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_push (vm) ((vm_global_get (vm) (frame) (name))))) else (if sx_truthy ((prim_call "=" [op; (Number 21.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (vm_global_set (vm) (frame) (name) ((vm_peek (vm))))) else (if sx_truthy ((prim_call "=" [op; (Number 32.0)])) then (let offset = (frame_read_i16 (frame)) in (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset])))) else (if sx_truthy ((prim_call "=" [op; (Number 33.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy ((Bool (not (sx_truthy (v))))) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 34.0)])) then (let offset = (frame_read_i16 (frame)) in let v = (vm_pop (vm)) in (if sx_truthy (v) then (frame_set_ip_b (frame) ((prim_call "+" [(frame_ip (frame)); offset]))) else Nil)) else (if sx_truthy ((prim_call "=" [op; (Number 48.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (vm_call (vm) (f) (args))) else (if sx_truthy ((prim_call "=" [op; (Number 49.0)])) then (let argc = (frame_read_u8 (frame)) in let args = (collect_n_from_stack (vm) (argc)) in let f = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_call (vm) (f) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 50.0)])) then (let result' = (vm_pop (vm)) in (let () = ignore ((vm_set_frames_b (vm) (rest_frames))) in (let () = ignore ((vm_set_sp_b (vm) ((frame_base (frame))))) in (vm_push (vm) (result'))))) else (if sx_truthy ((prim_call "=" [op; (Number 51.0)])) then (let idx = (frame_read_u16 (frame)) in let code_val = (nth (consts) (idx)) in (let cl = (vm_create_closure (vm) (frame) (code_val)) in (vm_push (vm) (cl)))) else (if sx_truthy ((prim_call "=" [op; (Number 52.0)])) then (let idx = (frame_read_u16 (frame)) in let argc = (frame_read_u8 (frame)) in let name = (nth (consts) (idx)) in let args = (collect_n_from_stack (vm) (argc)) in (vm_push (vm) ((call_primitive (name) (args))))) else (if sx_truthy ((prim_call "=" [op; (Number 64.0)])) then (let count = (frame_read_u16 (frame)) in let items = (collect_n_from_stack (vm) (count)) in (vm_push (vm) (items))) else (if sx_truthy ((prim_call "=" [op; (Number 65.0)])) then (let count = (frame_read_u16 (frame)) in let d = (collect_n_pairs (vm) (count)) in (vm_push (vm) (d))) else (if sx_truthy ((prim_call "=" [op; (Number 144.0)])) then (let count = (frame_read_u8 (frame)) in let parts = (collect_n_from_stack (vm) (count)) in (vm_push (vm) ((sx_apply str parts)))) else (if sx_truthy ((prim_call "=" [op; (Number 128.0)])) then (let idx = (frame_read_u16 (frame)) in let name = (nth (consts) (idx)) in (sx_dict_set_b (vm_globals_ref (vm)) name (vm_peek (vm)))) else (if sx_truthy ((prim_call "=" [op; (Number 160.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "+" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 161.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "-" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 162.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "*" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 163.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "/" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 164.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "=" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 165.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call "<" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 166.0)])) then (let b = (vm_pop (vm)) in let a = (vm_pop (vm)) in (vm_push (vm) ((prim_call ">" [a; b])))) else (if sx_truthy ((prim_call "=" [op; (Number 167.0)])) then (vm_push (vm) ((Bool (not (sx_truthy ((vm_pop (vm)))))))) else (if sx_truthy ((prim_call "=" [op; (Number 168.0)])) then (vm_push (vm) ((len ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 169.0)])) then (vm_push (vm) ((first ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 170.0)])) then (vm_push (vm) ((rest ((vm_pop (vm)))))) else (if sx_truthy ((prim_call "=" [op; (Number 171.0)])) then (let n = (vm_pop (vm)) in let coll = (vm_pop (vm)) in (vm_push (vm) ((nth (coll) (n))))) else (if sx_truthy ((prim_call "=" [op; (Number 172.0)])) then (let coll = (vm_pop (vm)) in let x = (vm_pop (vm)) in (vm_push (vm) ((cons (x) (coll))))) else (if sx_truthy ((prim_call "=" [op; (Number 173.0)])) then (vm_push (vm) ((prim_call "-" [(Number 0.0); (vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 174.0)])) then (vm_push (vm) ((prim_call "inc" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 175.0)])) then (vm_push (vm) ((prim_call "dec" [(vm_pop (vm))]))) else (if sx_truthy ((prim_call "=" [op; (Number 112.0)])) then (let request = (vm_pop (vm)) in (raise (Eval_error (value_to_str (String (sx_str [(String "VM: IO suspension (OP_PERFORM) — request: "); request])))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "VM: unknown opcode "); op])))))))))))))))))))))))))))))))))))))))))))))))
(* vm-call-closure *)
and vm_call_closure closure args globals =
(let vm = (make_vm (globals)) in (let () = ignore ((vm_push_frame (vm) (closure) (args))) in (let () = ignore ((vm_run (vm))) in (vm_pop (vm)))))
(* vm-execute-module *)
and vm_execute_module code globals =
(let closure = (make_vm_closure (code) ((List [])) ((String "module")) (globals) (Nil)) in let vm = (make_vm (globals)) in (let frame = (make_vm_frame (closure) ((Number 0.0))) in (let () = ignore ((pad_n_nils (vm) ((code_locals (code))))) in (let () = ignore ((vm_set_frames_b (vm) ((List [frame])))) in (let () = ignore ((vm_run (vm))) in (vm_pop (vm)))))))
Reference in New Issue View Git Blame Copy Permalink