# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1479991502 0
# Node ID 2e803dec5d585ef3f8e94df33b77d89912f7493f
# Parent  503bfe5cd173635960978e91c5d9e4fcd884d074
Attempt at a crazy DSL thing for opcodes.

diff -r 503bfe5cd173 -r 2e803dec5d58 .lispwords
--- a/.lispwords	Tue Nov 22 21:41:34 2016 +0000
+++ b/.lispwords	Thu Nov 24 12:45:02 2016 +0000
@@ -1,1 +1,2 @@
 (1 macro-map)
+(2 recompile-instruction-function)
diff -r 503bfe5cd173 -r 2e803dec5d58 cl-chip8.asd
--- a/cl-chip8.asd	Tue Nov 22 21:41:34 2016 +0000
+++ b/cl-chip8.asd	Thu Nov 24 12:45:02 2016 +0000
@@ -18,6 +18,7 @@
                :qtgui
                :qtools
                :qtopengl
+               :trivia
                )
 
   :serial t
diff -r 503bfe5cd173 -r 2e803dec5d58 package.lisp
--- a/package.lisp	Tue Nov 22 21:41:34 2016 +0000
+++ b/package.lisp	Thu Nov 24 12:45:02 2016 +0000
@@ -3,6 +3,7 @@
     :cl
     :losh
     :iterate
+    :trivia
     :cl-arrows
     :chip8.quickutils)
   (:export))
diff -r 503bfe5cd173 -r 2e803dec5d58 src/emulator.lisp
--- 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)