Transpiler native record support for VM types (Step 5.5 unblock)
- Add VmFrame/VmMachine types to sx_types.ml (alongside CekState/CekFrame) - Add VmFrame/VmMachine value variants to the value sum type - Extend get_val in sx_runtime.ml to dispatch on VmFrame/VmMachine fields - Extend sx_dict_set_b for VmFrame/VmMachine field mutation - Extend transpiler ml-emit-dict-native to detect VM dict patterns and emit native OCaml record construction (same mechanism as CekState) - Retranspile evaluator — no diff (transpiler extension is additive) - Update bootstrap_vm.py output location The transpiler now handles 4 native record types: CekState (5 fields), CekFrame (10 fields), VmFrame (4 fields), VmMachine (5 fields) Full VM replacement (sx_vm.ml → transpiled) still needs vm.sx feature parity: JIT dispatch, CEK fallback, suspension handling. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -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 ->
|
||||
|
||||
@@ -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 "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
|
||||
| Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
|
||||
| VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
|
||||
| VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user