From 4e0a92ec00f135fa274d4fd55c908301dbec2104 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 14 May 2026 23:28:24 +0000 Subject: [PATCH] =?UTF-8?q?vm-ext:=20phase=20B=20=E2=80=94=20extension=20r?= =?UTF-8?q?egistry=20module?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- hosts/ocaml/bin/run_tests.ml | 148 +++++++++++++++++++++++++++- hosts/ocaml/lib/sx_vm_extension.ml | 48 +++++++++ hosts/ocaml/lib/sx_vm_extensions.ml | 89 +++++++++++++++++ 3 files changed, 284 insertions(+), 1 deletion(-) create mode 100644 hosts/ocaml/lib/sx_vm_extension.ml create mode 100644 hosts/ocaml/lib/sx_vm_extensions.ml diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index f1427b7e..b08eadd5 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -67,6 +67,14 @@ let rec deep_equal a b = | NativeFn _, NativeFn _ -> a == b | _ -> 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 *) (* ====================================================================== *) @@ -1323,7 +1331,145 @@ let run_foundation_tests () = Printf.printf " PASS: opcode 199 stays in core (catch-all)\n" | exn -> 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") (* ====================================================================== *) diff --git a/hosts/ocaml/lib/sx_vm_extension.ml b/hosts/ocaml/lib/sx_vm_extension.ml new file mode 100644 index 00000000..2be73e85 --- /dev/null +++ b/hosts/ocaml/lib/sx_vm_extension.ml @@ -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 diff --git a/hosts/ocaml/lib/sx_vm_extensions.ml b/hosts/ocaml/lib/sx_vm_extensions.ml new file mode 100644 index 00000000..8e1dd288 --- /dev/null +++ b/hosts/ocaml/lib/sx_vm_extensions.ml @@ -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 ()