135 lines
5.4 KiB
OCaml
135 lines
5.4 KiB
OCaml
(** {1 [erlang_ext] — Erlang-on-SX VM opcode extension (Phase 9h)}
|
|
|
|
Registers the Erlang opcode namespace in [Sx_vm_extensions] so that
|
|
[extension-opcode-id "erlang.OP_*"] resolves to a stable id. The SX
|
|
stub dispatcher in [lib/erlang/vm/dispatcher.sx] consults these ids
|
|
(Phase 9i) and falls back to its own local ids when the host
|
|
extension is absent.
|
|
|
|
Opcode ids occupy 222-239 in the extension partition (200-247).
|
|
222+ is chosen to clear the test extensions' reserved ids
|
|
(test_reg 210/211, test_ext 220/221) so all three coexist in
|
|
run_tests; production sx_server only registers this one. Names
|
|
mirror the SX stub dispatcher exactly:
|
|
|
|
- 222 erlang.OP_PATTERN_TUPLE - 231 erlang.OP_BIF_HD
|
|
- 223 erlang.OP_PATTERN_LIST - 232 erlang.OP_BIF_TL
|
|
- 224 erlang.OP_PATTERN_BINARY - 233 erlang.OP_BIF_ELEMENT
|
|
- 225 erlang.OP_PERFORM - 234 erlang.OP_BIF_TUPLE_SIZE
|
|
- 226 erlang.OP_HANDLE - 235 erlang.OP_BIF_LISTS_REVERSE
|
|
- 227 erlang.OP_RECEIVE_SCAN - 236 erlang.OP_BIF_IS_INTEGER
|
|
- 228 erlang.OP_SPAWN - 237 erlang.OP_BIF_IS_ATOM
|
|
- 229 erlang.OP_SEND - 238 erlang.OP_BIF_IS_LIST
|
|
- 230 erlang.OP_BIF_LENGTH - 239 erlang.OP_BIF_IS_TUPLE
|
|
|
|
{2 Handler status}
|
|
|
|
The bytecode compiler does not yet emit these opcodes — Erlang
|
|
programs run through the general CEK path and the working
|
|
specialization path is the SX stub dispatcher. So every handler
|
|
here raises a descriptive [Eval_error] rather than silently
|
|
corrupting the VM stack. This keeps the extension honest: the
|
|
namespace is registered and disassembles by name, [extension-opcode-id]
|
|
works, but actually dispatching an opcode (which only happens once a
|
|
future phase teaches the compiler to emit them) fails loudly with a
|
|
pointer to the phase that will wire it. Real stack-machine handlers
|
|
land alongside compiler emission in a later phase. *)
|
|
|
|
open Sx_types
|
|
|
|
(** Per-instance state: invocation counter, purely to exercise the
|
|
[extension_state] machinery (mirrors [test_ext]). *)
|
|
type Sx_vm_extension.extension_state += ErlangExtState of {
|
|
mutable dispatched : int;
|
|
}
|
|
|
|
let not_wired name =
|
|
raise (Eval_error
|
|
(Printf.sprintf
|
|
"%s: bytecode emission not yet wired (Phase 9j) — \
|
|
Erlang runs via CEK; specialization path is the SX stub \
|
|
dispatcher in lib/erlang/vm/dispatcher.sx"
|
|
name))
|
|
|
|
module M : Sx_vm_extension.EXTENSION = struct
|
|
let name = "erlang"
|
|
let init () = ErlangExtState { dispatched = 0 }
|
|
|
|
let opcodes st =
|
|
let bump () = match st with
|
|
| ErlangExtState s -> s.dispatched <- s.dispatched + 1
|
|
| _ -> ()
|
|
in
|
|
let op id nm =
|
|
(id, nm, (fun (_vm : Sx_vm.vm) (_frame : Sx_vm.frame) ->
|
|
bump (); not_wired nm))
|
|
in
|
|
(* Phase 10b vertical slice: one REAL register-machine handler.
|
|
erlang.OP_BIF_LENGTH (230) — pops an Erlang list off the VM
|
|
stack and pushes its length. Proves the full path works:
|
|
extension-opcode-id -> bytecode -> Sx_vm dispatch fallthrough
|
|
-> this handler -> correct stack result. The remaining 17
|
|
opcodes still raise not_wired until their handlers + compiler
|
|
emission land. Erlang lists are tagged dicts:
|
|
nil = {"tag" -> String "nil"}
|
|
cons = {"tag" -> String "cons"; "head" -> v; "tail" -> v} *)
|
|
let er_tag d =
|
|
match Hashtbl.find_opt d "tag" with
|
|
| Some (String s) -> s | _ -> ""
|
|
in
|
|
let op_bif_length =
|
|
(230, "erlang.OP_BIF_LENGTH",
|
|
(fun (vm : Sx_vm.vm) (_frame : Sx_vm.frame) ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
let rec walk acc node =
|
|
match node with
|
|
| Dict d ->
|
|
(match er_tag d with
|
|
| "nil" -> acc
|
|
| "cons" ->
|
|
(match Hashtbl.find_opt d "tail" with
|
|
| Some t -> walk (acc + 1) t
|
|
| None -> raise (Eval_error
|
|
"erlang.OP_BIF_LENGTH: cons cell without :tail"))
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_LENGTH: not a proper list"))
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_LENGTH: not a proper list")
|
|
in
|
|
Sx_vm.push vm (Integer (walk 0 v))))
|
|
in
|
|
[
|
|
op 222 "erlang.OP_PATTERN_TUPLE";
|
|
op 223 "erlang.OP_PATTERN_LIST";
|
|
op 224 "erlang.OP_PATTERN_BINARY";
|
|
op 225 "erlang.OP_PERFORM";
|
|
op 226 "erlang.OP_HANDLE";
|
|
op 227 "erlang.OP_RECEIVE_SCAN";
|
|
op 228 "erlang.OP_SPAWN";
|
|
op 229 "erlang.OP_SEND";
|
|
op_bif_length;
|
|
op 231 "erlang.OP_BIF_HD";
|
|
op 232 "erlang.OP_BIF_TL";
|
|
op 233 "erlang.OP_BIF_ELEMENT";
|
|
op 234 "erlang.OP_BIF_TUPLE_SIZE";
|
|
op 235 "erlang.OP_BIF_LISTS_REVERSE";
|
|
op 236 "erlang.OP_BIF_IS_INTEGER";
|
|
op 237 "erlang.OP_BIF_IS_ATOM";
|
|
op 238 "erlang.OP_BIF_IS_LIST";
|
|
op 239 "erlang.OP_BIF_IS_TUPLE";
|
|
]
|
|
end
|
|
|
|
(** Register [erlang] in [Sx_vm_extensions]. Idempotent only by failing
|
|
loudly — calling twice raises [Failure]. sx_server calls this once
|
|
at startup. *)
|
|
let register () = Sx_vm_extensions.register (module M : Sx_vm_extension.EXTENSION)
|
|
|
|
(** Read the dispatch counter from the live registry state. [None] if
|
|
[register] hasn't run. *)
|
|
let dispatch_count () =
|
|
match Sx_vm_extensions.state_of_extension "erlang" with
|
|
| Some (ErlangExtState s) -> Some s.dispatched
|
|
| _ -> None
|