--- a/cl-chip8.asd Fri Dec 16 14:42:58 2016 -0500
+++ b/cl-chip8.asd Fri Dec 16 14:49:23 2016 -0500
@@ -26,7 +26,8 @@
(:file "quickutils")))
(:file "package")
(:module "src" :serial t
- :components ((:file "emulator")
+ :components ((:file "debugger")
+ (:file "emulator")
(:module "gui" :serial t
:components ((:file "debugger")
(:file "screen")))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/debugger.lisp Fri Dec 16 14:49:23 2016 -0500
@@ -0,0 +1,181 @@
+(in-package :chip8)
+
+;;;; Data ---------------------------------------------------------------------
+(defstruct debugger
+ (paused nil :type boolean)
+ (take-step nil :type boolean)
+ (print-needed nil :type boolean)
+ (callbacks-arrived nil :type list)
+ (breakpoints nil :type list))
+
+(define-with-macro debugger
+ paused take-step print-needed
+ callbacks-arrived)
+
+
+;;;; 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)))))))))
+
+(defun bit-diagram (integer)
+ (iterate (for high-bit :from 15 :downto 8)
+ (for low-bit :from 7 :downto 0)
+ (for hi = (logbitp high-bit integer))
+ (for lo = (logbitp low-bit integer))
+ (collect (cond
+ ((and hi lo) #\full_block)
+ (hi #\upper_half_block)
+ (lo #\lower_half_block)
+ (t #\space))
+ :result-type 'string)))
+
+(defun retrieve-instruction (array index)
+ (cat-bytes
+ ;; ugly hacks to handle odd parity
+ (if (minusp index)
+ 0
+ (aref array index))
+ (if (< (1+ index) (length array))
+ (aref array (1+ index))
+ 0)))
+
+(defun instruction-information (array index)
+ (let ((instruction (retrieve-instruction array index)))
+ (list index
+ instruction
+ (disassemble-instruction instruction)
+ (bit-diagram instruction))))
+
+(defun print-disassembled-instruction (array index)
+ (destructuring-bind (address instruction disassembly bits)
+ (instruction-information array index)
+ (format t "~3,'0X: ~4,'0X ~24A ~8A~%"
+ address
+ instruction
+ (or disassembly "")
+ bits)))
+
+(defun disassemble-instructions (array start)
+ (iterate
+ (for i :from start :below (length array) :by 2)
+ (collect (instruction-information array i) :result-type vector)))
+
+(defun dump-disassembly (array &optional (start 0) (end (length array)))
+ (iterate
+ (for i :from start :below end :by 2)
+ (print-disassembled-instruction array i)
+ (sleep 0.001)))
+
+
+;;;; Debugger -----------------------------------------------------------------
+(defun debugger-pause (debugger)
+ (with-debugger (debugger)
+ (setf paused t print-needed t)))
+
+(defun debugger-unpause (debugger)
+ (with-debugger (debugger)
+ (setf paused nil print-needed nil)))
+
+(defun debugger-toggle-pause (debugger)
+ (if (debugger-paused debugger)
+ (debugger-unpause debugger)
+ (debugger-pause debugger)))
+
+(defun debugger-step (debugger)
+ (with-debugger (debugger)
+ (setf take-step t)))
+
+(defun debugger-print (debugger chip)
+ (with-debugger (debugger)
+ (when (and paused print-needed)
+ (let ((pc (chip-program-counter chip)))
+ (setf print-needed nil)
+ (destructuring-bind (address instruction disassembly bits)
+ (instruction-information (chip-memory chip) pc)
+ (format t "~3,'0X: ~4,'0X ~24A ~8A~%"
+ address
+ instruction
+ (or disassembly "")
+ bits))
+ (mapc (rcurry #'funcall pc) callbacks-arrived))))
+ (values))
+
+(defun debugger-paused-p (debugger)
+ (debugger-paused debugger))
+
+(defun debugger-check-breakpoints (debugger address)
+ (let ((result (member address (debugger-breakpoints debugger))))
+ (if result
+ (progn (debugger-pause debugger)
+ t)
+ nil)))
+
+(defun debugger-should-wait-p (debugger address)
+ (with-debugger (debugger)
+ (if (not paused)
+ ;; If we're not paused, we just need to check for breakpoints
+ (debugger-check-breakpoints debugger address)
+ ;; Otherwise we're paused
+ (if take-step
+ (progn (setf take-step nil ; if we're paused, but are ready to step, go
+ print-needed t)
+ nil)
+ t)))) ; otherwise we're fully paused -- wait
+
+(defun debugger-add-breakpoint (debugger address)
+ (pushnew address (debugger-breakpoints debugger)))
+
+(defun debugger-remove-breakpoint (debugger address)
+ (removef (debugger-breakpoints debugger) address))
+
+(defun debugger-add-callback-arrived (debugger function)
+ (push function (debugger-callbacks-arrived debugger))
+ t)
+
+
--- a/src/emulator.lisp Fri Dec 16 14:42:58 2016 -0500
+++ b/src/emulator.lisp Fri Dec 16 14:49:23 2016 -0500
@@ -70,13 +70,6 @@
(declaim
(inline chip-flag (setf chip-flag)))
-(defstruct debugger
- (paused nil :type boolean)
- (take-step nil :type boolean)
- (print-needed nil :type boolean)
- (callbacks-arrived nil :type list)
- (breakpoints nil :type list))
-
(defstruct chip
(running t :type boolean)
(memory (make-array +memory-size+ :element-type 'int8)
@@ -114,10 +107,6 @@
loaded-rom
debugger)
-(define-with-macro debugger
- paused take-step print-needed
- callbacks-arrived)
-
(defun chip-flag (chip)
(aref (chip-registers chip) #xF))
@@ -126,172 +115,6 @@
(setf (aref (chip-registers chip) #xF) new-value))
-;;;; 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)))))))))
-
-(defun bit-diagram (integer)
- (iterate (for high-bit :from 15 :downto 8)
- (for low-bit :from 7 :downto 0)
- (for hi = (logbitp high-bit integer))
- (for lo = (logbitp low-bit integer))
- (collect (cond
- ((and hi lo) #\full_block)
- (hi #\upper_half_block)
- (lo #\lower_half_block)
- (t #\space))
- :result-type 'string)))
-
-(defun retrieve-instruction (array index)
- (chip8::cat-bytes
- ;; ugly hacks to handle odd parity
- (if (minusp index)
- 0
- (aref array index))
- (if (< (1+ index) (length array))
- (aref array (1+ index))
- 0)))
-
-(defun instruction-information (array index)
- (let ((instruction (retrieve-instruction array index)))
- (list index
- instruction
- (disassemble-instruction instruction)
- (bit-diagram instruction))))
-
-(defun print-disassembled-instruction (array index)
- (destructuring-bind (address instruction disassembly bits)
- (instruction-information array index)
- (format t "~3,'0X: ~4,'0X ~24A ~8A~%"
- address
- instruction
- (or disassembly "")
- bits)))
-
-(defun disassemble-instructions (array start)
- (iterate
- (for i :from start :below (length array) :by 2)
- (collect (instruction-information array i) :result-type vector)))
-
-(defun dump-disassembly (array &optional (start 0) (end (length array)))
- (iterate
- (for i :from start :below end :by 2)
- (print-disassembled-instruction array i)
- (sleep 0.001)))
-
-
-;;;; Debugger -----------------------------------------------------------------
-(defun debugger-pause (debugger)
- (with-debugger (debugger)
- (setf paused t print-needed t)))
-
-(defun debugger-unpause (debugger)
- (with-debugger (debugger)
- (setf paused nil print-needed nil)))
-
-(defun debugger-toggle-pause (debugger)
- (if (debugger-paused debugger)
- (debugger-unpause debugger)
- (debugger-pause debugger)))
-
-(defun debugger-step (debugger)
- (with-debugger (debugger)
- (setf take-step t)))
-
-(defun debugger-print (debugger chip)
- (with-debugger (debugger)
- (when (and paused print-needed)
- (let ((pc (chip-program-counter chip)))
- (setf print-needed nil)
- (destructuring-bind (address instruction disassembly bits)
- (instruction-information (chip-memory chip) pc)
- (format t "~3,'0X: ~4,'0X ~24A ~8A~%"
- address
- instruction
- (or disassembly "")
- bits))
- (mapc (rcurry #'funcall pc) callbacks-arrived))))
- (values))
-
-(defun debugger-paused-p (debugger)
- (debugger-paused debugger))
-
-(defun debugger-check-breakpoints (debugger address)
- (let ((result (member address (debugger-breakpoints debugger))))
- (if result
- (progn (debugger-pause debugger)
- t)
- nil)))
-
-(defun debugger-should-wait-p (debugger address)
- (with-debugger (debugger)
- (if (not paused)
- ;; If we're not paused, we just need to check for breakpoints
- (debugger-check-breakpoints debugger address)
- ;; Otherwise we're paused
- (if take-step
- (progn (setf take-step nil ; if we're paused, but are ready to step, go
- print-needed t)
- nil)
- t)))) ; otherwise we're fully paused -- wait
-
-(defun debugger-add-breakpoint (debugger address)
- (pushnew address (debugger-breakpoints debugger)))
-
-(defun debugger-remove-breakpoint (debugger address)
- (removef (debugger-breakpoints debugger) address))
-
-(defun debugger-add-callback-arrived (debugger function)
- (push function (debugger-callbacks-arrived debugger))
- t)
-
-
;;;; Graphics -----------------------------------------------------------------
(declaim
(inline font-location vref (setf vref))