--- a/src/emulator.lisp Tue Nov 22 21:41:34 2016 +0000
+++ b/src/emulator.lisp Thu Nov 24 12:45:02 2016 +0000
@@ -79,6 +79,9 @@
,@(iterate (for item :in items)
(collect `(,macro ,@(ensure-list item)))))))
+(defun required ()
+ (error "Required"))
+
;;;; Data ---------------------------------------------------------------------
(declaim
@@ -149,53 +152,8 @@
;;;; Disassembler -------------------------------------------------------------
(defun disassemble-instruction (instruction)
- (flet ((v (n) (symb 'v (format nil "~X" n))))
- (let ((_x__ (ldb (byte 4 8) instruction))
- (__x_ (ldb (byte 4 4) instruction))
- (___x (ldb (byte 4 0) instruction))
- (__xx (ldb (byte 8 0) instruction))
- (_xxx (ldb (byte 12 0) instruction)))
- (case (logand #xF000 instruction)
- (#x0000 (case instruction
- (#x00E0 '(cls))
- (#x00EE '(ret))))
- (#x1000 `(jp ,_xxx))
- (#x2000 `(call ,_xxx))
- (#x3000 `(se ,(v _x__) ,__xx))
- (#x4000 `(sne ,(v _x__) ,__xx))
- (#x5000 (case (logand #x000F instruction)
- (#x0 `(se ,(v _x__) ,(v __x_)))))
- (#x6000 `(ld ,(v _x__) ,__xx))
- (#x7000 `(add ,(v _x__) ,__xx))
- (#x8000 (case (logand #x000F instruction)
- (#x0 `(ld ,(v _x__) ,(v __x_)))
- (#x1 `(or ,(v _x__) ,(v __x_)))
- (#x2 `(and ,(v _x__) ,(v __x_)))
- (#x3 `(xor ,(v _x__) ,(v __x_)))
- (#x4 `(add ,(v _x__) ,(v __x_)))
- (#x5 `(sub ,(v _x__) ,(v __x_)))
- (#x6 `(shr ,(v _x__) ,(v __x_)))
- (#x7 `(subn ,(v _x__) ,(v __x_)))
- (#xE `(shl ,(v _x__) ,(v __x_)))))
- (#x9000 (case (logand #x000F instruction)
- (#x0 `(sne ,(v _x__) ,(v __x_)))))
- (#xA000 `(ld i ,_xxx))
- (#xB000 `(jp ,(v 0) ,_xxx))
- (#xC000 `(rnd ,(v _x__) ,__xx))
- (#xD000 `(drw ,(v _x__) ,(v __x_) ,___x))
- (#xE000 (case (logand #x00FF instruction)
- (#x9E `(skp ,(v _x__)))
- (#xA1 `(sknp ,(v _x__)))))
- (#xF000 (case (logand #x00FF instruction)
- (#x07 `(ld ,(v _x__) dt))
- (#x0A `(ld ,(v _x__) k))
- (#x15 `(ld dt ,(v _x__)))
- (#x18 `(ld st ,(v _x__)))
- (#x1E `(add i ,(v _x__)))
- (#x29 `(ld f ,(v _x__)))
- (#x33 `(ld b ,(v _x__)))
- (#x55 `(ld (mem i) ,_x__))
- (#x65 `(ld ,_x__ (mem i)))))))))
+ (declare (ignore instruction))
+ nil)
(defun bit-diagram (integer)
(iterate (for high-bit :from 15 :downto 8)
@@ -372,6 +330,20 @@
;;;; Opcodes ------------------------------------------------------------------
+(defparameter *opcodes* (make-hash-table))
+
+(defun dispatch-instruction (chip opcode)
+ (declare (ignore chip opcode))
+ nil)
+
+(defstruct opcode
+ (pattern (required) :type keyword)
+ (matcher (required) :type list)
+ (function-name (required) :type symbol)
+ (arglist (required) :type list)
+ (bindings (required) :type list)
+ (format-info (required) :type list))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun parse-opcode-argument-bindings (argument-list)
(flet ((normalize-arg (arg)
@@ -384,9 +356,48 @@
(when (not (eql symbol '_))
(collect `(,symbol (ldb (byte ,(* nibbles 4)
,(* position 4))
- opcode))))))))
+ opcode)))))))
+
+ (defun parse-opcode-matcher (opcode)
+ (map 'list (lambda (char)
+ (or (digit-char-p char 16) '_))
+ (symbol-name opcode)))
+
+ (defun record-opcode (opcode function-name arglist format-info)
+ (setf (gethash function-name *opcodes*)
+ (make-opcode :pattern opcode
+ :matcher (parse-opcode-matcher opcode)
+ :function-name function-name
+ :arglist arglist
+ :bindings (parse-opcode-argument-bindings arglist)
+ :format-info format-info)))
-(defmacro define-opcode (name argument-list &body body)
+ (defmacro recompile-instruction-matcher
+ (function arglist opcode-info-symbol clause-body)
+ `(compile ',function
+ `(lambda ,',arglist
+ (match* ((ldb (byte 4 12) opcode)
+ (ldb (byte 4 8) opcode)
+ (ldb (byte 4 4) opcode)
+ (ldb (byte 4 0) opcode))
+ ,@(iterate (for (nil ,opcode-info-symbol) :in-hashtable *opcodes*)
+ (collect (list (opcode-matcher ,opcode-info-symbol)
+ ,clause-body)))))))
+
+ (defun recompile-disassemble-instruction ()
+ (recompile-instruction-matcher disassemble-instruction
+ (opcode)
+ op-info
+ `(let (,@(opcode-bindings op-info))
+ (format nil ,@(opcode-format-info op-info)))))
+
+ (defun recompile-dispatch-instruction ()
+ (recompile-instruction-matcher dispatch-instruction
+ (chip opcode)
+ op-info
+ `(,(opcode-function-name op-info) chip opcode))))
+
+(defmacro define-opcode (opcode name argument-list format-info &body body)
`(progn
(declaim (ftype (function (chip int16)
(values null &optional))
@@ -398,95 +409,100 @@
`(aref registers ,index)))
(let ,(parse-opcode-argument-bindings argument-list)
,@body))
- nil))))
+ nil))
+ (record-opcode ,opcode ',name ',argument-list ',format-info)
+ (recompile-disassemble-instruction)
+ (recompile-dispatch-instruction)
+ ',name))
-(macro-map ;; LD ...
- ((name arglist destination source)
- ((op-ld-i<imm (_ (value 3)) index value)
- (op-ld-reg<imm (_ r (value 2)) (register r) value)
- (op-ld-reg<reg (_ rx ry _) (register rx) (register ry))
- (op-ld-reg<dt (_ r _ _) (register r) delay-timer)
- (op-ld-dt<reg (_ r _ _) delay-timer (register r))
- (op-ld-st<reg (_ r _ _) sound-timer (register r))))
- `(define-opcode ,name ,arglist
+(macro-map ;; LD ...
+ ((opcode name arglist destination source format-info)
+ ((:A___ op-ld-i<imm (_ (value 3)) index value ("LD I, ~3,'0X" value))
+ (:6___ op-ld-reg<imm (_ r (value 2)) (register r) value ("LD V~X, ~2,'0X" r value))
+ (:8__0 op-ld-reg<reg (_ rx ry _) (register rx) (register ry) ("LD V~X, V~X" rx ry))
+ (:F_07 op-ld-reg<dt (_ r _ _) (register r) delay-timer ("LD V~X, DT" r))
+ (:F_15 op-ld-dt<reg (_ r _ _) delay-timer (register r) ("LD DT, V~X" r))
+ (:F_18 op-ld-st<reg (_ r _ _) sound-timer (register r) ("LD ST, V~X" r))))
+ `(define-opcode ,opcode ,name ,arglist ,format-info
(setf ,destination ,source)))
-(define-opcode op-cls () ;; CLS
+(define-opcode :00E0 op-cls () ("CLS")
(fill video 0)
(setf video-dirty t))
-(define-opcode op-jp-imm (_ (target 3)) ;; JP addr
+(define-opcode :1___ op-jp-imm (_ (target 3)) ("JP ~3,'0X" target)
(setf program-counter target))
-(define-opcode op-jp-imm+reg (_ (target 3)) ;; JP V0 + addr
+(define-opcode :B___ op-jp-imm+reg (_ (target 3)) ("JP V0+~3,'0X" target)
(setf program-counter (+ target (register 0))))
-(define-opcode op-call (_ (target 3)) ;; CALL addr
+(define-opcode :2___ op-call (_ (target 3)) ("CALL ~3,'0X" target)
(vector-push program-counter stack)
(setf program-counter target))
-(define-opcode op-ret () ;; RET
+(define-opcode :00EE op-ret () ("RET")
(setf program-counter (vector-pop stack)))
-(macro-map ;; ADD/SUB (8-bit)
- ((name op source-arg source-expr)
- ((op-add-reg<imm +_8 (immediate 2) immediate)
- (op-add-reg<reg +_8 (ry 1) (register ry))
- (op-sub-reg<reg -_8 (ry 1) (register ry))))
- `(define-opcode ,name (_ rx ,source-arg)
+(macro-map ;; ADD/SUB (8-bit)
+ ((opcode name op source-arg source-expr format-info)
+ ((:7___ op-add-reg<imm +_8 (immediate 2) immediate ("ADD V~X, ~3,'0X" rx immediate))
+ (:8__4 op-add-reg<reg +_8 (ry 1) (register ry) ("ADD V~X, V~X" rx ry))
+ (:8__5 op-sub-reg<reg -_8 (ry 1) (register ry) ("SUB V~X, V~X" rx ry))))
+ `(define-opcode ,opcode ,name (_ rx ,source-arg) ,format-info
(multiple-value-bind (result carry)
(,op (register rx) ,source-expr)
(setf (register rx) result
flag carry))))
-(define-opcode op-add-index<reg (_ r) ;; ADD I, Vx (16-bit)
+(define-opcode :F_1E op-add-index<reg (_ r) ("ADD I, V~X" r)
(zapf index (chop 16 (+ % (register r)))))
-(define-opcode op-subn-reg<reg (_ rx ry) ;; SUBN
+(define-opcode :8__7 op-subn-reg<reg (_ rx ry) ("SUBN V~X, V~X" rx ry)
(multiple-value-bind (result carry)
(-_8 (register ry) (register rx)) ; subtraction order is swapped for SUBN
(setf (register rx) result
flag carry)))
-(macro-map ;; SE/SNE
- ((name test x-arg x-form y-arg y-form)
- ((op-se-reg-imm = (r 1) (register r) (immediate 2) immediate)
- (op-sne-reg-imm not= (r 1) (register r) (immediate 2) immediate)
- (op-se-reg-reg = (rx 1) (register rx) (ry 1) (register ry))
- (op-sne-reg-reg not= (rx 1) (register rx) (ry 1) (register ry))))
- `(define-opcode ,name (_ ,x-arg ,y-arg)
- (when (,test ,x-form ,y-form)
+(macro-map ;; SE/SNE
+ ((opcode name test arglist x y format-info)
+ ((:3___ op-se-reg-imm = (_ r (imm 2)) (register r) imm ("SE V~X, ~2,'0X" r imm))
+ (:4___ op-sne-reg-imm not= (_ r (imm 2)) (register r) imm ("SNE V~X, ~2,'0X" r imm))
+ (:5__0 op-se-reg-reg = (_ rx ry _) (register rx) (register ry) ("SE V~X, V~X" rx ry))
+ (:9__0 op-sne-reg-reg not= (_ rx ry _) (register rx) (register ry) ("SNE V~X, V~X" rx ry))))
+ `(define-opcode ,opcode ,name ,arglist ,format-info
+ (when (,test ,x ,y)
(incf program-counter 2))))
-(macro-map ;; AND/OR/XOR
- ((name function)
- ((op-or logior)
- (op-and logand)
- (op-xor logxor)))
- `(define-opcode ,name (_ destination source _)
+(macro-map ;; AND/OR/XOR
+ ((opcode name function format-string)
+ ((:8__1 op-or logior "OR V~X, V~X")
+ (:8__2 op-and logand "AND V~X, V~X")
+ (:8__3 op-xor logxor "XOR V~X, V~X")))
+ `(define-opcode ,opcode ,name (_ destination source _)
+ (,format-string destination source)
(zapf (register destination)
(,function % (register source)))))
-(define-opcode op-rand (_ r (mask 2)) ;; RND
+(define-opcode :C___ op-rand (_ r (mask 2)) ("RND V~X, ~2,'0X" r mask)
(setf (register r)
(logand (random 256 random-state) mask)))
-(define-opcode op-skp (_ r _ _) ;; SKP
+(define-opcode :E_9E op-skp (_ r _ _) ("SKP V~X" r)
(when (aref keys (register r))
(incf program-counter 2)))
-(define-opcode op-sknp (_ r _ _) ;; SKNP
+(define-opcode :E_A1 op-sknp (_ r _ _) ("SKNP V~X" r)
(when (not (aref keys (register r)))
(incf program-counter 2)))
-(define-opcode op-ld-mem<regs (_ n _ _) ;; LD [I] < Vn
+(define-opcode :F_55 op-ld-mem<regs (_ n _ _) ("LD [I], ~X" n)
(replace memory registers :start1 index :end2 (1+ n)))
-(define-opcode op-ld-regs<mem (_ n _ _) ;; LD Vn < [I]
+(define-opcode :F_65 op-ld-regs<mem (_ n _ _) ("LD ~X, [I]" n)
(replace registers memory :end1 (1+ n) :start2 index))
-(define-opcode op-ld-reg<key (_ r _ _) ;; LD Vx, Key (await)
+(define-opcode :F_0A op-ld-reg<key (_ r _ _) ("LD V~X, K" r)
;; I'm unsure how this instruction is supposed to interact with the timers.
;;
;; Either the timers should continue to count down while we wait for a key, or
@@ -500,27 +516,27 @@
;; If we don't have a key, just execute this instruction again next time.
(decf program-counter 2))))
-(define-opcode op-shr (_ r _ _) ;; SHR
+(define-opcode :8__6 op-shr (_ r _ _) ("SHR V~X" r)
(let ((value (register r)))
(setf flag (get-bit 0 value)
(register r) (ash value -1))))
-(define-opcode op-shl (_ r _ _) ;; SHL
+(define-opcode :8__E op-shl (_ r _ _) ("SHL V~X" r)
(let ((value (register r)))
(setf flag (get-bit 7 value)
(register r) (chop 8 (ash value 1)))))
-(define-opcode op-ld-font<vx (_ r _ _) ;; LD F, Vx
+(define-opcode :F_29 op-ld-font<vx (_ r _ _) ("LD F, V~X" r)
(setf index (font-location (register r))))
-(define-opcode op-ld-bcd<vx (_ r _ _) ;; LD B, Vx
+(define-opcode :F_33 op-ld-bcd<vx (_ r _ _) ("LD B, V~X" r)
(multiple-value-bind (hundreds tens ones)
(bcd (register r))
(setf (aref memory (+ index 0)) hundreds
(aref memory (+ index 1)) tens
(aref memory (+ index 2)) ones)))
-(define-opcode op-draw (_ rx ry size) ;; DRW Vx, Vy, size
+(define-opcode :D___ op-draw (_ rx ry size) ("DRW V~X, V~X, ~D" rx ry size)
(draw-sprite chip (register rx) (register ry) size))
@@ -644,50 +660,6 @@
(reset chip))
-(defun dispatch-instruction (chip instruction)
- (macrolet ((call (name) `(,name chip instruction)))
- (ecase (logand #xF000 instruction)
- (#x0000 (ecase instruction
- (#x00E0 (call op-cls))
- (#x00EE (call op-ret))))
- (#x1000 (call op-jp-imm))
- (#x2000 (call op-call))
- (#x3000 (call op-se-reg-imm))
- (#x4000 (call op-sne-reg-imm))
- (#x5000 (ecase (logand #x000F instruction)
- (#x0 (call op-se-reg-reg))))
- (#x6000 (call op-ld-reg<imm))
- (#x7000 (call op-add-reg<imm))
- (#x8000 (ecase (logand #x000F instruction)
- (#x0 (call op-ld-reg<reg))
- (#x1 (call op-or))
- (#x2 (call op-and))
- (#x3 (call op-xor))
- (#x4 (call op-add-reg<reg))
- (#x5 (call op-sub-reg<reg))
- (#x6 (call op-shr))
- (#x7 (call op-subn-reg<reg))
- (#xE (call op-shl))))
- (#x9000 (ecase (logand #x000F instruction)
- (#x0 (call op-sne-reg-reg))))
- (#xA000 (call op-ld-i<imm))
- (#xB000 (call op-jp-imm+reg))
- (#xC000 (call op-rand))
- (#xD000 (call op-draw))
- (#xE000 (ecase (logand #x00FF instruction)
- (#x9E (call op-skp))
- (#xA1 (call op-sknp))))
- (#xF000 (ecase (logand #x00FF instruction)
- (#x07 (call op-ld-reg<dt))
- (#x0A (call op-ld-reg<key))
- (#x15 (call op-ld-dt<reg))
- (#x18 (call op-ld-st<reg))
- (#x1E (call op-add-index<reg))
- (#x29 (call op-ld-font<vx))
- (#x33 (call op-ld-bcd<vx))
- (#x55 (call op-ld-mem<regs))
- (#x65 (call op-ld-regs<mem)))))))
-
(defun emulate-cycle (chip)
(with-chip (chip)
(debugger-print debugger chip)