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

OCaml runtime: R7RS parameters, VM closure introspection, import suspension

Browse Source 
- R7RS parameter primitives (make-parameter, parameter?, parameterize support)
- VM closure get_val introspection (vm-code, vm-upvalues, vm-name, vm-globals)
- Lazy list caching on vm_code for transpiled VM performance
- VM import suspension: check_io_suspension + resume_module for browser lazy loading
- 23 new R7RS tests (parameter-basic, parameterize-basic, syntax-rules-basic)
- Playwright bytecode-loading spec + WASM rebuild

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-04 18:48:51 +00:00
parent 2727577702
commit 4baed1853c
16 changed files with 692 additions and 178 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
hosts/ocaml/bootstrap_vm.py
View File

@@ -376,7 +376,8 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *)
let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let _is_jit_failed cl = cl.vm_code.vc_arity = -1
@@ -574,7 +575,20 @@ let () = _vm_call_fn := vm_call
Public API — matches Sx_vm interface for drop-in replacement
================================================================ *)
(** Execute a compiled module — entry point for load-sxbc, compile-blob. *)
(** Build a suspension dict from __io_request in globals. *)
let check_io_suspension globals vm_val =
match Hashtbl.find_opt globals "__io_request" with
| Some req when sx_truthy req ->
let d = Hashtbl.create 4 in
Hashtbl.replace d "suspended" (Bool true);
Hashtbl.replace d "op" (String "import");
Hashtbl.replace d "request" req;
Hashtbl.replace d "vm" vm_val;
Some (Dict d)
| _ -> None
(** Execute a compiled module — entry point for load-sxbc, compile-blob.
Returns the result value, or a suspension dict if OP_PERFORM fired. *)
let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module";
vm_env_ref = globals; vm_closure_env = None } in
@@ -587,7 +601,25 @@ let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
done;
m.vm_frames <- [frame];
ignore (vm_run vm_val);
vm_pop vm_val
match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val
(** Resume a suspended module. Clears __io_request, pushes nil, re-runs. *)
let resume_module (suspended : value) =
match suspended with
| Dict d ->
let vm_val = Hashtbl.find d "vm" in
let globals = match vm_val with
| VmMachine m -> m.vm_globals
| _ -> raise (Eval_error "resume_module: expected VmMachine") in
Hashtbl.replace globals "__io_request" Nil;
ignore (vm_push vm_val Nil);
ignore (vm_run vm_val);
(match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val)
| _ -> raise (Eval_error "resume_module: expected suspension dict")
(** Execute a closure with args — entry point for JIT Lambda calls. *)
let call_closure (cl : vm_closure) (args : value list) (globals : (string, value) Hashtbl.t) =

36
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -208,6 +208,8 @@ let () =
for i = 0 to Array.length a.r_fields - 1 do
if not (safe_eq a.r_fields.(i) b.r_fields.(i)) then eq := false
done; !eq)
(* Parameters: same UID = same parameter *)
| Parameter a, Parameter b -> a.pm_uid = b.pm_uid
(* Lambda/Component/Island/Signal/NativeFn: physical only *)
| _ -> false
in
@@ -732,6 +734,7 @@ let () =
String (Printf.sprintf "~%s" i.i_name)
| [Lambda _] -> String "<lambda>"
| [Record r] -> String (Printf.sprintf "#<%s>" r.r_type.rt_name)
| [Parameter p] -> String (Printf.sprintf "#<parameter %s>" p.pm_uid)
| [a] -> String (inspect a) (* used for dedup keys in compiler *)
| _ -> raise (Eval_error "serialize: 1 arg"));
register "make-symbol" (fun args ->
@@ -951,6 +954,39 @@ let () =
register "make-record-mutator" (fun args ->
match args with [idx] -> make_record_mutator idx
| _ -> raise (Eval_error "make-record-mutator: expected (index)"));
(* R7RS parameters — converter stored, applied by parameterize frame *)
register "make-parameter" (fun args ->
match args with
| [init] ->
let uid = !param_counter in
incr param_counter;
Parameter { pm_uid = "__param_" ^ string_of_int uid;
pm_default = init; pm_converter = None }
| [init; converter] ->
let uid = !param_counter in
incr param_counter;
(* Apply converter to init for NativeFn, store raw for Lambda *)
let converted = match converter with
| NativeFn (_, f) -> f [init]
| _ -> init (* Lambda converters applied via CEK at parameterize time *)
in
Parameter { pm_uid = "__param_" ^ string_of_int uid;
pm_default = converted; pm_converter = Some converter }
| _ -> raise (Eval_error "make-parameter: expected 1-2 args"));
register "parameter?" (fun args ->
match args with [Parameter _] -> Bool true | [_] -> Bool false
| _ -> Bool false);
register "parameter-uid" (fun args ->
match args with [Parameter p] -> String p.pm_uid
| _ -> raise (Eval_error "parameter-uid: expected parameter"));
register "parameter-default" (fun args ->
match args with [Parameter p] -> p.pm_default
| _ -> raise (Eval_error "parameter-default: expected parameter"));
register "parameter-converter" (fun args ->
match args with
| [Parameter p] -> (match p.pm_converter with Some c -> c | None -> Nil)
| _ -> raise (Eval_error "parameter-converter: expected parameter"));
register "is-else-clause?" (fun args ->
match args with
| [Keyword "else"] -> Bool true

32
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -131,6 +131,38 @@ let get_val container key =
| "frames" -> List (List.map (fun f -> VmFrame f) m.vm_frames)
| "globals" -> Dict m.vm_globals
| _ -> Nil)
| VmClosure cl, String k ->
(match k with
| "vm-code" ->
(* Return vm_code fields as a Dict. The bytecode and constants arrays
are lazily converted to Lists and cached on the vm_code record so
the transpiled VM loop (which re-derives bc/consts each iteration)
doesn't allocate on every step. *)
let c = cl.vm_code in
let bc = match c.vc_bytecode_list with
| Some l -> l
| None ->
let l = Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vc_bytecode) in
c.vc_bytecode_list <- Some l; l in
let consts = match c.vc_constants_list with
| Some l -> l
| None ->
let l = Array.to_list c.vc_constants in
c.vc_constants_list <- Some l; l in
let d = Hashtbl.create 4 in
Hashtbl.replace d "vc-bytecode" (List bc);
Hashtbl.replace d "vc-constants" (List consts);
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
Dict d
| "vm-upvalues" ->
List (Array.to_list (Array.map (fun uv -> uv.uv_value) cl.vm_upvalues))
| "vm-name" ->
(match cl.vm_name with Some n -> String n | None -> Nil)
| "vm-globals" -> Dict cl.vm_env_ref
| "vm-closure-env" ->
(match cl.vm_closure_env with Some e -> Env e | None -> Nil)
| _ -> Nil)
| Dict d, String k -> dict_get d k
| Dict d, Keyword k -> dict_get d k
| (List l | ListRef { contents = l }), Number n ->

2
hosts/ocaml/lib/sx_types.ml
View File

@@ -179,6 +179,8 @@ and vm_code = {
vc_locals : int;
vc_bytecode : int array;
vc_constants : value array;
mutable vc_bytecode_list : value list option; (** Lazy cache for transpiled VM *)
mutable vc_constants_list : value list option; (** Lazy cache for transpiled VM *)
}
(** Upvalue cell — shared mutable reference to a captured variable. *)

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

@@ -41,7 +41,8 @@ let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option)
(** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *)
let jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
@@ -131,8 +132,10 @@ let code_from_value v =
let arity = match Hashtbl.find_opt d "arity" with
| Some (Number n) -> int_of_float n | _ -> 0
in
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants }
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||] }
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants;
vc_bytecode_list = None; vc_constants_list = None }
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }
(** Call an SX value via CEK, detecting suspension instead of erroring.
Returns the result value, or raises VmSuspended if CEK suspends.

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

@@ -287,7 +287,8 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *)
let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let _is_jit_failed cl = cl.vm_code.vc_arity = -1

38
hosts/ocaml/sx_vm_ref.ml
View File

@@ -287,7 +287,8 @@ let vm_create_closure vm_val frame_val code_val =
(* --- JIT sentinel --- *)
let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let _is_jit_failed cl = cl.vm_code.vc_arity = -1
@@ -455,7 +456,20 @@ let () = _vm_call_fn := vm_call
Public API — matches Sx_vm interface for drop-in replacement
================================================================ *)
(** Execute a compiled module — entry point for load-sxbc, compile-blob. *)
(** Build a suspension dict from __io_request in globals. *)
let check_io_suspension globals vm_val =
match Hashtbl.find_opt globals "__io_request" with
| Some req when sx_truthy req ->
let d = Hashtbl.create 4 in
Hashtbl.replace d "suspended" (Bool true);
Hashtbl.replace d "op" (String "import");
Hashtbl.replace d "request" req;
Hashtbl.replace d "vm" vm_val;
Some (Dict d)
| _ -> None
(** Execute a compiled module — entry point for load-sxbc, compile-blob.
Returns the result value, or a suspension dict if OP_PERFORM fired. *)
let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module";
vm_env_ref = globals; vm_closure_env = None } in
@@ -468,7 +482,25 @@ let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
done;
m.vm_frames <- [frame];
ignore (vm_run vm_val);
vm_pop vm_val
match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val
(** Resume a suspended module. Clears __io_request, pushes nil, re-runs. *)
let resume_module (suspended : value) =
match suspended with
| Dict d ->
let vm_val = Hashtbl.find d "vm" in
let globals = match vm_val with
| VmMachine m -> m.vm_globals
| _ -> raise (Eval_error "resume_module: expected VmMachine") in
Hashtbl.replace globals "__io_request" Nil;
ignore (vm_push vm_val Nil);
ignore (vm_run vm_val);
(match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val)
| _ -> raise (Eval_error "resume_module: expected suspension dict")
(** Execute a closure with args — entry point for JIT Lambda calls. *)
let call_closure (cl : vm_closure) (args : value list) (globals : (string, value) Hashtbl.t) =