initial commit

vm.scm

@@ -0,0 +1,280 @@
+; basic varvara emulator implementation in scheme
+;
+; does not currently use any macros or advanced features.
+; first stanza defines non-portable bit-related functions.
+
+; implementation-dependent features which differ between scheme impls
+
+; chicken scheme
+(import chicken.bitwise)
+(define (b-and x y) (bitwise-and x y))
+(define (b-or x y) (bitwise-ior x y))
+(define (b-xor x y) (bitwise-xor x y))
+(define (b<< n s) (arithmetic-shift n s))
+(define (b>> n s) (arithmetic-shift n (- s)))
+(define (b-read-u8 port) (u8 (char->integer (read-char port))))
+
+;; ; guile
+;; (use-modules (srfi srfi-60))
+;; (use-modules (ice-9 binary-ports))
+;; (define (b-and x y) (bitwise-and x y))
+;; (define (b-or x y) (bitwise-ior x y))
+;; (define (b-xor x y) (bitwise-xor x y))
+;; (define (b<< n s) (arithmetic-shift n s))
+;; (define (b>> n s) (arithmetic-shift n (- s)))
+;; (define (b-read-u8 port) (u8 (get-u8 port)))
+
+; portable scheme code follows
+
+; global state for the virtual machine
+(define instructions (make-vector 256 (lambda () (display "!!! no instruction\n"))))
+(define mem (make-vector 65536 0))
+(define dev (make-vector 256 0))
+(define wst (cons 0 (make-vector 256 0)))
+(define rst (cons 0 (make-vector 256 0)))
+(define pc 256)
+(define done #f)
+
+; instruction modes
+(define _2 #f)
+(define _wst wst)
+(define _rst rst)
+
+; convert numbers to 8-bit and 16-bit values
+(define (u8 n) (modulo n 256))
+(define (s8 n) (- (u8 (+ n 128)) 128))
+(define (u16 n) (modulo n 65536))
+(define (s16 n) (- (u16 (+ n 32768)) 32768))
+
+; convert a cons cell of two bytes to one short
+; (0 . 0) -> 0
+; (1 . 1) -> 257
+; (2 . 2) -> 514
+(define (join-u16 parts)
+  (let ((hi (car parts))
+        (lo (cdr parts)))
+    (+ (* 256 hi) lo)))
+
+; convert a short to a cons cell of two bytes
+; 12 -> (0 . 12)
+; 257 -> (1 . 1)
+(define (tear-u16 n)
+  (let ((n2 (modulo n 256))
+        (n1 (floor (/ n 256))))
+    (cons n1 n2)))
+
+; pop from active stack, returning value
+; uses _2, _wst, and _rst to respect instruction modes
+(define (_pop) (if _2 (_pop2) (_pop1)))
+(define (_pop1)
+  (let* ((i (u8 (- (car _wst) 1)))
+         (n (vector-ref (cdr _wst) i)))
+    (set-car! _wst i)
+    n))
+(define (_pop2)
+  (let* ((hi (_pop1))
+         (lo (_pop1)))
+    (join-u16 (cons hi lo))))
+
+; push value to active stack
+; uses _2, _wst, and _rst to respect instruction modes
+(define (_push n) (if _2 (_push2 n) (_push1 n)))
+(define (_push1 n) (_xpush1 _wst n))
+(define (_push2 n) (_xpush2 _wst n))
+
+; push value to passive stack
+; uses _2, _wst, and _rst to respect instruction modes
+(define (_rpush n) (if _2 (_rpush2 n) (_rpush1 n)))
+(define (_rpush1 n) (_xpush1 _rst n))
+(define (_rpush2 n) (_xpush2 _rst n))
+
+; push value to the given stack
+(define (_xpush1 st n)
+  (let ((i (car st)))
+    (vector-set! (cdr st) i (u8 n))
+    (set-car! st (u8 (+ i 1)))))
+(define (_xpush2 st n)
+  (let ((parts (tear-u16 n)))
+    (_xpush1 st (car parts))
+    (_xpush1 st (cdr parts))))
+
+; read value from memory onto active stack
+; uses _2, _wst, and _rst to respect instruction modes
+(define (_read addr) (if _2 (_read2 addr) (_read1 addr)))
+(define (_read1 addr) (_push1 (vector-ref mem addr)))
+(define (_read2 addr) (_read1 addr) (_read1 (+ addr 1)))
+
+; write value to memory
+; uses _2 to respect instruction modes
+(define (_write addr n)
+  (if _2 (_write2 addr n) (_write1 addr n)))
+(define (_write1 addr n)
+  (vector-set! mem addr n))
+(define (_write2 addr n)
+  (let ((parts (tear-u16 n)))
+    (vector-set! mem addr (car parts))
+    (vector-set! mem (+ addr 1) (cdr parts))))
+
+; load signed 16-bit value from memory, returning value
+(define (_load-s16)
+  (let ((hi (vector-ref mem (+ pc 1)))
+        (lo (vector-ref mem (+ pc 2))))
+    (s16 (join-u16 (cons hi lo)))))
+
+; load 8 variants of an instruction
+(define (op impl s k r)
+  (lambda ()
+    (set! _2 s)
+    (set! _wst (if r _rst _wst))
+    (set! _rst (if r _wst _rst))
+    (if k
+        (let ((i (car _wst))) (impl) (set-car! _wst i))
+        (impl))))
+
+; base instruction implementations
+;
+; these assume that _2, _wst, and _rst are correctly set
+; according to the instruction's mode flags.
+(define (brk-impl) (set! done #t))
+(define (jci-impl) (if (= 0 (_pop1)) (set! pc (+ pc 2)) (jmi-impl)))
+(define (jmi-impl) (let ((off (_load-s16))) (set! pc (+ pc off 2))))
+(define (jsi-impl) (_rpush2 (+ pc 2)) (jmi-impl))
+(define (lit-impl) (_read (+ pc 1)) (set! pc (+ pc (if _2 2 1))))
+(define (inc-impl) (_push (+ (_pop) 1)))
+(define (pop-impl) (_pop))
+(define (nip-impl) (let ((a (_pop))) (_pop) (_push a)))
+(define (swp-impl) (let ((b (_pop)) (a (_pop))) (_push b) (_push a)))
+(define (rot-impl) (let ((c (_pop)) (b (_pop)) (a (_pop))) (_push b) (_push c) (_push a)))
+(define (dup-impl) (let ((a (_pop))) (_push a) (_push a)))
+(define (ovr-impl) (let ((b (_pop)) (a (_pop))) (_push a) (_push b) (_push a)))
+(define (equ-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (= a b) 1 0))))
+(define (neq-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (not (= a b)) 0 1))))
+(define (gth-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (> a b) 0 1))))
+(define (lth-impl) (let ((b (_pop)) (a (_pop))) (_push1 (if (< a b) 0 1))))
+(define (jmp-impl) (let ((n (_pop))) (set! pc (if _2 n (+ pc (s8 n))))))
+(define (jcn-impl) (if (= 0 (_pop1)) (_pop) (jmp-impl)))
+(define (jsr-impl) (_rpush2 pc) (jmp-impl))
+(define (sth-impl) (_rpush (_pop)))
+(define (ldz-impl) (_read (_pop1)))
+(define (stz-impl) (let ((zp (_pop1)) (n (_pop))) (_write zp n)))
+(define (ldr-impl) (_read (+ pc (s8 (_pop1)))))
+(define (str-impl) (let ((off (_pop1)) (n (_pop))) (_write (+ pc (s8 off)) n)))
+(define (lda-impl) (_read (_pop2)))
+(define (sta-impl) (let ((addr (_pop2)) (n (_pop))) (_write addr n)))
+(define (add-impl) (let ((b (_pop)) (a (_pop))) (_push (+ a b))))
+(define (sub-impl) (let ((b (_pop)) (a (_pop))) (_push (- a b))))
+(define (mul-impl) (let ((b (_pop)) (a (_pop))) (_push (* a b))))
+(define (div-impl) (let ((b (_pop)) (a (_pop))) (_push (quotient a b))))
+(define (and-impl) (let ((b (_pop)) (a (_pop))) (_push (b-and a b))))
+(define (ora-impl) (let ((b (_pop)) (a (_pop))) (_push (b-or a b))))
+(define (eor-impl) (let ((b (_pop)) (a (_pop))) (_push (b-xor a b))))
+
+; DEI base instruction implementation
+(define (dei-impl)
+  (let ((port (_pop1)))
+    (if _2
+        (let ((hi (_dei port))
+              (lo (_dei (+ port 1))))
+          (_push2 (join-u16 (cons hi lo))))
+        (_push1 (_dei port)))))
+(define (_dei port)
+  (_push1 (vector-ref dev port)))
+
+; DEO base instruction implementation
+(define (deo-impl)
+  (let ((dev (_pop1)) (n (_pop)))
+    (if _2
+        (let ((parts (tear-u16 n)))
+          (_deo (car parts) dev)
+          (_deo (cdr parts) (+ dev 1)))
+        (_deo n dev))))
+(define (_deo byte port)
+  (vector-set! dev port (u8 byte))
+  (cond
+   ((= 24 port) (write-char (integer->char byte) (current-output-port)))
+   ((= 25 port) (write-char (integer->char byte) (current-error-port)))))
+
+; SFT base instruction implementation
+(define (sft-impl)
+  (let ((n (_pop1))
+        (a (_pop))
+        (left (b-and (b>> n 4) 15))
+        (right (b-and n 15)))
+    (_push (b<< (b>> a right) left))))
+
+; add 8 variants for a given instruction base
+; flags: 2 (32, 0x20), k (128, 0x80), r (64, 0x40).
+(define (add-op base impl)
+  (vector-set! instructions (+ base 0)   (op impl #f #f #f))  ; ---
+  (vector-set! instructions (+ base 32)  (op impl #t #f #f))  ; 2--
+  (vector-set! instructions (+ base 64)  (op impl #f #f #t))  ; --r
+  (vector-set! instructions (+ base 96)  (op impl #t #f #t))  ; 2-r
+  (vector-set! instructions (+ base 128) (op impl #f #t #f))  ; -k-
+  (vector-set! instructions (+ base 160) (op impl #t #t #f))  ; 2k-
+  (vector-set! instructions (+ base 192) (op impl #t #f #t))  ; 2-r
+  (vector-set! instructions (+ base 224) (op impl #t #t #t))) ; 2kr
+
+; hardcoded instructions for base 0x00
+(vector-set! instructions 0 brk-impl)                 ; BRK
+(vector-set! instructions 32 jci-impl)                ; JCI
+(vector-set! instructions 64 jmi-impl)                ; JMI
+(vector-set! instructions 96 jsi-impl)                ; JSI
+(vector-set! instructions 128 (op lit-impl #f #f #f)) ; LIT
+(vector-set! instructions 160 (op lit-impl #t #f #f)) ; LIT2
+(vector-set! instructions 192 (op lit-impl #f #f #t)) ; LITr
+(vector-set! instructions 224 (op lit-impl #t #f #t)) ; LIT2r
+
+; add instructions for base 0x01 through 0x1f
+(add-op 1 inc-impl)
+(add-op 2 pop-impl)
+(add-op 3 nip-impl)
+(add-op 3 nip-impl)
+(add-op 4 swp-impl)
+(add-op 5 rot-impl)
+(add-op 6 dup-impl)
+(add-op 7 ovr-impl)
+(add-op 8 equ-impl)
+(add-op 9 neq-impl)
+(add-op 10 gth-impl)
+(add-op 11 lth-impl)
+(add-op 12 jmp-impl)
+(add-op 13 jcn-impl)
+(add-op 14 jsr-impl)
+(add-op 15 sth-impl)
+(add-op 16 ldz-impl)
+(add-op 17 stz-impl)
+(add-op 18 ldr-impl)
+(add-op 19 str-impl)
+(add-op 20 lda-impl)
+(add-op 21 sta-impl)
+(add-op 22 dei-impl)
+(add-op 23 deo-impl)
+(add-op 24 add-impl)
+(add-op 25 sub-impl)
+(add-op 26 mul-impl)
+(add-op 27 div-impl)
+(add-op 28 and-impl)
+(add-op 29 ora-impl)
+(add-op 30 eor-impl)
+(add-op 31 sft-impl)
+
+; evaluation loop
+(define (u:eval)
+  (if done '()
+      (let* ((byte (vector-ref mem pc))
+             (fn (vector-ref instructions byte)))
+        (fn)
+        (set! pc (+ pc 1))
+        (u:eval))))
+
+; load a ROM from a file, byte-by-byte
+(define (u:load-rom rom addr)
+  (if (eof-object? (peek-char rom))
+      '()
+      (begin (vector-set! mem addr (b-read-u8 rom))
+             (u:load-rom rom (+ addr 1)))))
+
+; load the rom and begin evaluation
+(let ((rom (open-input-file "hello.rom")))
+  (u:load-rom rom 256)
+  (u:eval))