vm-ext: phase B — extension registry module
sx_vm_extension.ml: handler type, extensible extension_state variant, EXTENSION first-class module signature. sx_vm_extensions.ml: register / dispatch / id_of_name / state_of_extension. install_dispatch () runs at module init, swapping Phase A's stub for the real registry. Rejects out-of-range opcode IDs (must be 200-247), duplicate IDs, duplicate names, and duplicate extension names. Tests: 9 new foundation cases — lookup hits/misses, end-to-end VM dispatch including opcode composition, all four rejection paths. +9 pass vs Phase A baseline, no regressions across 11 conformance suites.
This commit is contained in:
48
hosts/ocaml/lib/sx_vm_extension.ml
Normal file
48
hosts/ocaml/lib/sx_vm_extension.ml
Normal file
@@ -0,0 +1,48 @@
|
||||
(** {1 VM extension interface}
|
||||
|
||||
Type definitions for VM bytecode extensions. See
|
||||
[plans/sx-vm-opcode-extension.md].
|
||||
|
||||
An extension is a first-class module of type [EXTENSION]: it has a
|
||||
stable [name], an [init] that returns its private state, and an
|
||||
[opcodes] function that lists the opcodes it provides.
|
||||
|
||||
Opcode handlers receive the live [vm] and the active [frame]. They
|
||||
read operands via [Sx_vm.read_u8] / [read_u16], manipulate the stack
|
||||
via [push] / [pop] / [peek], and update the frame's [ip] as needed. *)
|
||||
|
||||
(** A handler for an extension opcode. Reads operands from bytecode,
|
||||
manipulates the VM stack, updates the frame's instruction pointer.
|
||||
May raise exceptions (which propagate via the existing VM error path). *)
|
||||
type handler = Sx_vm.vm -> Sx_vm.frame -> unit
|
||||
|
||||
(** State an extension carries alongside the VM. Opaque to the VM core;
|
||||
extensions extend this with their own constructor and cast as needed.
|
||||
|
||||
Extensible variant — extensions add cases:
|
||||
{[
|
||||
type Sx_vm_extension.extension_state +=
|
||||
| ErlangState of erlang_scheduler
|
||||
]} *)
|
||||
type extension_state = ..
|
||||
|
||||
(** An extension is a first-class module of this signature. *)
|
||||
module type EXTENSION = sig
|
||||
(** Stable name for this extension (e.g. ["erlang"], ["guest_vm"]).
|
||||
Used as the lookup key in the registry and as the prefix for opcode
|
||||
names ([erlang.OP_PATTERN_TUPLE_2] etc). *)
|
||||
val name : string
|
||||
|
||||
(** Initialize per-instance state. Called once when [register] is
|
||||
invoked on this extension. *)
|
||||
val init : unit -> extension_state
|
||||
|
||||
(** Opcodes this extension provides. Each is
|
||||
[(opcode_id, opcode_name, handler)].
|
||||
|
||||
[opcode_id] must be in the range 200-247 (the extension partition;
|
||||
see the partition comment at the top of [Sx_vm]'s dispatch loop).
|
||||
Conflicts with already-registered opcodes cause [register] to
|
||||
fail. *)
|
||||
val opcodes : extension_state -> (int * string * handler) list
|
||||
end
|
||||
89
hosts/ocaml/lib/sx_vm_extensions.ml
Normal file
89
hosts/ocaml/lib/sx_vm_extensions.ml
Normal file
@@ -0,0 +1,89 @@
|
||||
(** {1 VM extension registry}
|
||||
|
||||
Holds the live registry of extension opcodes and installs the
|
||||
[dispatch] function into [Sx_vm.extension_dispatch_ref] at module
|
||||
init time, replacing Phase A's stub.
|
||||
|
||||
See [plans/sx-vm-opcode-extension.md] and [Sx_vm_extension] for the
|
||||
extension interface. *)
|
||||
|
||||
open Sx_vm_extension
|
||||
|
||||
(** The opcode range an extension is allowed to claim.
|
||||
Mirrors the partition comment in [Sx_vm]. *)
|
||||
let extension_min = 200
|
||||
let extension_max = 247
|
||||
|
||||
(** opcode_id → handler *)
|
||||
let by_id : (int, handler) Hashtbl.t = Hashtbl.create 64
|
||||
|
||||
(** opcode_name → opcode_id *)
|
||||
let by_name : (string, int) Hashtbl.t = Hashtbl.create 64
|
||||
|
||||
(** extension_name → state *)
|
||||
let states : (string, extension_state) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Registered extension names, newest first. *)
|
||||
let extensions : string list ref = ref []
|
||||
|
||||
(** Dispatch an extension opcode to its registered handler. Raises
|
||||
[Sx_vm.Invalid_opcode] if no handler is registered for [op]. *)
|
||||
let dispatch op vm frame =
|
||||
match Hashtbl.find_opt by_id op with
|
||||
| Some handler -> handler vm frame
|
||||
| None -> raise (Sx_vm.Invalid_opcode op)
|
||||
|
||||
(** Register an extension. Fails if the extension name is already
|
||||
registered, or if any opcode_id is outside the extension range or
|
||||
collides with an already-registered opcode. *)
|
||||
let register (m : (module EXTENSION)) =
|
||||
let module M = (val m) in
|
||||
if Hashtbl.mem states M.name then
|
||||
failwith (Printf.sprintf
|
||||
"Sx_vm_extensions: extension %S already registered" M.name);
|
||||
let st = M.init () in
|
||||
let ops = M.opcodes st in
|
||||
List.iter (fun (id, opname, _h) ->
|
||||
if id < extension_min || id > extension_max then
|
||||
failwith (Printf.sprintf
|
||||
"Sx_vm_extensions: opcode %d (%s) outside extension range %d-%d"
|
||||
id opname extension_min extension_max);
|
||||
if Hashtbl.mem by_id id then
|
||||
failwith (Printf.sprintf
|
||||
"Sx_vm_extensions: opcode %d (%s) already registered" id opname);
|
||||
if Hashtbl.mem by_name opname then
|
||||
failwith (Printf.sprintf
|
||||
"Sx_vm_extensions: opcode name %S already registered" opname)
|
||||
) ops;
|
||||
Hashtbl.add states M.name st;
|
||||
List.iter (fun (id, opname, h) ->
|
||||
Hashtbl.add by_id id h;
|
||||
Hashtbl.add by_name opname id
|
||||
) ops;
|
||||
extensions := M.name :: !extensions
|
||||
|
||||
(** Look up the opcode_id for an opcode_name. Returns [None] if no
|
||||
extension provides that opcode. *)
|
||||
let id_of_name name = Hashtbl.find_opt by_name name
|
||||
|
||||
(** Look up the state of an extension by name. Returns [None] if the
|
||||
extension is not registered. *)
|
||||
let state_of_extension name = Hashtbl.find_opt states name
|
||||
|
||||
(** Names of all registered extensions, newest first. *)
|
||||
let registered_extensions () = !extensions
|
||||
|
||||
(** Test-only: clear the registry. Used by unit tests to isolate
|
||||
extensions between test cases. The dispatch_ref is left in place. *)
|
||||
let _reset_for_tests () =
|
||||
Hashtbl.clear by_id;
|
||||
Hashtbl.clear by_name;
|
||||
Hashtbl.clear states;
|
||||
extensions := []
|
||||
|
||||
(** Install our [dispatch] into [Sx_vm.extension_dispatch_ref], replacing
|
||||
the Phase A stub. Idempotent. Called automatically at module init. *)
|
||||
let install_dispatch () =
|
||||
Sx_vm.extension_dispatch_ref := dispatch
|
||||
|
||||
let () = install_dispatch ()
|
||||
Reference in New Issue
Block a user