208 lines
6.4 KiB
Plaintext
208 lines
6.4 KiB
Plaintext
;; 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))))
|
|
|
|
(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 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-mk-atom "ok")))
|
|
|
|
(er-vm-register-erlang-opcodes!)
|