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:
@@ -67,6 +67,14 @@ let rec deep_equal a b =
|
|||||||
| NativeFn _, NativeFn _ -> a == b
|
| NativeFn _, NativeFn _ -> a == b
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
|
(* ====================================================================== *)
|
||||||
|
(* Test extensions for the VM extension registry suite (Phase B) *)
|
||||||
|
(* ====================================================================== *)
|
||||||
|
|
||||||
|
(* Extend the extensible variant from sx_vm_extension.ml so the test
|
||||||
|
extensions below can carry their own private state. *)
|
||||||
|
type Sx_vm_extension.extension_state += TestRegState of int ref
|
||||||
|
|
||||||
(* ====================================================================== *)
|
(* ====================================================================== *)
|
||||||
(* Build evaluator environment with test platform functions *)
|
(* Build evaluator environment with test platform functions *)
|
||||||
(* ====================================================================== *)
|
(* ====================================================================== *)
|
||||||
@@ -1323,7 +1331,145 @@ let run_foundation_tests () =
|
|||||||
Printf.printf " PASS: opcode 199 stays in core (catch-all)\n"
|
Printf.printf " PASS: opcode 199 stays in core (catch-all)\n"
|
||||||
| exn ->
|
| exn ->
|
||||||
incr fail_count;
|
incr fail_count;
|
||||||
Printf.printf " FAIL: opcode 199 — unexpected: %s\n" (Printexc.to_string exn))
|
Printf.printf " FAIL: opcode 199 — unexpected: %s\n" (Printexc.to_string exn));
|
||||||
|
|
||||||
|
Printf.printf "\nSuite: vm-extension-registry\n";
|
||||||
|
(* Sx_vm_extensions self-installs its dispatcher at module init. Reset
|
||||||
|
the registry so prior loaded extensions don't interfere with this
|
||||||
|
test. *)
|
||||||
|
Sx_vm_extensions._reset_for_tests ();
|
||||||
|
let module TestExt : Sx_vm_extension.EXTENSION = struct
|
||||||
|
let name = "test_reg"
|
||||||
|
let init () = TestRegState (ref 0)
|
||||||
|
let opcodes _st = [
|
||||||
|
(210, "test_reg.OP_PUSH_42", (fun vm _frame ->
|
||||||
|
Sx_vm.push vm (Sx_types.Integer 42)));
|
||||||
|
(211, "test_reg.OP_DOUBLE_TOS", (fun vm _frame ->
|
||||||
|
let v = Sx_vm.pop vm in
|
||||||
|
match v with
|
||||||
|
| Sx_types.Integer n -> Sx_vm.push vm (Sx_types.Integer (n * 2))
|
||||||
|
| _ -> failwith "OP_DOUBLE_TOS: not an integer"));
|
||||||
|
]
|
||||||
|
end in
|
||||||
|
Sx_vm_extensions.register (module TestExt);
|
||||||
|
|
||||||
|
(match Sx_vm_extensions.id_of_name "test_reg.OP_PUSH_42" with
|
||||||
|
| Some 210 ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: id_of_name resolves opcode\n"
|
||||||
|
| other ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: id_of_name: got %s\n"
|
||||||
|
(match other with Some n -> string_of_int n | None -> "None"));
|
||||||
|
|
||||||
|
(match Sx_vm_extensions.id_of_name "nonexistent.OP" with
|
||||||
|
| None ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: id_of_name returns None for unknown\n"
|
||||||
|
| Some _ ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: id_of_name should return None for unknown\n");
|
||||||
|
|
||||||
|
(match Sx_vm_extensions.state_of_extension "test_reg" with
|
||||||
|
| Some (TestRegState _) ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: state_of_extension returns extension state\n"
|
||||||
|
| _ ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: state_of_extension lookup\n");
|
||||||
|
|
||||||
|
(match Sx_vm_extensions.state_of_extension "nonexistent" with
|
||||||
|
| None ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: state_of_extension None for unknown\n"
|
||||||
|
| Some _ ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: state_of_extension should be None\n");
|
||||||
|
|
||||||
|
(* End-to-end dispatch through the VM. Bytecode runs OP_PUSH_42 then
|
||||||
|
OP_RETURN (50); execute_module pops the result. *)
|
||||||
|
let make_bc_seq bytes = ({
|
||||||
|
vc_arity = 0; vc_rest_arity = -1; vc_locals = 0;
|
||||||
|
vc_bytecode = bytes; vc_constants = [||];
|
||||||
|
vc_bytecode_list = None; vc_constants_list = None;
|
||||||
|
} : Sx_types.vm_code) in
|
||||||
|
(let globals = Hashtbl.create 1 in
|
||||||
|
try
|
||||||
|
match Sx_vm.execute_module (make_bc_seq [| 210; 50 |]) globals with
|
||||||
|
| Integer 42 ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: dispatch routes opcode 210 -> push 42\n"
|
||||||
|
| other ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: dispatch opcode 210: got %s\n"
|
||||||
|
(Sx_types.inspect other)
|
||||||
|
with exn ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: dispatch opcode 210 raised: %s\n"
|
||||||
|
(Printexc.to_string exn));
|
||||||
|
|
||||||
|
(* Compose two extension opcodes: PUSH_42 then DOUBLE_TOS then RETURN.
|
||||||
|
Verifies that successive extension dispatches share VM state. *)
|
||||||
|
(let globals = Hashtbl.create 1 in
|
||||||
|
try
|
||||||
|
match Sx_vm.execute_module (make_bc_seq [| 210; 211; 50 |]) globals with
|
||||||
|
| Integer 84 ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: extension opcodes compose (42 -> 84)\n"
|
||||||
|
| other ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: composed opcodes: got %s\n"
|
||||||
|
(Sx_types.inspect other)
|
||||||
|
with exn ->
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: composed opcodes raised: %s\n"
|
||||||
|
(Printexc.to_string exn));
|
||||||
|
|
||||||
|
(* Duplicate opcode-id detection. *)
|
||||||
|
let module DupExt : Sx_vm_extension.EXTENSION = struct
|
||||||
|
let name = "dup_check"
|
||||||
|
let init () = TestRegState (ref 0)
|
||||||
|
let opcodes _st = [
|
||||||
|
(210, "dup_check.OP_X", (fun _vm _frame -> ()));
|
||||||
|
]
|
||||||
|
end in
|
||||||
|
(try
|
||||||
|
Sx_vm_extensions.register (module DupExt);
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: duplicate opcode id should have raised\n"
|
||||||
|
with Failure _ ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: duplicate opcode id rejected\n");
|
||||||
|
|
||||||
|
(* Out-of-range opcode-id detection. *)
|
||||||
|
let module OutExt : Sx_vm_extension.EXTENSION = struct
|
||||||
|
let name = "out_of_range"
|
||||||
|
let init () = TestRegState (ref 0)
|
||||||
|
let opcodes _st = [
|
||||||
|
(300, "out_of_range.OP_X", (fun _vm _frame -> ()));
|
||||||
|
]
|
||||||
|
end in
|
||||||
|
(try
|
||||||
|
Sx_vm_extensions.register (module OutExt);
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: out-of-range opcode should have raised\n"
|
||||||
|
with Failure _ ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: out-of-range opcode rejected\n");
|
||||||
|
|
||||||
|
(* Duplicate extension-name detection. *)
|
||||||
|
let module SameNameExt : Sx_vm_extension.EXTENSION = struct
|
||||||
|
let name = "test_reg" (* same as TestExt above *)
|
||||||
|
let init () = TestRegState (ref 0)
|
||||||
|
let opcodes _st = []
|
||||||
|
end in
|
||||||
|
(try
|
||||||
|
Sx_vm_extensions.register (module SameNameExt);
|
||||||
|
incr fail_count;
|
||||||
|
Printf.printf " FAIL: duplicate extension name should have raised\n"
|
||||||
|
with Failure _ ->
|
||||||
|
incr pass_count;
|
||||||
|
Printf.printf " PASS: duplicate extension name rejected\n")
|
||||||
|
|
||||||
|
|
||||||
(* ====================================================================== *)
|
(* ====================================================================== *)
|
||||||
|
|||||||
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 ()
|
||||||
@@ -258,10 +258,10 @@ Five sub-phases in dependency order. Each is testable in isolation.
|
|||||||
opcodes yet. Phase B's module init installs the real `dispatch` into
|
opcodes yet. Phase B's module init installs the real `dispatch` into
|
||||||
`Sx_vm.extension_dispatch_ref`, replacing Phase A's stub.
|
`Sx_vm.extension_dispatch_ref`, replacing Phase A's stub.
|
||||||
|
|
||||||
- [ ] `Sx_vm_extension` interface module (handler type, EXTENSION sig).
|
- [x] `Sx_vm_extension` interface module (handler type, EXTENSION sig).
|
||||||
- [ ] `Sx_vm_extensions` registry module (`register`, `dispatch`,
|
- [x] `Sx_vm_extensions` registry module (`register`, `dispatch`,
|
||||||
`id_of_name`, `state_of_extension`).
|
`id_of_name`, `state_of_extension`).
|
||||||
- [ ] Wire the registry's `dispatch` into `Sx_vm.extension_dispatch_ref` at
|
- [x] Wire the registry's `dispatch` into `Sx_vm.extension_dispatch_ref` at
|
||||||
module init.
|
module init.
|
||||||
|
|
||||||
**Tests:**
|
**Tests:**
|
||||||
@@ -457,6 +457,24 @@ familiarity.
|
|||||||
|
|
||||||
Newest first.
|
Newest first.
|
||||||
|
|
||||||
|
- **2026-05-14** — Phase B done. Added `hosts/ocaml/lib/sx_vm_extension.ml`
|
||||||
|
(interface: `handler` type, `extension_state` extensible variant,
|
||||||
|
`EXTENSION` module type) and `sx_vm_extensions.ml` (registry: `register`,
|
||||||
|
`dispatch`, `id_of_name`, `state_of_extension`, `_reset_for_tests`).
|
||||||
|
`let () = install_dispatch ()` at module init replaces Phase A's stub
|
||||||
|
with the real registry dispatch — Phase A behavior preserved (empty
|
||||||
|
registry still raises `Invalid_opcode` for unregistered ops). Registry
|
||||||
|
rejects opcode IDs outside 200-247, duplicate IDs, duplicate names, and
|
||||||
|
duplicate extension names. 9 new foundation tests (`vm-extension-registry`
|
||||||
|
suite): id_of_name resolve+miss, state_of_extension resolve+miss,
|
||||||
|
end-to-end VM dispatch (push 42), opcode composition (push 42 → double
|
||||||
|
→ 84), duplicate-id / out-of-range / duplicate-name rejection. +9 pass
|
||||||
|
vs Phase A baseline (4816 vs 4807), 1111 pre-existing failures unchanged.
|
||||||
|
Conformance suites green: erlang 530/530, haskell 285/285, datalog
|
||||||
|
276/276, prolog 590/590, smalltalk 847/847, common-lisp 487/487, apl
|
||||||
|
562/562, js 148/148, forth 632/638 (pre-existing), tcl 3/4 (pre-existing),
|
||||||
|
ocaml-on-sx unit 607/607.
|
||||||
|
|
||||||
- **2026-05-14** — Phase A done. Added `Invalid_opcode of int` exception,
|
- **2026-05-14** — Phase A done. Added `Invalid_opcode of int` exception,
|
||||||
`extension_dispatch_ref` (default raises `Invalid_opcode op`), and the
|
`extension_dispatch_ref` (default raises `Invalid_opcode op`), and the
|
||||||
`| op when op >= 200 -> !extension_dispatch_ref op vm frame` arm before the
|
`| op when op >= 200 -> !extension_dispatch_ref op vm frame` arm before the
|
||||||
|
|||||||
Reference in New Issue
Block a user