482 lines
14 KiB
Racket
482 lines
14 KiB
Racket
#lang racket
|
|
|
|
(struct mem
|
|
(regs pc sp flags bank))
|
|
|
|
(define (make-mem [start #x00] [bs '()])
|
|
(set-bytes start bs
|
|
(mem (make-regs)
|
|
start
|
|
0
|
|
0
|
|
(make-bank))))
|
|
|
|
(define (make-regs)
|
|
(make-vector 8 0))
|
|
|
|
(define (get-zero mem)
|
|
(bitwise-bit-set? (mem-flags mem) 7))
|
|
|
|
(define (get-carry mem)
|
|
(bitwise-bit-set? (mem-flags mem) 4))
|
|
|
|
(define (get-reg x mem)
|
|
(if (and (< x 8) (>= x 0))
|
|
(let ([regs (mem-regs mem)])
|
|
(if (not (= x 6))
|
|
(vector-ref regs x)
|
|
(let([bank (mem-bank mem)]
|
|
[h (vector-ref regs 4)]
|
|
[l (vector-ref regs 5)])
|
|
(vector-ref bank (make-16b-addr h l)))))
|
|
(error "unknown register index")))
|
|
|
|
(define (set-reg x val m)
|
|
(if (and (< x 8) (>= x 0))
|
|
(let ([regs (mem-regs m)])
|
|
(if (not (= x 6))
|
|
(let ([newregs (vector-copy regs)])
|
|
(vector-set! newregs x (mod-8bit val))
|
|
(struct-copy mem m [regs newregs]))
|
|
(let ([newbank (vector-copy (mem-bank m))]
|
|
[h (vector-ref regs 4)]
|
|
[l (vector-ref regs 5)])
|
|
(vector-set! newbank (make-16b-addr h l) (mod-8bit val))
|
|
(struct-copy mem m [bank newbank]))))
|
|
(error "unknown register index")))
|
|
|
|
(define (make-bank [def #x00])
|
|
(make-vector 65536 def))
|
|
|
|
(define (mod-8bit val)
|
|
(modulo val 256))
|
|
|
|
(define (mod-16bit val)
|
|
(modulo val 65536))
|
|
|
|
(define (set-pc addr m)
|
|
(begin
|
|
(struct-copy mem m [pc (mod-16bit addr)])))
|
|
|
|
(define (set-flags f m)
|
|
(begin
|
|
(struct-copy mem m [flags (mod-8bit f)])))
|
|
|
|
(define (get-byte addr m)
|
|
(let ([b (mem-bank m)])
|
|
(if (and (>= addr 0)
|
|
(< addr (vector-length b)))
|
|
(vector-ref b addr)
|
|
(error (format "address ~a out of bounds" addr)))))
|
|
|
|
(define (set-byte addr val m)
|
|
(let ([b (mem-bank m)])
|
|
(if (and (>= addr 0)
|
|
(< addr (vector-length b)))
|
|
(let ([newbank (vector-copy b)])
|
|
(vector-set! newbank addr (mod-8bit val))
|
|
(struct-copy mem m [bank newbank]))
|
|
(error (format "address ~a out of bounds" addr)))))
|
|
|
|
(define (set-bytes addr bs m)
|
|
(if (null? bs)
|
|
m
|
|
(set-bytes (mod-16bit (add1 addr))
|
|
(cdr bs)
|
|
(set-byte addr (car bs) m))))
|
|
|
|
(define (get-x byte)
|
|
(arithmetic-shift (bitwise-and #b11000000 byte) -6))
|
|
|
|
(define (get-y byte)
|
|
(arithmetic-shift (bitwise-and #b00111000 byte) -3))
|
|
|
|
(define (get-z byte)
|
|
(bitwise-and #b00000111 byte))
|
|
|
|
(define (inc-sp m)
|
|
(struct-copy mem m [sp (add1 (mem-sp m))]))
|
|
|
|
(define (inc-pc m)
|
|
(struct-copy mem m [pc (add1 (mem-pc m))]))
|
|
|
|
(define (make-16b-addr x y)
|
|
(bitwise-ior y (arithmetic-shift x 8)))
|
|
|
|
(define (make-8b-ld-reg-imm y m)
|
|
(letrec ([pc (mem-pc m)]
|
|
[x (get-byte pc m)])
|
|
(cons (8b-ld-reg-imm y x)
|
|
(set-pc (add1pc pc) m))))
|
|
|
|
(define (make-jp cc m)
|
|
(letrec ([pc (mem-pc m)]
|
|
[y (get-byte pc m)]
|
|
[npc (add1pc pc)]
|
|
[x (get-byte npc m)]
|
|
[addr (make-16b-addr x y)]
|
|
[cs (cc-tab cc)])
|
|
(cons (jp cs addr) (set-pc (add1pc npc) m))))
|
|
|
|
(define (cc-tab cc)
|
|
(case cc
|
|
[(0) 'NZ]
|
|
[(1) 'Z]
|
|
[(2) 'NC]
|
|
[(3) 'C]
|
|
[else 'uncond]))
|
|
|
|
(define (make-8b-ld-reg-reg y z m)
|
|
(cons (8b-ld-reg-reg y z)
|
|
m))
|
|
|
|
(define (make-alu-imm z m)
|
|
(letrec ([pc (mem-pc m)]
|
|
[x (get-byte pc m)])
|
|
(cons (case z
|
|
[(0) (8b-add-imm x)]
|
|
[(1) (8b-adc-imm x)]
|
|
[(2) (8b-sub-imm x)]
|
|
[(3) (8b-sbc-imm x)]
|
|
[(4) (8b-and-imm x)]
|
|
[(5) (8b-xor-imm x)]
|
|
[(6) (8b-or-imm x)]
|
|
[(7) (8b-cp-imm x)]
|
|
[else (nop)])
|
|
(inc-pc m))))
|
|
|
|
(define (make-8b-inc-dec-reg y z m)
|
|
(cons ((case z
|
|
[(4) 8b-inc-reg]
|
|
[(5) 8b-dec-reg]) y)
|
|
m))
|
|
|
|
(define (make-alu-reg y z m)
|
|
(cons (case y
|
|
[(0) (8b-add-reg z)]
|
|
[(1) (8b-adc-reg z)]
|
|
[(2) (8b-sub-reg z)]
|
|
[(3) (8b-sbc-reg z)]
|
|
[(4) (8b-and-reg z)]
|
|
[(5) (8b-xor-reg z)]
|
|
[(6) (8b-or-reg z)]
|
|
[(7) (8b-cp-reg z)])
|
|
m))
|
|
|
|
(define (make-nop m)
|
|
(cons (nop) m))
|
|
|
|
(define (make-stop m)
|
|
(cons 'STOP m))
|
|
|
|
(define (jp cc addr)
|
|
(case cc
|
|
[(uncond) (jp-uncond addr)]
|
|
[else (jp-cond cc addr)]))
|
|
|
|
(define (8b-ld-reg-imm reg imm)
|
|
(lambda (m)
|
|
(set-reg reg imm m)))
|
|
|
|
(define (8b-ld-reg-reg dst src)
|
|
(lambda (m)
|
|
(set-reg dst
|
|
(get-reg src m)
|
|
m)))
|
|
|
|
(define (8b-inc-reg r)
|
|
(lambda (m)
|
|
(let ([a (mod-8bit (add1 (get-reg r m)))])
|
|
(set-flags
|
|
(bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00))
|
|
(set-reg r a m)))))
|
|
|
|
(define (8b-dec-reg r)
|
|
(lambda (m)
|
|
(let ([a (mod-8bit (sub1 (get-reg r m)))])
|
|
(set-flags
|
|
(bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
#b01000000)
|
|
(set-reg r a m)))))
|
|
|
|
(define (jp-cond cc addr)
|
|
(lambda (m)
|
|
(let ([c (get-carry m)]
|
|
[z (get-zero m)])
|
|
(if (case cc
|
|
[(NZ) (not z)]
|
|
[(Z) z]
|
|
[(NC) (not c)]
|
|
[(C) c])
|
|
(set-pc addr m)
|
|
m))))
|
|
|
|
(define (jp-uncond addr)
|
|
(lambda (m)
|
|
(set-pc addr m)))
|
|
|
|
(define (8b-add-imm v)
|
|
(lambda (m)
|
|
(let ([a (+ (get-reg 7 m)
|
|
(mod-8bit v))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-sbc-imm v)
|
|
(lambda (m)
|
|
(letrec ([c (bitwise-and #b00010000 (mem-flags m))]
|
|
[a (- (get-reg 7 m)
|
|
(mod-8bit v)
|
|
c)])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-sub-imm v)
|
|
(lambda (m)
|
|
(let ([a (- (get-reg 7 m)
|
|
(mod-8bit v))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-cp-imm v)
|
|
(lambda (m)
|
|
(let ([a (- (get-reg 7 m)
|
|
(mod-8bit v))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
m))))
|
|
|
|
(define (8b-adc-imm v)
|
|
(lambda (m)
|
|
(letrec ([c (bitwise-and #b00010000 (mem-flags m))]
|
|
[a (+ (get-reg 7 m)
|
|
(mod-8bit v)
|
|
c)])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-add-reg r)
|
|
(lambda (m)
|
|
(let ([a (+ (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-sbc-reg r)
|
|
(lambda (m)
|
|
(letrec ([c (bitwise-and #b00010000 (mem-flags m))]
|
|
[a (- (get-reg 7 m)
|
|
(get-reg r m)
|
|
c)])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-sub-reg r)
|
|
(lambda (m)
|
|
(let ([a (- (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-cp-reg r)
|
|
(lambda (m)
|
|
(let ([a (- (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
m))))
|
|
|
|
(define (8b-adc-reg r)
|
|
(lambda (m)
|
|
(letrec ([c (bitwise-and #b00010000 (mem-flags m))]
|
|
[a (+ (get-reg 7 m)
|
|
(get-reg r m)
|
|
c)])
|
|
(set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
|
|
(if (>= a 16) #b00100000 #x00)
|
|
(if (>= a 256) #b00010000 #x00))
|
|
(set-reg 7 (mod-8bit a) m)))))
|
|
|
|
(define (8b-xor-reg r)
|
|
(lambda (m)
|
|
(let ([a (bitwise-xor (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (8b-and-reg r)
|
|
(lambda (m)
|
|
(let ([a (bitwise-and (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (8b-or-reg r)
|
|
(lambda (m)
|
|
(let ([a (bitwise-ior (get-reg 7 m)
|
|
(get-reg r m))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (8b-xor-imm imm)
|
|
(lambda (m)
|
|
(let ([a (bitwise-xor (get-reg 7 m)
|
|
(mod-8bit imm))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (8b-or-imm imm)
|
|
(lambda (m)
|
|
(let ([a (bitwise-ior (get-reg 7 m)
|
|
(mod-8bit imm))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (8b-and-imm imm)
|
|
(lambda (m)
|
|
(let ([a (bitwise-and (get-reg 7 m)
|
|
(mod-8bit imm))])
|
|
(set-flags (if (= a 0) #b10000000 #x00)
|
|
(set-reg 7 a m)))))
|
|
|
|
(define (nop)
|
|
(lambda (m) m))
|
|
|
|
(define (display-byte-hex v)
|
|
(~a #:align 'right #:left-pad-string "0" #:width 2
|
|
(format "~x" v)))
|
|
|
|
(define (display-word-hex v)
|
|
(~a #:align 'right #:left-pad-string "0" #:width 4
|
|
(format "~x" v)))
|
|
|
|
(define (display-bin v)
|
|
(~a #:left-pad-string "0" #:width 8 #:align 'right
|
|
(format "~b" v)))
|
|
|
|
(define (print-regs m)
|
|
(letrec ([regs (mem-regs m)]
|
|
[F (display-byte-hex (mem-flags m))]
|
|
[B (display-byte-hex (vector-ref regs 0))]
|
|
[C (display-byte-hex (vector-ref regs 1))]
|
|
[D (display-byte-hex (vector-ref regs 2))]
|
|
[E (display-byte-hex (vector-ref regs 3))]
|
|
[h (vector-ref regs 4)]
|
|
[l (vector-ref regs 5)]
|
|
[H (display-byte-hex (vector-ref regs 4))]
|
|
[L (display-byte-hex (vector-ref regs 5))]
|
|
[HL-ind (display-byte-hex (get-byte (make-16b-addr h l) m))]
|
|
[A (display-byte-hex (vector-ref regs 7))])
|
|
(displayln (format "BC: $~a~a, DE: $~a~a" B C D E))
|
|
(displayln (format "HL: $~a~a, AF: $~a~a" H L A F))
|
|
(displayln (format "(HL): $~a" HL-ind))
|
|
(void)))
|
|
|
|
(define (print-state m)
|
|
(displayln (format "PC: $~a, SP: $~a, Flags: %~a"
|
|
(display-word-hex (mem-pc m))
|
|
(display-word-hex (mem-sp m))
|
|
(display-bin (mem-flags m)))))
|
|
|
|
(define (print-part-bank start count m)
|
|
(define (print-mem v)
|
|
(display (format " $~a" (display-byte-hex v))))
|
|
(let ([s (display-word-hex start)]
|
|
[e (display-word-hex (mod-16bit (+ start (sub1 count))))])
|
|
(display (format "$~a >" s))
|
|
(let ([splice (vector-take
|
|
(vector-drop (mem-bank m) start)
|
|
count)])
|
|
(vector-map print-mem splice))
|
|
(display (format " < $~a\n" e) ))
|
|
(void))
|
|
|
|
(define (add1pc pc)
|
|
(mod-16bit (add1 pc)))
|
|
|
|
(define (within x y z)
|
|
(and (>= x y) (<= x z)))
|
|
|
|
(define (decode-op m)
|
|
(letrec ([pc (mem-pc m)]
|
|
[op (get-byte pc m)]
|
|
[npc (add1pc pc)]
|
|
[x (get-x op)]
|
|
[y (get-y op)]
|
|
[z (get-z op)])
|
|
(cond
|
|
[(= #x00 op) (make-nop (set-pc npc m))]
|
|
[(= #x10 op) (make-stop (set-pc npc m))]
|
|
[(= #xC3 op) (make-jp 'uncond (set-pc npc m))]
|
|
[(and (= 0 x) (within z 4 5))
|
|
(make-8b-inc-dec-reg y z (set-pc npc m))]
|
|
[(= 1 x)
|
|
(make-8b-ld-reg-reg y z (set-pc npc m))]
|
|
[(= 2 x)
|
|
(make-alu-reg y z (set-pc npc m))]
|
|
[(and (= 3 x) (= z 2) (within y 0 3))
|
|
(make-jp y (set-pc npc m))]
|
|
[(and (= 3 x) (= z 6))
|
|
(make-alu-imm y (set-pc npc m))]
|
|
[(and (= 0 x) (= 6 z))
|
|
(make-8b-ld-reg-imm y (set-pc npc m))]
|
|
[else (make-nop (set-pc npc m))])))
|
|
|
|
(define (test-vm start bank-start bank-count bs)
|
|
(let ([m (make-mem start bs)])
|
|
(define (fin m)
|
|
(begin (print-state m)
|
|
(print-regs m)
|
|
(print-part-bank bank-start bank-count m)))
|
|
(define (run-op m)
|
|
(displayln (format "executing: $~a @ $~a"
|
|
(display-byte-hex (get-byte (mem-pc m) m))
|
|
(display-word-hex (mem-pc m))))
|
|
(letrec ([op-pc (decode-op m)]
|
|
[op (car op-pc)]
|
|
[newmem (cdr op-pc)])
|
|
(if (and (not (procedure? op))
|
|
(eq? op 'STOP))
|
|
(fin newmem)
|
|
(begin
|
|
;(print-state newmem)
|
|
;(print-regs newmem)
|
|
(run-op (op newmem))))))
|
|
(run-op m)))
|
|
|
|
(define (run-vm start bank-start bank-count bs)
|
|
(let ([m (make-mem start bs)])
|
|
(define (fin m)
|
|
(begin (print-state m)
|
|
(print-regs m)
|
|
(print-part-bank bank-start bank-count m)))
|
|
(define (run-op m)
|
|
(letrec ([op-pc (decode-op m)]
|
|
[op (car op-pc)]
|
|
[newmem (cdr op-pc)])
|
|
(if (and (not (procedure? op))
|
|
(eq? op 'STOP))
|
|
(fin newmem)
|
|
(run-op (op newmem)))))
|
|
(run-op m)))
|
|
|
|
(provide (all-defined-out))
|