404 lines
14 KiB
Plaintext
404 lines
14 KiB
Plaintext
;; Phase 9 — stub VM opcode dispatcher tests.
|
|
;; Verifies the dispatcher shape (mirrors plans/sx-vm-opcode-extension.md
|
|
;; for when 9a integrates) and the three pattern-match opcodes (9b)
|
|
;; route to the correct er-match-* impl.
|
|
|
|
(define er-vm-test-count 0)
|
|
(define er-vm-test-pass 0)
|
|
(define er-vm-test-fails (list))
|
|
|
|
(define
|
|
er-vm-test
|
|
(fn
|
|
(name actual expected)
|
|
(set! er-vm-test-count (+ er-vm-test-count 1))
|
|
(if
|
|
(= actual expected)
|
|
(set! er-vm-test-pass (+ er-vm-test-pass 1))
|
|
(append! er-vm-test-fails {:name name :expected expected :actual actual}))))
|
|
|
|
;; ── dispatcher core ─────────────────────────────────────────────
|
|
(er-vm-test
|
|
"tuple opcode registered"
|
|
(= (er-vm-lookup-opcode-by-id 128) nil)
|
|
false)
|
|
|
|
(er-vm-test
|
|
"tuple opcode name"
|
|
(get (er-vm-lookup-opcode-by-id 128) :name)
|
|
"OP_PATTERN_TUPLE")
|
|
|
|
(er-vm-test
|
|
"list opcode by name"
|
|
(get (er-vm-lookup-opcode-by-name "OP_PATTERN_LIST") :id)
|
|
129)
|
|
|
|
(er-vm-test
|
|
"binary opcode by name"
|
|
(get (er-vm-lookup-opcode-by-name "OP_PATTERN_BINARY") :id)
|
|
130)
|
|
|
|
(er-vm-test "lookup miss by id" (er-vm-lookup-opcode-by-id 999) nil)
|
|
|
|
(er-vm-test "lookup miss by name" (er-vm-lookup-opcode-by-name "OP_NOPE") nil)
|
|
|
|
(er-vm-test
|
|
"opcode list has 3+"
|
|
(>= (len (er-vm-list-opcodes)) 3)
|
|
true)
|
|
|
|
;; ── OP_PATTERN_TUPLE ────────────────────────────────────────────
|
|
;; Pattern: {ok, X} matches value {ok, 42} → X bound to 42
|
|
(define er-vm-t1-env (er-env-new))
|
|
(define er-vm-t1-pat {:type "tuple" :elements (list {:type "atom" :value "ok"} {:name "X" :type "var"})})
|
|
(define er-vm-t1-val (er-mk-tuple (list (er-mk-atom "ok") 42)))
|
|
(er-vm-test
|
|
"OP_PATTERN_TUPLE match"
|
|
(er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t1-val er-vm-t1-env))
|
|
true)
|
|
(er-vm-test "OP_PATTERN_TUPLE binds var" (get er-vm-t1-env "X") 42)
|
|
|
|
;; Same pattern against {error, ...} → false
|
|
(define er-vm-t2-env (er-env-new))
|
|
(define er-vm-t2-val (er-mk-tuple (list (er-mk-atom "error") 7)))
|
|
(er-vm-test
|
|
"OP_PATTERN_TUPLE no-match"
|
|
(er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t2-val er-vm-t2-env))
|
|
false)
|
|
|
|
;; Wrong arity tuple — pattern has 2 elements, value has 3
|
|
(define er-vm-t3-env (er-env-new))
|
|
(define
|
|
er-vm-t3-val
|
|
(er-mk-tuple (list (er-mk-atom "ok") 1 2)))
|
|
(er-vm-test
|
|
"OP_PATTERN_TUPLE arity mismatch"
|
|
(er-vm-dispatch 128 (list er-vm-t1-pat er-vm-t3-val er-vm-t3-env))
|
|
false)
|
|
|
|
;; ── OP_PATTERN_LIST (cons) ──────────────────────────────────────
|
|
;; Pattern: [H | T] matches [1, 2, 3] → H=1, T=[2,3]
|
|
(define er-vm-l1-env (er-env-new))
|
|
(define er-vm-l1-pat {:type "cons" :tail {:name "T" :type "var"} :head {:name "H" :type "var"}})
|
|
(define
|
|
er-vm-l1-val
|
|
(er-mk-cons
|
|
1
|
|
(er-mk-cons 2 (er-mk-cons 3 (er-mk-nil)))))
|
|
(er-vm-test
|
|
"OP_PATTERN_LIST match"
|
|
(er-vm-dispatch 129 (list er-vm-l1-pat er-vm-l1-val er-vm-l1-env))
|
|
true)
|
|
(er-vm-test "OP_PATTERN_LIST binds head" (get er-vm-l1-env "H") 1)
|
|
(er-vm-test
|
|
"OP_PATTERN_LIST tail is cons"
|
|
(er-cons? (get er-vm-l1-env "T"))
|
|
true)
|
|
|
|
;; [H|T] against empty list → false
|
|
(define er-vm-l2-env (er-env-new))
|
|
(er-vm-test
|
|
"OP_PATTERN_LIST no-match on nil"
|
|
(er-vm-dispatch 129 (list er-vm-l1-pat (er-mk-nil) er-vm-l2-env))
|
|
false)
|
|
|
|
;; ── OP_PATTERN_BINARY ───────────────────────────────────────────
|
|
;; Pattern <<A:8>> against <<42>> → A bound to 42
|
|
(define er-vm-b1-env (er-env-new))
|
|
(define er-vm-b1-pat {:type "binary" :segments (list {:value {:name "A" :type "var"} :size {:type "integer" :value "8"} :spec "integer"})})
|
|
(define er-vm-b1-val (er-mk-binary (list 42)))
|
|
(er-vm-test
|
|
"OP_PATTERN_BINARY match"
|
|
(er-vm-dispatch 130 (list er-vm-b1-pat er-vm-b1-val er-vm-b1-env))
|
|
true)
|
|
(er-vm-test
|
|
"OP_PATTERN_BINARY binds segment"
|
|
(get er-vm-b1-env "A")
|
|
42)
|
|
|
|
;; Same pattern against wrong-size binary (2 bytes) → false
|
|
(define er-vm-b2-env (er-env-new))
|
|
(define er-vm-b2-val (er-mk-binary (list 42 99)))
|
|
(er-vm-test
|
|
"OP_PATTERN_BINARY size mismatch"
|
|
(er-vm-dispatch 130 (list er-vm-b1-pat er-vm-b2-val er-vm-b2-env))
|
|
false)
|
|
|
|
;; ── dispatch error path ────────────────────────────────────────
|
|
(define er-vm-err-caught (list nil))
|
|
(guard
|
|
(c (:else (set-nth! er-vm-err-caught 0 (str c))))
|
|
(er-vm-dispatch 999 (list)))
|
|
(er-vm-test
|
|
"unknown opcode raises"
|
|
(string-contains? (str (nth er-vm-err-caught 0)) "unknown opcode")
|
|
true)
|
|
|
|
|
|
;; ── Phase 9c — OP_PERFORM / OP_HANDLE ───────────────────────────
|
|
(er-vm-test "perform opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 131) :name) "OP_PERFORM")
|
|
(er-vm-test "handle opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 132) :name) "OP_HANDLE")
|
|
|
|
(define er-vm-pf-caught (list nil))
|
|
(guard (c (:else (set-nth! er-vm-pf-caught 0 c)))
|
|
(er-vm-dispatch 131 (list "yield" (list 42))))
|
|
(er-vm-test "perform raises tagged"
|
|
(get (nth er-vm-pf-caught 0) :tag) "vm-effect")
|
|
(er-vm-test "perform effect name"
|
|
(get (nth er-vm-pf-caught 0) :effect) "yield")
|
|
(er-vm-test "perform args carried"
|
|
(nth (get (nth er-vm-pf-caught 0) :args) 0) 42)
|
|
|
|
(er-vm-test "handle catches matching effect"
|
|
(er-vm-dispatch 132
|
|
(list
|
|
(fn () (er-vm-dispatch 131 (list "yield" (list 7))))
|
|
"yield"
|
|
(fn (args) (+ (nth args 0) 100))))
|
|
107)
|
|
|
|
(er-vm-test "handle no-effect returns thunk result"
|
|
(er-vm-dispatch 132
|
|
(list
|
|
(fn () 99)
|
|
"yield"
|
|
(fn (args) "handler ran")))
|
|
99)
|
|
|
|
(define er-vm-rt-caught (list nil))
|
|
(guard (c (:else (set-nth! er-vm-rt-caught 0 c)))
|
|
(er-vm-dispatch 132
|
|
(list
|
|
(fn () (er-vm-dispatch 131 (list "other" (list))))
|
|
"yield"
|
|
(fn (args) "wrong"))))
|
|
(er-vm-test "handle rethrows non-matching"
|
|
(get (nth er-vm-rt-caught 0) :effect) "other")
|
|
|
|
(er-vm-test "nested handles separate effect names"
|
|
(er-vm-dispatch 132
|
|
(list
|
|
(fn ()
|
|
(er-vm-dispatch 132
|
|
(list
|
|
(fn () (er-vm-dispatch 131 (list "b" (list 5))))
|
|
"a"
|
|
(fn (args) "inner-handled"))))
|
|
"b"
|
|
(fn (args) (+ (nth args 0) 1000))))
|
|
1005)
|
|
|
|
|
|
;; ── Phase 9d — OP_RECEIVE_SCAN ──────────────────────────────────
|
|
(er-vm-test "receive-scan opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 133) :name) "OP_RECEIVE_SCAN")
|
|
|
|
;; Pattern: receive {ok, X} -> X end against mailbox [{error, 1}, {ok, 42}, foo]
|
|
(define er-vm-r1-env (er-env-new))
|
|
(define er-vm-r1-clauses
|
|
(list
|
|
{:pattern {:type "tuple"
|
|
:elements (list
|
|
{:type "atom" :value "ok"}
|
|
{:type "var" :name "X"})}
|
|
:guards (list)
|
|
:body (list {:type "var" :name "X"})}))
|
|
(define er-vm-r1-mbox
|
|
(list
|
|
(er-mk-tuple (list (er-mk-atom "error") 1))
|
|
(er-mk-tuple (list (er-mk-atom "ok") 42))
|
|
(er-mk-atom "foo")))
|
|
|
|
(define er-vm-r1-result
|
|
(er-vm-dispatch 133 (list er-vm-r1-clauses er-vm-r1-mbox er-vm-r1-env)))
|
|
(er-vm-test "scan finds match"
|
|
(get er-vm-r1-result :matched) true)
|
|
(er-vm-test "scan reports correct index"
|
|
(get er-vm-r1-result :index) 1)
|
|
(er-vm-test "scan binds var"
|
|
(get er-vm-r1-env "X") 42)
|
|
(er-vm-test "scan leaves body unevaluated"
|
|
(= (get er-vm-r1-result :body) nil) false)
|
|
|
|
;; No match case
|
|
(define er-vm-r2-env (er-env-new))
|
|
(define er-vm-r2-mbox (list (er-mk-atom "nope") 99))
|
|
(define er-vm-r2-result
|
|
(er-vm-dispatch 133 (list er-vm-r1-clauses er-vm-r2-mbox er-vm-r2-env)))
|
|
(er-vm-test "scan no-match"
|
|
(get er-vm-r2-result :matched) false)
|
|
(er-vm-test "scan no-match leaves env clean"
|
|
(dict-has? er-vm-r2-env "X") false)
|
|
|
|
;; Empty mailbox
|
|
(define er-vm-r3-result
|
|
(er-vm-dispatch 133 (list er-vm-r1-clauses (list) (er-env-new))))
|
|
(er-vm-test "scan empty mailbox"
|
|
(get er-vm-r3-result :matched) false)
|
|
|
|
;; First-match wins (arrival order)
|
|
(define er-vm-r4-env (er-env-new))
|
|
(define er-vm-r4-mbox
|
|
(list
|
|
(er-mk-tuple (list (er-mk-atom "ok") 1))
|
|
(er-mk-tuple (list (er-mk-atom "ok") 2))))
|
|
(define er-vm-r4-result
|
|
(er-vm-dispatch 133 (list er-vm-r1-clauses er-vm-r4-mbox er-vm-r4-env)))
|
|
(er-vm-test "scan first-match wins (index 0)"
|
|
(get er-vm-r4-result :index) 0)
|
|
(er-vm-test "scan binds first match's var"
|
|
(get er-vm-r4-env "X") 1)
|
|
|
|
|
|
;; ── Phase 9e — OP_SPAWN / OP_SEND ───────────────────────────────
|
|
(er-vm-procs-reset!)
|
|
|
|
(er-vm-test "spawn opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 134) :name) "OP_SPAWN")
|
|
(er-vm-test "send opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 135) :name) "OP_SEND")
|
|
|
|
(define er-vm-fn (fn () "body"))
|
|
(define er-vm-p1 (er-vm-dispatch 134 (list er-vm-fn (list))))
|
|
(define er-vm-p2 (er-vm-dispatch 134 (list er-vm-fn (list "arg"))))
|
|
(er-vm-test "spawn returns pid 0 first"
|
|
er-vm-p1 0)
|
|
(er-vm-test "spawn returns pid 1 second"
|
|
er-vm-p2 1)
|
|
(er-vm-test "proc count is 2"
|
|
(er-vm-proc-count) 2)
|
|
(er-vm-test "spawned proc state runnable"
|
|
(er-vm-proc-state er-vm-p1) "runnable")
|
|
(er-vm-test "spawned proc mailbox empty"
|
|
(len (er-vm-proc-mailbox er-vm-p1)) 0)
|
|
(er-vm-test "spawned proc has 8 registers"
|
|
(len (get (er-vm-proc-get er-vm-p1) :registers)) 8)
|
|
|
|
;; OP_SEND appends to target's mailbox, preserves arrival order.
|
|
(er-vm-test "send returns true on valid pid"
|
|
(er-vm-dispatch 135 (list er-vm-p1 "msg1")) true)
|
|
(er-vm-dispatch 135 (list er-vm-p1 "msg2")
|
|
)
|
|
(er-vm-dispatch 135 (list er-vm-p1 "msg3"))
|
|
(er-vm-test "mailbox length after 3 sends"
|
|
(len (er-vm-proc-mailbox er-vm-p1)) 3)
|
|
(er-vm-test "mailbox preserves order — first"
|
|
(nth (er-vm-proc-mailbox er-vm-p1) 0) "msg1")
|
|
(er-vm-test "mailbox preserves order — last"
|
|
(nth (er-vm-proc-mailbox er-vm-p1) 2) "msg3")
|
|
|
|
;; send to nonexistent pid returns false (doesn't crash)
|
|
(er-vm-test "send to unknown pid is false"
|
|
(er-vm-dispatch 135 (list 99999 "x")) false)
|
|
|
|
;; Isolation: msgs to p1 don't appear in p2's mailbox
|
|
(er-vm-test "isolation — p2 mailbox empty"
|
|
(len (er-vm-proc-mailbox er-vm-p2)) 0)
|
|
|
|
;; reset clears
|
|
(er-vm-procs-reset!)
|
|
(er-vm-test "reset clears procs"
|
|
(er-vm-proc-count) 0)
|
|
(er-vm-test "reset resets pid counter"
|
|
(er-vm-dispatch 134 (list er-vm-fn (list))) 0)
|
|
|
|
|
|
;; ── Phase 9f — hot-BIF dispatch table ───────────────────────────
|
|
;; Each opcode skips the registry lookup and calls the underlying
|
|
;; er-bif-* directly. Verify each returns the same result as going
|
|
;; through er-apply-bif.
|
|
|
|
(er-vm-test "BIF_LENGTH opcode by id"
|
|
(get (er-vm-lookup-opcode-by-id 136) :name) "OP_BIF_LENGTH")
|
|
(er-vm-test "BIF_LENGTH on 3-cons"
|
|
(er-vm-dispatch 136
|
|
(list (er-mk-cons 1 (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil))))))
|
|
3)
|
|
|
|
(er-vm-test "BIF_HD on cons"
|
|
(er-vm-dispatch 137 (list (er-mk-cons 99 (er-mk-nil)))) 99)
|
|
|
|
(er-vm-test "BIF_TL is cons"
|
|
(er-cons? (er-vm-dispatch 138
|
|
(list (er-mk-cons 1 (er-mk-cons 2 (er-mk-nil)))))) true)
|
|
|
|
(er-vm-test "BIF_ELEMENT pulls index"
|
|
(er-vm-dispatch 139 (list 2 (er-mk-tuple (list "a" "b" "c")))) "b")
|
|
|
|
(er-vm-test "BIF_TUPLE_SIZE on 4-tuple"
|
|
(er-vm-dispatch 140 (list (er-mk-tuple (list 1 2 3 4)))) 4)
|
|
|
|
(er-vm-test "BIF_LISTS_REVERSE preserves elements"
|
|
(er-list-length (er-vm-dispatch 141
|
|
(list (er-mk-cons 1 (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil))))))) 3)
|
|
|
|
(er-vm-test "BIF_LISTS_REVERSE actually reverses"
|
|
(get (er-vm-dispatch 141
|
|
(list (er-mk-cons 1 (er-mk-cons 2 (er-mk-cons 3 (er-mk-nil)))))) :head) 3)
|
|
|
|
(er-vm-test "BIF_IS_INTEGER true on int"
|
|
(get (er-vm-dispatch 142 (list 42)) :name) "true")
|
|
(er-vm-test "BIF_IS_INTEGER false on float"
|
|
(get (er-vm-dispatch 142 (list 3.14)) :name) "false")
|
|
|
|
(er-vm-test "BIF_IS_ATOM true"
|
|
(get (er-vm-dispatch 143 (list (er-mk-atom "ok"))) :name) "true")
|
|
(er-vm-test "BIF_IS_ATOM false on int"
|
|
(get (er-vm-dispatch 143 (list 7)) :name) "false")
|
|
|
|
(er-vm-test "BIF_IS_LIST true on cons"
|
|
(get (er-vm-dispatch 144
|
|
(list (er-mk-cons 1 (er-mk-nil)))) :name) "true")
|
|
(er-vm-test "BIF_IS_LIST true on nil"
|
|
(get (er-vm-dispatch 144 (list (er-mk-nil))) :name) "true")
|
|
(er-vm-test "BIF_IS_LIST false on tuple"
|
|
(get (er-vm-dispatch 144 (list (er-mk-tuple (list)))) :name) "false")
|
|
|
|
(er-vm-test "BIF_IS_TUPLE true"
|
|
(get (er-vm-dispatch 145 (list (er-mk-tuple (list 1)))) :name) "true")
|
|
(er-vm-test "BIF_IS_TUPLE false on int"
|
|
(get (er-vm-dispatch 145 (list 5)) :name) "false")
|
|
|
|
;; Sanity: total opcode count grew (3 patterns + perform + handle +
|
|
;; receive-scan + spawn + send + 10 hot-BIFs = 16+ registered).
|
|
(er-vm-test "opcode list has 16+"
|
|
(>= (len (er-vm-list-opcodes)) 16) true)
|
|
|
|
|
|
;; ── Phase 9i — host opcode-id resolution ────────────────────────
|
|
;; Requires a binary with the erlang_ext extension registered (9h).
|
|
;; The loop runs conformance against exactly that binary.
|
|
(er-vm-test "host id: OP_PATTERN_TUPLE = 222"
|
|
(er-vm-host-opcode-id "erlang.OP_PATTERN_TUPLE") 222)
|
|
(er-vm-test "host id: OP_BIF_IS_TUPLE = 239"
|
|
(er-vm-host-opcode-id "erlang.OP_BIF_IS_TUPLE") 239)
|
|
(er-vm-test "host id: unknown name -> nil"
|
|
(er-vm-host-opcode-id "erlang.OP_NOPE") nil)
|
|
(er-vm-test "effective id prefers host when present"
|
|
(er-vm-effective-opcode-id "erlang.OP_BIF_LENGTH" 136) 230)
|
|
(er-vm-test "effective id falls back to stub on nil"
|
|
(er-vm-effective-opcode-id "erlang.OP_NOPE" 999) 999)
|
|
;; The full erlang.OP_* namespace resolves to the contiguous 222-239 block.
|
|
(er-vm-test "host ids contiguous 222..239"
|
|
(let ((names (list "erlang.OP_PATTERN_TUPLE" "erlang.OP_PATTERN_LIST"
|
|
"erlang.OP_PATTERN_BINARY" "erlang.OP_PERFORM"
|
|
"erlang.OP_HANDLE" "erlang.OP_RECEIVE_SCAN"
|
|
"erlang.OP_SPAWN" "erlang.OP_SEND"
|
|
"erlang.OP_BIF_LENGTH" "erlang.OP_BIF_HD"
|
|
"erlang.OP_BIF_TL" "erlang.OP_BIF_ELEMENT"
|
|
"erlang.OP_BIF_TUPLE_SIZE" "erlang.OP_BIF_LISTS_REVERSE"
|
|
"erlang.OP_BIF_IS_INTEGER" "erlang.OP_BIF_IS_ATOM"
|
|
"erlang.OP_BIF_IS_LIST" "erlang.OP_BIF_IS_TUPLE"))
|
|
(ok (list true)))
|
|
(for-each
|
|
(fn (i)
|
|
(when (not (= (er-vm-host-opcode-id (nth names i)) (+ 222 i)))
|
|
(set-nth! ok 0 false)))
|
|
(range 0 (len names)))
|
|
(nth ok 0))
|
|
true)
|
|
|
|
(define er-vm-test-summary (str "vm " er-vm-test-pass "/" er-vm-test-count))
|