(** {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