;; Erlang VM — stub opcode dispatcher (Phase 9).
;;
;; Mimics the OCaml-side EXTENSION shape from
;; plans/sx-vm-opcode-extension.md so opcodes 9b-9g can be designed
;; and tested in SX before 9a (`hosts/ocaml/`) lands the real
;; registration plumbing. When 9a is available, these stubs become
;; the cross-host SX-side mirror of the C/OCaml handlers and the
;; bytecode compiler emits them directly.
;;
;; Opcode IDs follow the plan's tier partition:
;;   0-127     reserved for SX core
;;   128-199   guest extensions (e.g. erlang, lua)
;;   200-247   port-/platform-specific
;;
;; Erlang owns 128-159 for now.

(define er-vm-opcodes (list {}))

(define er-vm-opcodes-get (fn () (nth er-vm-opcodes 0)))

(define
  er-vm-opcodes-reset!
  (fn () (set-nth! er-vm-opcodes 0 {})))

(define
  er-vm-register-opcode!
  (fn
    (id name handler)
    (dict-set! (er-vm-opcodes-get) (str id) {:name name :id id :handler handler})
    (er-mk-atom "ok")))

(define
  er-vm-lookup-opcode-by-id
  (fn
    (id)
    (let
      ((reg (er-vm-opcodes-get)) (k (str id)))
      (if (dict-has? reg k) (get reg k) nil))))

(define
  er-vm-lookup-opcode-by-name
  (fn
    (name)
    (let
      ((reg (er-vm-opcodes-get))
        (ks (keys (er-vm-opcodes-get)))
        (found (list nil)))
      (for-each
        (fn
          (i)
          (let
            ((entry (get reg (nth ks i))))
            (when
              (= (get entry :name) name)
              (set-nth! found 0 entry))))
        (range 0 (len ks)))
      (nth found 0))))

(define er-vm-list-opcodes (fn () (keys (er-vm-opcodes-get))))

;; ── Phase 9i — host opcode-id resolution ────────────────────────
;; When the OCaml `erlang_ext` extension is registered (Phase 9h), the
;; runtime exposes `extension-opcode-id` which maps an "erlang.OP_*"
;; name to the host-assigned id (222-239). We consult it so the SX
;; side and the OCaml side agree on ids; when it returns nil (name not
;; registered) we fall back to the stub-local id.
;;
;; NOTE: this requires a binary with the VM extension mechanism (the
;; vm-ext phase-A..E cherry-pick + Sx_vm_extensions force-link). The
;; loop builds and runs against exactly that binary
;; (hosts/ocaml/_build/default/bin/sx_server.exe). `extension-opcode-id`
;; resolves lazily at call time, so merely loading this file is safe;
;; only invoking the resolver on a binary that lacks the primitive
;; would raise.

(define er-vm-host-opcode-id
  (fn (ext-name)
    (extension-opcode-id ext-name)))

(define er-vm-effective-opcode-id
  (fn (ext-name stub-id)
    (let ((host (extension-opcode-id ext-name)))
      (cond
        (= host nil) stub-id
        :else host))))

(define
  er-vm-dispatch
  (fn
    (id operands)
    (let
      ((entry (er-vm-lookup-opcode-by-id id)))
      (if
        (= entry nil)
        (error (str "Erlang VM: unknown opcode id " id))
        ((get entry :handler) operands)))))

(define
  er-vm-dispatch-by-name
  (fn
    (name operands)
    (let
      ((entry (er-vm-lookup-opcode-by-name name)))
      (if
        (= entry nil)
        (error (str "Erlang VM: unknown opcode name '" name "'"))
        ((get entry :handler) operands)))))

;; ── Phase 9c — effect opcodes (perform / handle) ────────────────
;; Stub algebraic-effects-style operators. OP_PERFORM raises a tagged
;; exception; OP_HANDLE wraps a thunk in `guard` and catches matching
;; effects, passing the args to the handler. The real specialization
;; (constant-time effect dispatch, single-shot vs multi-shot continuations)
;; lands when 9a integrates.

(define er-vm-effect-marker?
  (fn (c effect-name)
    (and (= (type-of c) "dict")
         (= (get c :tag) "vm-effect")
         (= (get c :effect) effect-name))))

(define er-vm-op-perform
  (fn (operands)
    (raise {:tag "vm-effect" :effect (nth operands 0) :args (nth operands 1)})))

(define er-vm-op-handle
  (fn (operands)
    (let ((thunk (nth operands 0))
          (effect-name (nth operands 1))
          (handler (nth operands 2))
          (result (list nil))
          (caught (list false))
          (rethrow (list nil)))
      (guard
        (c
          (:else
            (cond
              (er-vm-effect-marker? c effect-name)
                (do (set-nth! caught 0 true)
                    (set-nth! result 0 (handler (get c :args))))
              :else (set-nth! rethrow 0 c))))
        (set-nth! result 0 (thunk)))
      (cond
        (not (= (nth rethrow 0) nil)) (raise (nth rethrow 0))
        :else (nth result 0)))))

;; ── Phase 9d — receive scan opcode ────────────────────────────
;; Selective receive primitive. Scans a mailbox value-list in arrival
;; order; for each value, tries each clause's pattern (binding into
;; env on success); on match returns `{:matched true :index N :body B}`
;; — the caller decides what to do with the index (queue-delete) and
;; the body (eval in the now-mutated env). On miss returns
;; `{:matched false}`, the caller arranges suspension (via OP_PERFORM).
;;
;; Operands: (clauses mbox-list env)
;;   clauses    — list of {:pattern :guards :body} dicts
;;   mbox-list  — SX list of message values
;;   env        — env dict (mutated on match)

(define er-vm-receive-try-clauses
  (fn (clauses msg env i)
    (cond
      (>= i (len clauses)) {:matched false}
      :else
        (let ((c (nth clauses i)) (snap (er-env-copy env)))
          (cond
            (and
              (er-match! (get c :pattern) msg env)
              (er-eval-guards (get c :guards) env))
              {:matched true :body (get c :body)}
            :else
              (do (er-env-restore! env snap)
                  (er-vm-receive-try-clauses clauses msg env (+ i 1))))))))

(define er-vm-receive-scan-loop
  (fn (clauses mbox env i)
    (cond
      (>= i (len mbox)) {:matched false}
      :else
        (let ((msg (nth mbox i))
              (cr (er-vm-receive-try-clauses clauses msg env 0)))
          (cond
            (get cr :matched) {:matched true :index i :body (get cr :body)}
            :else (er-vm-receive-scan-loop clauses mbox env (+ i 1)))))))

(define er-vm-op-receive-scan
  (fn (operands)
    (er-vm-receive-scan-loop (nth operands 0) (nth operands 1) (nth operands 2) 0)))

;; ── Phase 9e — spawn / send + lightweight scheduler ─────────────
;; Stub register-machine process layout for the eventual fast scheduler.
;; A VM-process is `{:id :registers :mailbox :state :initial-fn :initial-args}`.
;; Registers is a vector (SX list, mutated via set-nth!) — fixed slot count
;; per process so cells don't grow during execution. Mailbox is an SX list.
;; State is one of "runnable" / "waiting" / "dead". This sits PARALLEL to
;; the existing `er-scheduler` (which is the language-level scheduler) —
;; the VM scheduler will eventually take over once 9a integrates and
;; bytecode-compiled Erlang runs against it.

(define er-vm-procs (list {}))
(define er-vm-procs-get (fn () (nth er-vm-procs 0)))
(define er-vm-procs-reset!
  (fn () (do (set-nth! er-vm-procs 0 {}) (set-nth! er-vm-next-pid 0 0))))

(define er-vm-next-pid (list 0))

(define er-vm-proc-new!
  (fn (initial-fn initial-args)
    (let ((pid (nth er-vm-next-pid 0)))
      (set-nth! er-vm-next-pid 0 (+ pid 1))
      (let ((proc
              {:id pid
               :registers (list nil nil nil nil nil nil nil nil)
               :mailbox (list)
               :state "runnable"
               :initial-fn initial-fn
               :initial-args initial-args}))
        (dict-set! (er-vm-procs-get) (str pid) proc)
        pid))))

(define er-vm-proc-get (fn (pid) (get (er-vm-procs-get) (str pid))))

(define er-vm-proc-send!
  (fn (pid msg)
    (let ((proc (er-vm-proc-get pid)))
      (cond
        (= proc nil) false
        :else
          (do
            (dict-set! proc :mailbox (append (get proc :mailbox) (list msg)))
            (when (= (get proc :state) "waiting")
              (dict-set! proc :state "runnable"))
            true)))))

(define er-vm-proc-mailbox (fn (pid) (get (er-vm-proc-get pid) :mailbox)))
(define er-vm-proc-state (fn (pid) (get (er-vm-proc-get pid) :state)))
(define er-vm-proc-count (fn () (len (keys (er-vm-procs-get)))))

(define er-vm-op-spawn
  (fn (operands)
    (er-vm-proc-new! (nth operands 0) (nth operands 1))))

(define er-vm-op-send
  (fn (operands)
    (er-vm-proc-send! (nth operands 0) (nth operands 1))))

;; ── Phase 9f — hot-BIF dispatch table ──────────────────────────
;; Specialized opcodes for the BIFs that the bytecode compiler emits
;; on hot call sites. The handler is the underlying `er-bif-*` impl
;; directly — same `(vs)` signature as the dispatcher uses for
;; operands, so the cost is the opcode-id → handler hop with no
;; registry-key string lookup. Cold BIFs continue going through the
;; general path (`er-apply-bif` / `er-lookup-bif`).
;;
;; Opcodes 136-159 reserved for hot BIFs.

;; ── Phase 9b — pattern-match opcodes ────────────────────────────
;; Each handler takes a list (pattern-ast value env) and returns
;; true/false, mutating env on success (same contract as the
;; existing er-match-tuple / er-match-cons / er-match-binary).
;; Wire these as wrappers for now; the real opcodes will eventually
;; have register-machine semantics and skip the AST-walk overhead.

(define
  er-vm-register-erlang-opcodes!
  (fn
    ()
    (er-vm-register-opcode!
      128
      "OP_PATTERN_TUPLE"
      (fn
        (operands)
        (er-match-tuple
          (nth operands 0)
          (nth operands 1)
          (nth operands 2))))
    (er-vm-register-opcode!
      129
      "OP_PATTERN_LIST"
      (fn
        (operands)
        (er-match-cons
          (nth operands 0)
          (nth operands 1)
          (nth operands 2))))
    (er-vm-register-opcode!
      130
      "OP_PATTERN_BINARY"
      (fn
        (operands)
        (er-match-binary
          (nth operands 0)
          (nth operands 1)
          (nth operands 2))))
    (er-vm-register-opcode! 131 "OP_PERFORM" er-vm-op-perform)
    (er-vm-register-opcode! 132 "OP_HANDLE" er-vm-op-handle)
    (er-vm-register-opcode! 133 "OP_RECEIVE_SCAN" er-vm-op-receive-scan)
    (er-vm-register-opcode! 134 "OP_SPAWN" er-vm-op-spawn)
    (er-vm-register-opcode! 135 "OP_SEND" er-vm-op-send)
    ;; Phase 9f — hot BIFs
    (er-vm-register-opcode! 136 "OP_BIF_LENGTH"        er-bif-length)
    (er-vm-register-opcode! 137 "OP_BIF_HD"            er-bif-hd)
    (er-vm-register-opcode! 138 "OP_BIF_TL"            er-bif-tl)
    (er-vm-register-opcode! 139 "OP_BIF_ELEMENT"       er-bif-element)
    (er-vm-register-opcode! 140 "OP_BIF_TUPLE_SIZE"    er-bif-tuple-size)
    (er-vm-register-opcode! 141 "OP_BIF_LISTS_REVERSE" er-bif-lists-reverse)
    (er-vm-register-opcode! 142 "OP_BIF_IS_INTEGER"    er-bif-is-integer)
    (er-vm-register-opcode! 143 "OP_BIF_IS_ATOM"       er-bif-is-atom)
    (er-vm-register-opcode! 144 "OP_BIF_IS_LIST"       er-bif-is-list)
    (er-vm-register-opcode! 145 "OP_BIF_IS_TUPLE"      er-bif-is-tuple)
    (er-mk-atom "ok")))

(er-vm-register-erlang-opcodes!)
