VM spec in SX + 72 tests passing on both JS and OCaml
spec/vm.sx — bytecode VM written in SX (the spec):
- Stack-based interpreter for bytecode from compiler.sx
- 24 opcodes: constants, variables (local/upvalue/global), control flow,
function calls (with TCO), closures with upvalue capture, collections,
string concat, define
- Upvalue cells for shared mutable closure variables
- Call dispatch: vm-closure (fast path), native-fn, CEK fallback
- Platform interface: 7 primitives (vm-stack-*, call-primitive, cek-call,
get-primitive, env-parent)
spec/tests/test-vm.sx — 72 tests exercising compile→bytecode→VM pipeline:
constants, arithmetic, comparison, control flow (if/when/cond/case/and/or),
let bindings, lambda, closures, upvalue mutation, TCO (10K iterations),
collections, strings, define, letrec, quasiquote, threading, integration
(fibonacci, recursive map/filter/reduce, compose)
spec/compiler.sx — fix :else keyword detection in case/cond compilation
(was comparing Keyword object to evaluated string, now checks type)
Platform primitives added (JS + OCaml):
make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-length, vm-stack-copy!,
primitive?, get-primitive, call-primitive, set-nth! (JS)
Test runners updated to load bytecode.sx + compiler.sx + vm.sx for --full.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -558,7 +558,8 @@
|
||||
(let ((test (first args))
|
||||
(body (nth args 1))
|
||||
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
|
||||
(if (or (= test :else) (= test true))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
;; else clause — just compile the body
|
||||
(compile-expr em body scope tail?)
|
||||
(do
|
||||
@@ -590,7 +591,8 @@
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1))
|
||||
(rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list))))
|
||||
(if (or (= test :else) (= test true))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
(do (emit-op em 5) ;; POP match-val
|
||||
(compile-expr em body scope tail?))
|
||||
(do
|
||||
|
||||
418
spec/tests/test-vm.sx
Normal file
418
spec/tests/test-vm.sx
Normal file
@@ -0,0 +1,418 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx)
|
||||
;;
|
||||
;; Requires: test-framework.sx, compiler.sx, vm.sx loaded.
|
||||
;; Tests the compile → bytecode → VM execution pipeline.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Helper: compile an SX expression and execute it on the VM.
|
||||
;; Returns the result value.
|
||||
(define vm-eval
|
||||
(fn (expr)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module
|
||||
(code-from-value code)
|
||||
{}))))
|
||||
|
||||
;; Helper: compile and run with a pre-populated globals dict.
|
||||
(define vm-eval-with
|
||||
(fn (expr globals)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module (code-from-value code) globals))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constants and literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-constants"
|
||||
(deftest "number constant"
|
||||
(assert-equal 42 (vm-eval 42)))
|
||||
|
||||
(deftest "string constant"
|
||||
(assert-equal "hello" (vm-eval "hello")))
|
||||
|
||||
(deftest "boolean true"
|
||||
(assert-equal true (vm-eval true)))
|
||||
|
||||
(deftest "boolean false"
|
||||
(assert-equal false (vm-eval false)))
|
||||
|
||||
(deftest "nil constant"
|
||||
(assert-nil (vm-eval nil)))
|
||||
|
||||
(deftest "negative number"
|
||||
(assert-equal -7 (vm-eval -7)))
|
||||
|
||||
(deftest "float constant"
|
||||
(assert-equal 3.14 (vm-eval 3.14))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic via primitives
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-arithmetic"
|
||||
(deftest "addition"
|
||||
(assert-equal 5 (vm-eval '(+ 2 3))))
|
||||
|
||||
(deftest "subtraction"
|
||||
(assert-equal 7 (vm-eval '(- 10 3))))
|
||||
|
||||
(deftest "multiplication"
|
||||
(assert-equal 24 (vm-eval '(* 6 4))))
|
||||
|
||||
(deftest "division"
|
||||
(assert-equal 5 (vm-eval '(/ 10 2))))
|
||||
|
||||
(deftest "nested arithmetic"
|
||||
(assert-equal 14 (vm-eval '(+ (* 3 4) 2))))
|
||||
|
||||
(deftest "three-arg addition"
|
||||
(assert-equal 15 (vm-eval '(+ 5 4 6)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison and logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-comparison"
|
||||
(deftest "equal numbers"
|
||||
(assert-equal true (vm-eval '(= 1 1))))
|
||||
|
||||
(deftest "unequal numbers"
|
||||
(assert-equal false (vm-eval '(= 1 2))))
|
||||
|
||||
(deftest "less than"
|
||||
(assert-equal true (vm-eval '(< 1 2))))
|
||||
|
||||
(deftest "greater than"
|
||||
(assert-equal true (vm-eval '(> 5 3))))
|
||||
|
||||
(deftest "not"
|
||||
(assert-equal true (vm-eval '(not false))))
|
||||
|
||||
(deftest "not truthy"
|
||||
(assert-equal false (vm-eval '(not 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow — if, when, cond, and, or
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-control-flow"
|
||||
(deftest "if true branch"
|
||||
(assert-equal 1 (vm-eval '(if true 1 2))))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal 2 (vm-eval '(if false 1 2))))
|
||||
|
||||
(deftest "if without else returns nil"
|
||||
(assert-nil (vm-eval '(if false 1))))
|
||||
|
||||
(deftest "when true evaluates body"
|
||||
(assert-equal 42 (vm-eval '(when true 42))))
|
||||
|
||||
(deftest "when false returns nil"
|
||||
(assert-nil (vm-eval '(when false 42))))
|
||||
|
||||
(deftest "and short-circuits on false"
|
||||
(assert-equal false (vm-eval '(and true false 42))))
|
||||
|
||||
(deftest "and returns last truthy"
|
||||
(assert-equal 3 (vm-eval '(and 1 2 3))))
|
||||
|
||||
(deftest "or short-circuits on true"
|
||||
(assert-equal 1 (vm-eval '(or 1 false 2))))
|
||||
|
||||
(deftest "or returns false when all falsy"
|
||||
(assert-equal false (vm-eval '(or false false false))))
|
||||
|
||||
(deftest "cond first match"
|
||||
(assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two"))))
|
||||
|
||||
(deftest "cond else clause"
|
||||
(assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none"))))
|
||||
|
||||
(deftest "case match"
|
||||
(assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other"))))
|
||||
|
||||
(deftest "case else"
|
||||
(assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Let bindings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-let"
|
||||
(deftest "single binding"
|
||||
(assert-equal 10 (vm-eval '(let ((x 10)) x))))
|
||||
|
||||
(deftest "multiple bindings"
|
||||
(assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y)))))
|
||||
|
||||
(deftest "bindings are sequential"
|
||||
(assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y))))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y))))))
|
||||
|
||||
(deftest "inner let shadows outer"
|
||||
(assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x)))))
|
||||
|
||||
(deftest "let body returns last expression"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lambda and function calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-lambda"
|
||||
(deftest "lambda call"
|
||||
(assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5)))))
|
||||
|
||||
(deftest "lambda with multiple params"
|
||||
(assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6)))))
|
||||
|
||||
(deftest "higher-order: pass lambda to lambda"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((apply-fn (fn (f x) (f x)))
|
||||
(double (fn (n) (* n 2))))
|
||||
(apply-fn double 5)))))
|
||||
|
||||
(deftest "lambda returns lambda"
|
||||
(assert-equal 15
|
||||
(vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x)))))
|
||||
(let ((add10 (make-adder 10)))
|
||||
(add10 5))))))
|
||||
|
||||
(deftest "immediately invoked lambda"
|
||||
(assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures and upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-closures"
|
||||
(deftest "closure captures local"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((f (fn () x)))
|
||||
(f))))))
|
||||
|
||||
(deftest "closure captures through two levels"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((y 20))
|
||||
(let ((f (fn () (+ x y))))
|
||||
(f)))))))
|
||||
|
||||
(deftest "two closures share upvalue"
|
||||
(assert-equal 42
|
||||
(vm-eval '(let ((x 0))
|
||||
(let ((set-x (fn (v) (set! x v)))
|
||||
(get-x (fn () x)))
|
||||
(set-x 42)
|
||||
(get-x))))))
|
||||
|
||||
(deftest "closure mutation visible to sibling"
|
||||
(assert-equal 3
|
||||
(vm-eval '(let ((counter 0))
|
||||
(let ((inc! (fn () (set! counter (+ counter 1)))))
|
||||
(inc!)
|
||||
(inc!)
|
||||
(inc!)
|
||||
counter))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tail call optimization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-tco"
|
||||
(deftest "tail-recursive loop doesn't overflow"
|
||||
;; Count down from 10000 — would overflow without TCO
|
||||
(assert-equal 0
|
||||
(vm-eval '(let ((loop (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(loop (- n 1))))))
|
||||
(loop 10000)))))
|
||||
|
||||
(deftest "tail-recursive accumulator"
|
||||
(assert-equal 5050
|
||||
(vm-eval '(let ((sum (fn (n acc)
|
||||
(if (<= n 0) acc
|
||||
(sum (- n 1) (+ acc n))))))
|
||||
(sum 100 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collections
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-collections"
|
||||
(deftest "list construction"
|
||||
(assert-equal (list 1 2 3) (vm-eval '(list 1 2 3))))
|
||||
|
||||
(deftest "empty list"
|
||||
(assert-equal (list) (vm-eval '(list))))
|
||||
|
||||
(deftest "dict construction"
|
||||
(let ((d (vm-eval '{:a 1 :b 2})))
|
||||
(assert-equal 1 (get d "a"))
|
||||
(assert-equal 2 (get d "b"))))
|
||||
|
||||
(deftest "list operations"
|
||||
(assert-equal 1 (vm-eval '(first (list 1 2 3))))
|
||||
(assert-equal 3 (vm-eval '(len (list 1 2 3)))))
|
||||
|
||||
(deftest "nested list"
|
||||
(assert-equal (list 1 (list 2 3))
|
||||
(vm-eval '(list 1 (list 2 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-strings"
|
||||
(deftest "str concat"
|
||||
(assert-equal "hello world" (vm-eval '(str "hello" " " "world"))))
|
||||
|
||||
(deftest "string-length"
|
||||
(assert-equal 5 (vm-eval '(string-length "hello"))))
|
||||
|
||||
(deftest "str coerces numbers"
|
||||
(assert-equal "42" (vm-eval '(str 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Define — top-level and local
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-define"
|
||||
(deftest "top-level define"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do (define x 42) x))))
|
||||
|
||||
(deftest "define function then call"
|
||||
(assert-equal 10
|
||||
(vm-eval '(do
|
||||
(define double (fn (n) (* n 2)))
|
||||
(double 5)))))
|
||||
|
||||
(deftest "local define inside fn"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((f (fn (x)
|
||||
(define y (* x 2))
|
||||
(+ x y))))
|
||||
(f 10)))))
|
||||
|
||||
(deftest "define with forward reference"
|
||||
(assert-equal 120
|
||||
(vm-eval '(do
|
||||
(define fact (fn (n)
|
||||
(if (<= n 1) 1 (* n (fact (- n 1))))))
|
||||
(fact 5))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Letrec — mutual recursion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-letrec"
|
||||
(deftest "letrec self-recursion"
|
||||
(assert-equal 55
|
||||
(vm-eval '(letrec ((sum-to (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(+ n (sum-to (- n 1)))))))
|
||||
(sum-to 10)))))
|
||||
|
||||
(deftest "letrec mutual recursion"
|
||||
(assert-equal true
|
||||
(vm-eval '(letrec ((my-even? (fn (n)
|
||||
(if (= n 0) true (my-odd? (- n 1)))))
|
||||
(my-odd? (fn (n)
|
||||
(if (= n 0) false (my-even? (- n 1))))))
|
||||
(my-even? 10))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quasiquote
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-quasiquote"
|
||||
(deftest "simple quasiquote"
|
||||
(assert-equal (list 1 2 3)
|
||||
(vm-eval '(let ((x 2)) `(1 ,x 3)))))
|
||||
|
||||
(deftest "quasiquote with splice"
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Thread macro
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-threading"
|
||||
(deftest "thread-first"
|
||||
(assert-equal 7
|
||||
(vm-eval '(-> 5 (+ 2)))))
|
||||
|
||||
(deftest "thread-first chain"
|
||||
(assert-equal 12
|
||||
(vm-eval '(-> 10 (+ 5) (- 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Integration: compile then execute
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-integration"
|
||||
(deftest "fibonacci"
|
||||
(assert-equal 55
|
||||
(vm-eval '(do
|
||||
(define fib (fn (n)
|
||||
(if (<= n 1) n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
(fib 10)))))
|
||||
|
||||
(deftest "map via recursive define"
|
||||
(assert-equal (list 2 4 6)
|
||||
(vm-eval '(do
|
||||
(define my-map (fn (f lst)
|
||||
(if (empty? lst) (list)
|
||||
(cons (f (first lst)) (my-map f (rest lst))))))
|
||||
(my-map (fn (x) (* x 2)) (list 1 2 3))))))
|
||||
|
||||
(deftest "filter via recursive define"
|
||||
(assert-equal (list 2 4)
|
||||
(vm-eval '(do
|
||||
(define my-filter (fn (pred lst)
|
||||
(if (empty? lst) (list)
|
||||
(if (pred (first lst))
|
||||
(cons (first lst) (my-filter pred (rest lst)))
|
||||
(my-filter pred (rest lst))))))
|
||||
(my-filter (fn (x) (even? x)) (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "reduce via recursive define"
|
||||
(assert-equal 15
|
||||
(vm-eval '(do
|
||||
(define my-reduce (fn (f acc lst)
|
||||
(if (empty? lst) acc
|
||||
(my-reduce f (f acc (first lst)) (rest lst)))))
|
||||
(my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "nested function calls"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do
|
||||
(define compose (fn (f g) (fn (x) (f (g x)))))
|
||||
(define inc (fn (x) (+ x 1)))
|
||||
(define double (fn (x) (* x 2)))
|
||||
(let ((inc-then-double (compose double inc)))
|
||||
(inc-then-double 20)))))))
|
||||
590
spec/vm.sx
Normal file
590
spec/vm.sx
Normal file
@@ -0,0 +1,590 @@
|
||||
;; ==========================================================================
|
||||
;; vm.sx — SX bytecode virtual machine
|
||||
;;
|
||||
;; Stack-based interpreter for bytecode produced by compiler.sx.
|
||||
;; Written in SX — transpiled to each target (OCaml, JS, WASM).
|
||||
;;
|
||||
;; Architecture:
|
||||
;; - Array-based value stack (no allocation per step)
|
||||
;; - Frame list for call stack (one frame per function invocation)
|
||||
;; - Upvalue cells for shared mutable closure variables
|
||||
;; - Iterative dispatch loop (no host-stack growth)
|
||||
;; - TCO via frame replacement on OP_TAIL_CALL
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; The host must provide:
|
||||
;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow
|
||||
;; - cek-call (fallback for Lambda/Component)
|
||||
;; - get-primitive (primitive lookup)
|
||||
;; Everything else is defined here.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Types — VM data structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Upvalue cell — shared mutable reference for captured variables.
|
||||
;; When a closure captures a local, both the parent frame and the
|
||||
;; closure read/write through this cell.
|
||||
(define make-upvalue-cell
|
||||
(fn (value)
|
||||
{:uv-value value}))
|
||||
|
||||
(define uv-get (fn (cell) (get cell "uv-value")))
|
||||
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
|
||||
|
||||
;; VM code object — compiled bytecode + constant pool.
|
||||
;; Produced by compiler.sx, consumed by the VM.
|
||||
(define make-vm-code
|
||||
(fn (arity locals bytecode constants)
|
||||
{:vc-arity arity
|
||||
:vc-locals locals
|
||||
:vc-bytecode bytecode
|
||||
:vc-constants constants}))
|
||||
|
||||
;; VM closure — code + captured upvalues + globals reference.
|
||||
(define make-vm-closure
|
||||
(fn (code upvalues name globals closure-env)
|
||||
{:vm-code code
|
||||
:vm-upvalues upvalues
|
||||
:vm-name name
|
||||
:vm-globals globals
|
||||
:vm-closure-env closure-env}))
|
||||
|
||||
;; VM frame — one per active function invocation.
|
||||
(define make-vm-frame
|
||||
(fn (closure base)
|
||||
{:closure closure
|
||||
:ip 0
|
||||
:base base
|
||||
:local-cells {}}))
|
||||
|
||||
;; VM state — the virtual machine.
|
||||
(define make-vm
|
||||
(fn (globals)
|
||||
{:stack (make-vm-stack 4096)
|
||||
:sp 0
|
||||
:frames (list)
|
||||
:globals globals}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Stack operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-push
|
||||
(fn (vm value)
|
||||
(let ((sp (get vm "sp"))
|
||||
(stack (get vm "stack")))
|
||||
;; Grow stack if needed
|
||||
(when (>= sp (vm-stack-length stack))
|
||||
(let ((new-stack (make-vm-stack (* sp 2))))
|
||||
(vm-stack-copy! stack new-stack sp)
|
||||
(dict-set! vm "stack" new-stack)
|
||||
(set! stack new-stack)))
|
||||
(vm-stack-set! stack sp value)
|
||||
(dict-set! vm "sp" (+ sp 1)))))
|
||||
|
||||
(define vm-pop
|
||||
(fn (vm)
|
||||
(let ((sp (- (get vm "sp") 1)))
|
||||
(dict-set! vm "sp" sp)
|
||||
(vm-stack-get (get vm "stack") sp))))
|
||||
|
||||
(define vm-peek
|
||||
(fn (vm)
|
||||
(vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Operand reading — read from bytecode stream
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-read-u8
|
||||
(fn (frame)
|
||||
(let ((ip (get frame "ip"))
|
||||
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
|
||||
(let ((v (nth bc ip)))
|
||||
(dict-set! frame "ip" (+ ip 1))
|
||||
v))))
|
||||
|
||||
(define frame-read-u16
|
||||
(fn (frame)
|
||||
(let ((lo (frame-read-u8 frame))
|
||||
(hi (frame-read-u8 frame)))
|
||||
(+ lo (* hi 256)))))
|
||||
|
||||
(define frame-read-i16
|
||||
(fn (frame)
|
||||
(let ((v (frame-read-u16 frame)))
|
||||
(if (>= v 32768) (- v 65536) v))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Frame management
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Push a closure frame onto the VM.
|
||||
;; Lays out args as locals, pads remaining locals with nil.
|
||||
(define vm-push-frame
|
||||
(fn (vm closure args)
|
||||
(let ((frame (make-vm-frame closure (get vm "sp"))))
|
||||
(for-each (fn (a) (vm-push vm a)) args)
|
||||
;; Pad remaining local slots with nil
|
||||
(let ((arity (len args))
|
||||
(total-locals (get (get closure "vm-code") "vc-locals")))
|
||||
(let ((pad-count (- total-locals arity)))
|
||||
(when (> pad-count 0)
|
||||
(let ((i 0))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i pad-count)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop)))))
|
||||
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Code loading — convert compiler output to VM structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define code-from-value
|
||||
(fn (v)
|
||||
"Convert a compiler output dict to a vm-code object."
|
||||
(if (not (dict? v))
|
||||
(make-vm-code 0 16 (list) (list))
|
||||
(let ((bc-raw (get v "bytecode"))
|
||||
(bc (if (nil? bc-raw) (list) bc-raw))
|
||||
(consts-raw (get v "constants"))
|
||||
(consts (if (nil? consts-raw) (list) consts-raw))
|
||||
(arity-raw (get v "arity"))
|
||||
(arity (if (nil? arity-raw) 0 arity-raw)))
|
||||
(make-vm-code arity (+ arity 16) bc consts)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Call dispatch — route calls by value type
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; vm-call dispatches a function call within the VM.
|
||||
;; VmClosure: push frame on current VM (fast path, enables TCO).
|
||||
;; NativeFn: call directly, push result.
|
||||
;; Lambda/Component: fall back to CEK evaluator.
|
||||
(define vm-closure?
|
||||
(fn (v)
|
||||
(and (dict? v) (has-key? v "vm-code"))))
|
||||
|
||||
(define vm-call
|
||||
(fn (vm f args)
|
||||
(cond
|
||||
(vm-closure? f)
|
||||
;; Fast path: push frame on current VM
|
||||
(vm-push-frame vm f args)
|
||||
|
||||
(callable? f)
|
||||
;; Native function or primitive
|
||||
(vm-push vm (apply f args))
|
||||
|
||||
(or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island"))
|
||||
;; CEK fallback — the host provides cek-call
|
||||
(vm-push vm (cek-call f args))
|
||||
|
||||
:else
|
||||
(error (str "VM: not callable: " (type-of f))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Local/upvalue access helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-local-get
|
||||
(fn (vm frame slot)
|
||||
"Read a local variable — check shared cells first, then stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-get (get cells key))
|
||||
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
|
||||
|
||||
(define frame-local-set
|
||||
(fn (vm frame slot value)
|
||||
"Write a local variable — to shared cell if captured, else to stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-set! (get cells key) value)
|
||||
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
|
||||
|
||||
(define frame-upvalue-get
|
||||
(fn (frame idx)
|
||||
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
|
||||
|
||||
(define frame-upvalue-set
|
||||
(fn (frame idx value)
|
||||
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Global variable access with closure env chain
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-global-get
|
||||
(fn (vm frame name)
|
||||
"Look up a global: globals table → closure env chain → primitives."
|
||||
(let ((globals (get vm "globals")))
|
||||
(if (has-key? globals name)
|
||||
(get globals name)
|
||||
;; Walk the closure env chain for inner functions
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env")))
|
||||
(if (nil? closure-env)
|
||||
(get-primitive name)
|
||||
(let ((found (env-walk closure-env name)))
|
||||
(if (nil? found)
|
||||
(get-primitive name)
|
||||
found))))))))
|
||||
|
||||
(define vm-global-set
|
||||
(fn (vm frame name value)
|
||||
"Set a global: write to closure env if name exists there, else globals."
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env"))
|
||||
(written false))
|
||||
(when (not (nil? closure-env))
|
||||
(set! written (env-walk-set! closure-env name value)))
|
||||
(when (not written)
|
||||
(dict-set! (get vm "globals") name value)))))
|
||||
|
||||
;; env-walk: walk an environment chain looking for a binding.
|
||||
;; Returns the value or nil if not found.
|
||||
(define env-walk
|
||||
(fn (env name)
|
||||
(if (nil? env) nil
|
||||
(if (env-has? env name)
|
||||
(env-get env name)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) nil
|
||||
(env-walk parent name)))))))
|
||||
|
||||
;; env-walk-set!: walk an environment chain, set value if name found.
|
||||
;; Returns true if set, false if not found.
|
||||
(define env-walk-set!
|
||||
(fn (env name value)
|
||||
(if (nil? env) false
|
||||
(if (env-has? env name)
|
||||
(do (env-set! env name value) true)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) false
|
||||
(env-walk-set! parent name value)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Closure creation — OP_CLOSURE with upvalue capture
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-create-closure
|
||||
(fn (vm frame code-val)
|
||||
"Create a closure from a code constant. Reads upvalue descriptors
|
||||
from the bytecode stream and captures values from the enclosing frame."
|
||||
(let ((code (code-from-value code-val))
|
||||
(uv-count (if (dict? code-val)
|
||||
(let ((n (get code-val "upvalue-count")))
|
||||
(if (nil? n) 0 n))
|
||||
0)))
|
||||
(let ((upvalues
|
||||
(let ((result (list))
|
||||
(i 0))
|
||||
(define capture-loop
|
||||
(fn ()
|
||||
(when (< i uv-count)
|
||||
(let ((is-local (frame-read-u8 frame))
|
||||
(index (frame-read-u8 frame)))
|
||||
(let ((cell
|
||||
(if (= is-local 1)
|
||||
;; Capture from enclosing frame's local slot.
|
||||
;; Create/reuse a shared cell so both parent
|
||||
;; and closure read/write through it.
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str index)))
|
||||
(if (has-key? cells key)
|
||||
(get cells key)
|
||||
(let ((c (make-upvalue-cell
|
||||
(vm-stack-get (get vm "stack")
|
||||
(+ (get frame "base") index)))))
|
||||
(dict-set! cells key c)
|
||||
c)))
|
||||
;; Capture from enclosing frame's upvalue
|
||||
(nth (get (get frame "closure") "vm-upvalues") index))))
|
||||
(append! result cell)
|
||||
(set! i (+ i 1))
|
||||
(capture-loop))))))
|
||||
(capture-loop)
|
||||
result)))
|
||||
(make-vm-closure code upvalues nil
|
||||
(get vm "globals") nil)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Main execution loop — iterative dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-run
|
||||
(fn (vm)
|
||||
"Execute bytecode until all frames are exhausted.
|
||||
VmClosure calls push new frames; the loop picks them up.
|
||||
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
|
||||
(define loop
|
||||
(fn ()
|
||||
(when (not (empty? (get vm "frames")))
|
||||
(let ((frame (first (get vm "frames")))
|
||||
(rest-frames (rest (get vm "frames"))))
|
||||
(let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
|
||||
(consts (get (get (get frame "closure") "vm-code") "vc-constants")))
|
||||
(if (>= (get frame "ip") (len bc))
|
||||
;; Bytecode exhausted — stop
|
||||
(dict-set! vm "frames" (list))
|
||||
(do
|
||||
(vm-step vm frame rest-frames bc consts)
|
||||
(loop))))))))
|
||||
(loop)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Single step — opcode dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-step
|
||||
(fn (vm frame rest-frames bc consts)
|
||||
(let ((op (frame-read-u8 frame)))
|
||||
(cond
|
||||
|
||||
;; ---- Constants ----
|
||||
(= op 1) ;; OP_CONST
|
||||
(let ((idx (frame-read-u16 frame)))
|
||||
(vm-push vm (nth consts idx)))
|
||||
|
||||
(= op 2) ;; OP_NIL
|
||||
(vm-push vm nil)
|
||||
|
||||
(= op 3) ;; OP_TRUE
|
||||
(vm-push vm true)
|
||||
|
||||
(= op 4) ;; OP_FALSE
|
||||
(vm-push vm false)
|
||||
|
||||
(= op 5) ;; OP_POP
|
||||
(vm-pop vm)
|
||||
|
||||
(= op 6) ;; OP_DUP
|
||||
(vm-push vm (vm-peek vm))
|
||||
|
||||
;; ---- Variable access ----
|
||||
(= op 16) ;; OP_LOCAL_GET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-local-get vm frame slot)))
|
||||
|
||||
(= op 17) ;; OP_LOCAL_SET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(frame-local-set vm frame slot (vm-peek vm)))
|
||||
|
||||
(= op 18) ;; OP_UPVALUE_GET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-upvalue-get frame idx)))
|
||||
|
||||
(= op 19) ;; OP_UPVALUE_SET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(frame-upvalue-set frame idx (vm-peek vm)))
|
||||
|
||||
(= op 20) ;; OP_GLOBAL_GET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-push vm (vm-global-get vm frame name)))
|
||||
|
||||
(= op 21) ;; OP_GLOBAL_SET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-global-set vm frame name (vm-peek vm)))
|
||||
|
||||
;; ---- Control flow ----
|
||||
(= op 32) ;; OP_JUMP
|
||||
(let ((offset (frame-read-i16 frame)))
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset)))
|
||||
|
||||
(= op 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when (not v)
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
(= op 34) ;; OP_JUMP_IF_TRUE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when v
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
;; ---- Function calls ----
|
||||
(= op 48) ;; OP_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 49) ;; OP_TAIL_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
;; Drop current frame, reuse stack space — true TCO
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 50) ;; OP_RETURN
|
||||
(let ((result (vm-pop vm)))
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-push vm result))
|
||||
|
||||
(= op 51) ;; OP_CLOSURE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(code-val (nth consts idx)))
|
||||
(let ((cl (vm-create-closure vm frame code-val)))
|
||||
(vm-push vm cl)))
|
||||
|
||||
(= op 52) ;; OP_CALL_PRIM
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(argc (frame-read-u8 frame))
|
||||
(name (nth consts idx))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(vm-push vm (call-primitive name args-rev)))
|
||||
|
||||
;; ---- Collections ----
|
||||
(= op 64) ;; OP_LIST
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(items-rev (list))
|
||||
(i 0))
|
||||
(define collect-items
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! items-rev (cons (vm-pop vm) items-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-items))))
|
||||
(collect-items)
|
||||
(vm-push vm items-rev))
|
||||
|
||||
(= op 65) ;; OP_DICT
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(d {})
|
||||
(i 0))
|
||||
(define collect-pairs
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(let ((v (vm-pop vm))
|
||||
(k (vm-pop vm)))
|
||||
(dict-set! d k v)
|
||||
(set! i (+ i 1))
|
||||
(collect-pairs)))))
|
||||
(collect-pairs)
|
||||
(vm-push vm d))
|
||||
|
||||
;; ---- String ops ----
|
||||
(= op 144) ;; OP_STR_CONCAT
|
||||
(let ((count (frame-read-u8 frame))
|
||||
(parts-rev (list))
|
||||
(i 0))
|
||||
(define collect-parts
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! parts-rev (cons (vm-pop vm) parts-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-parts))))
|
||||
(collect-parts)
|
||||
(vm-push vm (apply str parts-rev)))
|
||||
|
||||
;; ---- Define ----
|
||||
(= op 128) ;; OP_DEFINE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(dict-set! (get vm "globals") name (vm-peek vm)))
|
||||
|
||||
:else
|
||||
(error (str "VM: unknown opcode " op))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 12. Entry points
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Execute a closure with arguments — creates a fresh VM.
|
||||
(define vm-call-closure
|
||||
(fn (closure args globals)
|
||||
(let ((vm (make-vm globals)))
|
||||
(vm-push-frame vm closure args)
|
||||
(vm-run vm)
|
||||
(vm-pop vm))))
|
||||
|
||||
;; Execute a compiled module (top-level bytecode).
|
||||
(define vm-execute-module
|
||||
(fn (code globals)
|
||||
(let ((closure (make-vm-closure code (list) "module" globals nil))
|
||||
(vm (make-vm globals)))
|
||||
(let ((frame (make-vm-frame closure 0)))
|
||||
;; Pad local slots
|
||||
(let ((i 0)
|
||||
(total (get code "vc-locals")))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i total)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop))
|
||||
(dict-set! vm "frames" (list frame))
|
||||
(vm-run vm)
|
||||
(vm-pop vm)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 13. Platform interface
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Each target must provide:
|
||||
;;
|
||||
;; make-vm-stack(size) → opaque stack (array-like)
|
||||
;; vm-stack-get(stack, idx) → value at index
|
||||
;; vm-stack-set!(stack, idx, value) → mutate index
|
||||
;; vm-stack-length(stack) → current capacity
|
||||
;; vm-stack-copy!(src, dst, count) → copy first count elements
|
||||
;;
|
||||
;; cek-call(f, args) → evaluate via CEK machine (fallback)
|
||||
;; get-primitive(name) → look up primitive by name (returns callable)
|
||||
;; call-primitive(name, args) → call primitive directly with args list
|
||||
;;
|
||||
;; env-parent(env) → parent environment or nil
|
||||
;; env-has?(env, name) → boolean
|
||||
;; env-get(env, name) → value
|
||||
;; env-set!(env, name, value) → mutate binding
|
||||
Reference in New Issue
Block a user