279 lines
11 KiB
OCaml
279 lines
11 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
|
|
(* Phase 10b — simple hot-BIF handlers. Erlang bool is the atom
|
|
{"tag"->"atom"; "name"->"true"|"false"}; mk_atom builds it. *)
|
|
let mk_atom nm =
|
|
let h = Hashtbl.create 2 in
|
|
Hashtbl.replace h "tag" (String "atom");
|
|
Hashtbl.replace h "name" (String nm);
|
|
Dict h
|
|
in
|
|
let er_bool b = mk_atom (if b then "true" else "false") in
|
|
let is_tag v t = match v with
|
|
| Dict d -> er_tag d = t
|
|
| _ -> false
|
|
in
|
|
let op_bif_hd =
|
|
(231, "erlang.OP_BIF_HD",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
match Sx_vm.pop vm with
|
|
| Dict d when er_tag d = "cons" ->
|
|
(match Hashtbl.find_opt d "head" with
|
|
| Some h -> Sx_vm.push vm h
|
|
| None -> raise (Eval_error "erlang.OP_BIF_HD: cons without :head"))
|
|
| _ -> raise (Eval_error "erlang.OP_BIF_HD: not a cons")))
|
|
in
|
|
let op_bif_tl =
|
|
(232, "erlang.OP_BIF_TL",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
match Sx_vm.pop vm with
|
|
| Dict d when er_tag d = "cons" ->
|
|
(match Hashtbl.find_opt d "tail" with
|
|
| Some t -> Sx_vm.push vm t
|
|
| None -> raise (Eval_error "erlang.OP_BIF_TL: cons without :tail"))
|
|
| _ -> raise (Eval_error "erlang.OP_BIF_TL: not a cons")))
|
|
in
|
|
let op_bif_tuple_size =
|
|
(234, "erlang.OP_BIF_TUPLE_SIZE",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
match Sx_vm.pop vm with
|
|
| Dict d when er_tag d = "tuple" ->
|
|
let n = match Hashtbl.find_opt d "elements" with
|
|
| Some (List es) -> List.length es
|
|
| Some (ListRef r) -> List.length !r
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_TUPLE_SIZE: tuple without :elements")
|
|
in
|
|
Sx_vm.push vm (Integer n)
|
|
| _ -> raise (Eval_error "erlang.OP_BIF_TUPLE_SIZE: not a tuple")))
|
|
in
|
|
let op_bif_is_integer =
|
|
(236, "erlang.OP_BIF_IS_INTEGER",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
Sx_vm.push vm (er_bool (match v with Integer _ -> true | _ -> false))))
|
|
in
|
|
let op_bif_is_atom =
|
|
(237, "erlang.OP_BIF_IS_ATOM",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
Sx_vm.push vm (er_bool (is_tag v "atom"))))
|
|
in
|
|
let op_bif_is_list =
|
|
(238, "erlang.OP_BIF_IS_LIST",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
Sx_vm.push vm (er_bool (is_tag v "cons" || is_tag v "nil"))))
|
|
in
|
|
let op_bif_is_tuple =
|
|
(239, "erlang.OP_BIF_IS_TUPLE",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
Sx_vm.push vm (er_bool (is_tag v "tuple"))))
|
|
in
|
|
(* element/2 and lists:reverse/1 — pure stack transforms (no
|
|
bytecode operands). Calling convention: args pushed left→right,
|
|
so element/2 stack is [.. Index Tuple] (Tuple on top). Erlang
|
|
element/2 is 1-indexed. *)
|
|
let op_bif_element =
|
|
(233, "erlang.OP_BIF_ELEMENT",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let tup = Sx_vm.pop vm in
|
|
let idx = Sx_vm.pop vm in
|
|
match tup, idx with
|
|
| Dict d, Integer i when er_tag d = "tuple" ->
|
|
let es = match Hashtbl.find_opt d "elements" with
|
|
| Some (List es) -> es
|
|
| Some (ListRef r) -> !r
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_ELEMENT: tuple without :elements")
|
|
in
|
|
let n = List.length es in
|
|
if i < 1 || i > n then
|
|
raise (Eval_error
|
|
(Printf.sprintf
|
|
"erlang.OP_BIF_ELEMENT: index %d out of range 1..%d" i n))
|
|
else
|
|
Sx_vm.push vm (List.nth es (i - 1))
|
|
| _, Integer _ ->
|
|
raise (Eval_error "erlang.OP_BIF_ELEMENT: 2nd arg not a tuple")
|
|
| _ ->
|
|
raise (Eval_error "erlang.OP_BIF_ELEMENT: 1st arg not an integer")))
|
|
in
|
|
let op_bif_lists_reverse =
|
|
(235, "erlang.OP_BIF_LISTS_REVERSE",
|
|
(fun (vm : Sx_vm.vm) _f ->
|
|
bump ();
|
|
let v = Sx_vm.pop vm in
|
|
let mk_nil () =
|
|
let h = Hashtbl.create 1 in
|
|
Hashtbl.replace h "tag" (String "nil"); Dict h in
|
|
let mk_cons hd tl =
|
|
let h = Hashtbl.create 3 in
|
|
Hashtbl.replace h "tag" (String "cons");
|
|
Hashtbl.replace h "head" hd;
|
|
Hashtbl.replace h "tail" tl;
|
|
Dict h in
|
|
let rec rev acc node =
|
|
match node with
|
|
| Dict d ->
|
|
(match er_tag d with
|
|
| "nil" -> acc
|
|
| "cons" ->
|
|
let hd = match Hashtbl.find_opt d "head" with
|
|
| Some x -> x
|
|
| None -> raise (Eval_error
|
|
"erlang.OP_BIF_LISTS_REVERSE: cons without :head") in
|
|
let tl = match Hashtbl.find_opt d "tail" with
|
|
| Some x -> x
|
|
| None -> raise (Eval_error
|
|
"erlang.OP_BIF_LISTS_REVERSE: cons without :tail") in
|
|
rev (mk_cons hd acc) tl
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_LISTS_REVERSE: not a proper list"))
|
|
| _ -> raise (Eval_error
|
|
"erlang.OP_BIF_LISTS_REVERSE: not a proper list")
|
|
in
|
|
Sx_vm.push vm (rev (mk_nil ()) 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_bif_hd;
|
|
op_bif_tl;
|
|
op_bif_element;
|
|
op_bif_tuple_size;
|
|
op_bif_lists_reverse;
|
|
op_bif_is_integer;
|
|
op_bif_is_atom;
|
|
op_bif_is_list;
|
|
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
|