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:
2026-05-14 23:28:24 +00:00
parent cf597f1b5f
commit 8c33a6f8d5
4 changed files with 305 additions and 4 deletions

View 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 ()