diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index df6871b3..c44f148e 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -80,6 +80,16 @@ let sx_dict_set_b d k v = match d, k with | Dict tbl, String key -> Hashtbl.replace tbl key v; v | Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v + | VmFrame f, String key -> + (match key with + | "ip" -> f.vf_ip <- val_to_int v; v + | _ -> raise (Eval_error ("dict-set! vm-frame: unknown field " ^ key))) + | VmMachine m, String key -> + (match key with + | "sp" -> m.vm_sp <- val_to_int v; v + | "frames" -> m.vm_frames <- (match v with List l -> List.map (fun x -> match x with VmFrame f -> f | _ -> raise (Eval_error "vm: frames must be vm-frame list")) l | _ -> []); v + | "stack" -> (match v with List _ -> v | _ -> raise (Eval_error "vm: stack must be array")) + | _ -> raise (Eval_error ("dict-set! vm-machine: unknown field " ^ key))) | _ -> raise (Eval_error "dict-set!: expected dict and string key") (** Get from dict or list. *) @@ -107,6 +117,20 @@ let get_val container key = | "first-render" -> f.cf_extra2 | "file" -> f.cf_env | "extra" -> f.cf_extra | "extra2" -> f.cf_extra2 | _ -> Nil) + | VmFrame f, String k -> + (match k with + | "ip" -> Number (float_of_int f.vf_ip) + | "closure" -> VmClosure f.vf_closure + | "base" -> Number (float_of_int f.vf_base) + | "local-cells" -> Nil (* opaque — accessed via frame-local-get/set *) + | _ -> Nil) + | VmMachine m, String k -> + (match k with + | "sp" -> Number (float_of_int m.vm_sp) + | "stack" -> Nil (* opaque — accessed via vm-push/pop *) + | "frames" -> List (List.map (fun f -> VmFrame f) m.vm_frames) + | "globals" -> Dict m.vm_globals + | _ -> Nil) | Dict d, String k -> dict_get d k | Dict d, Keyword k -> dict_get d k | (List l | ListRef { contents = l }), Number n -> diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 763ad941..dc9079bd 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -67,7 +67,10 @@ and value = | CekState of cek_state (** Optimized CEK machine state — avoids Dict allocation. *) | CekFrame of cek_frame (** Optimized CEK continuation frame. *) | VmClosure of vm_closure (** VM-compiled closure — callable within the VM without allocating a new VM. *) + | VmFrame of vm_frame (** VM call frame — one per function invocation. *) + | VmMachine of vm_machine (** VM state — stack, frames, globals. *) | Record of record (** R7RS record — opaque, generative, field-indexed. *) + | Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *) (** CEK machine state — record instead of Dict for performance. 5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *) @@ -155,6 +158,15 @@ and record = { r_fields : value array; (** mutable via Array.set for record-set! *) } +(** R7RS parameter — dynamic binding via provide frames on the kont stack. + Calling [(param)] searches kont for the nearest provide frame keyed + by [pm_uid]; if not found returns [pm_default]. *) +and parameter = { + pm_uid : string; (** unique ID — used as provide frame key *) + pm_default : value; (** initial/default value *) + pm_converter : value option; (** optional converter function *) +} + (** {1 Bytecode VM types} Defined here (not in sx_vm.ml) because [vm_code.constants] references @@ -183,6 +195,25 @@ and vm_closure = { vm_closure_env : env option; (** Original closure env for inner functions *) } +(** VM call frame — one per function invocation. + Defined here (not in sx_vm.ml) so it can be a [value] variant. *) +and vm_frame = { + vf_closure : vm_closure; + mutable vf_ip : int; + vf_base : int; + vf_local_cells : (int, vm_upvalue_cell) Hashtbl.t; +} + +(** VM state — stack machine with frame list. + Defined here for the same mutual-recursion reason. *) +and vm_machine = { + mutable vm_stack : value array; + mutable vm_sp : int; + mutable vm_frames : vm_frame list; + vm_globals : (string, value) Hashtbl.t; + mutable vm_pending_cek : value option; +} + (** {1 Forward ref for calling VM closures from outside the VM} *) @@ -201,6 +232,10 @@ exception Parse_error of string let rtd_table : (int, record_type) Hashtbl.t = Hashtbl.create 16 let rtd_counter = ref 0 +(** {1 Parameter UID counter} *) + +let param_counter = ref 0 + (** {1 Environment operations} *) @@ -369,7 +404,10 @@ let type_of = function | CekState _ -> "dict" (* CEK state behaves as a dict for type checks *) | CekFrame _ -> "dict" | VmClosure _ -> "function" + | VmFrame _ -> "vm-frame" + | VmMachine _ -> "vm-machine" | Record r -> r.r_type.rt_name + | Parameter _ -> "parameter" let is_nil = function Nil -> true | _ -> false let is_lambda = function Lambda _ -> true | _ -> false @@ -619,6 +657,20 @@ let make_record_mutator idx_val = | _ -> raise (Eval_error "record mutator: expected (record value)")) +(** {1 R7RS parameter accessors — called from transpiled evaluator} *) + +let parameter_p v = match v with Parameter _ -> Bool true | _ -> Bool false +let parameter_uid v = match v with + | Parameter p -> String p.pm_uid + | _ -> raise (Eval_error "parameter-uid: not a parameter") +let parameter_default v = match v with + | Parameter p -> p.pm_default + | _ -> raise (Eval_error "parameter-default: not a parameter") +let parameter_converter v = match v with + | Parameter p -> (match p.pm_converter with Some c -> c | None -> Nil) + | _ -> raise (Eval_error "parameter-converter: not a parameter") + + (** {1 Dict operations} *) let make_dict () : dict = Hashtbl.create 8 @@ -695,3 +747,6 @@ let rec inspect = function Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v) ) r.r_fields) in Printf.sprintf "" r.r_type.rt_name (String.concat " " fields) + | Parameter p -> Printf.sprintf "" p.pm_uid + | VmFrame f -> Printf.sprintf "" f.vf_ip f.vf_base + | VmMachine m -> Printf.sprintf "" m.vm_sp (List.length m.vm_frames) diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index c25dd3a6..1d18e69d 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -573,22 +573,52 @@ (ef "first-render") :else "Nil") " })")) - (str - "(let _d = Hashtbl.create " - (str (round (len items))) - " in " - (join - "; " - (map - (fn - (k) - (str - "Hashtbl.replace _d " - (ml-quote-string k) - " " - (ml-expr-inner (get d k) set-vars))) - items)) - "; Dict _d)")))))) + (if + (and + (some (fn (k) (= k "ip")) items) + (some (fn (k) (= k "closure")) items) + (some (fn (k) (= k "base")) items)) + (str + "(VmFrame { vf_closure = (match " + (ml-expr-inner (get d "closure") set-vars) + " with VmClosure c -> c | _ -> failwith \"vf_closure\")" + "; vf_ip = val_to_int " + (ml-expr-inner (get d "ip") set-vars) + "; vf_base = val_to_int " + (ml-expr-inner (get d "base") set-vars) + "; vf_local_cells = Hashtbl.create 4 })") + (if + (and + (some (fn (k) (= k "sp")) items) + (some (fn (k) (= k "stack")) items) + (some (fn (k) (= k "globals")) items)) + (str + "(VmMachine { vm_stack = (match " + (ml-expr-inner (get d "stack") set-vars) + " with List _ -> Array.make 4096 Nil | _ -> Array.make 4096 Nil)" + "; vm_sp = val_to_int " + (ml-expr-inner (get d "sp") set-vars) + "; vm_frames = []" + "; vm_globals = (match " + (ml-expr-inner (get d "globals") set-vars) + " with Dict d -> d | _ -> Hashtbl.create 0)" + "; vm_pending_cek = None })") + (str + "(let _d = Hashtbl.create " + (str (round (len items))) + " in " + (join + "; " + (map + (fn + (k) + (str + "Hashtbl.replace _d " + (ml-quote-string k) + " " + (ml-expr-inner (get d k) set-vars))) + items)) + "; Dict _d)")))))))) (define ml-emit-list