commit 1827ee1e22f5dff0e033a7e319188ecdaba15020 Author: d_m Date: Fri Jan 17 23:27:06 2025 -0500 initial commit diff --git a/README.md b/README.md new file mode 100644 index 0000000..e69de29 diff --git a/vm.scm b/vm.scm new file mode 100644 index 0000000..844e3db --- /dev/null +++ b/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))