/
emulator.lisp
555 lines (458 loc) · 18.2 KB
/
emulator.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
(in-package :chip8)
(declaim (optimize (speed 3) (safety 0) (debug 0)))
; (declaim (optimize (speed 3) (safety 1) (debug 2)))
;;;; Constants ----------------------------------------------------------------
(defconstant +cycles-per-second+ 500)
(defconstant +cycles-before-sleep+ 10)
(defconstant +screen-width+ 64)
(defconstant +screen-height+ 32)
(defconstant +memory-size+ (* 1024 4))
;;;; Types --------------------------------------------------------------------
(deftype int4 () '(unsigned-byte 4))
(deftype int8 () '(unsigned-byte 8))
(deftype int12 () '(unsigned-byte 12))
(deftype int16 () '(unsigned-byte 16))
;;;; Utils --------------------------------------------------------------------
(defun-inline not= (x y)
(not (= x y)))
(defun-inline chop (size integer)
(ldb (byte size 0) integer))
(defun-inline cat-bytes (high-order low-order)
(dpb high-order (byte 8 8) low-order))
(defun-inline get-bit (position integer)
(ldb (byte 1 position) integer))
(defun-inline +_8 (x y)
(let ((result (+ x y)))
(values (chop 8 result)
(if (> result 255) 1 0))))
(defun-inline -_8 (x y)
(let ((result (- x y)))
(values (chop 8 result)
(if (> x y) 1 0))))
(defun-inline >>_8 (v)
(values (ash v -1)
(get-bit 0 v)))
(defun-inline <<_8 (v)
(values (chop 8 (ash v 1))
(get-bit 7 v)))
(defmacro macro-map (lambda-list items &rest body)
(with-gensyms (macro)
`(macrolet ((,macro ,(ensure-list lambda-list) ,@body))
,@(iterate (for item :in items)
(collect `(,macro ,@(ensure-list item)))))))
;;;; Data ---------------------------------------------------------------------
(defstruct chip
(running t :type boolean)
(memory (make-array +memory-size+ :element-type 'int8)
:type (simple-array int8 (#.+memory-size+))
:read-only t)
(registers (make-array 16 :element-type 'int8)
:type (simple-array int8 (16))
:read-only t)
(index 0 :type int16)
(program-counter #x200 :type int12)
(keys (make-array 16 :element-type 'boolean :initial-element nil)
:type (simple-array boolean (16))
:read-only t)
(video (make-array (* +screen-height+ +screen-width+) :element-type 'fixnum)
:type (simple-array fixnum (#.(* +screen-height+ +screen-width+)))
:read-only t)
(video-dirty t :type boolean)
(screen-wrapping-enabled t :type boolean)
(delay-timer 0 :type fixnum)
(sound-timer 0 :type fixnum)
(sound-type :sine :type keyword)
(stack (make-array 16 :element-type 'int12 :fill-pointer 0)
:type (vector int12 16)
:read-only t)
(loaded-rom nil :type (or null string))
(debugger (make-debugger) :type debugger :read-only t))
(define-with-macro chip
running
memory
registers flag index program-counter
delay-timer sound-timer
video video-dirty screen-wrapping-enabled
sound-type
keys
stack
loaded-rom
debugger)
(defun-inline chip-flag (chip)
(aref (chip-registers chip) #xF))
(defun-inline (setf chip-flag) (new-value chip)
(setf (aref (chip-registers chip) #xF) new-value))
;;;; Graphics -----------------------------------------------------------------
(defun-inline vref (chip x y)
(aref (chip-video chip) (+ (* +screen-width+ y) x)))
(defun-inline (setf vref) (new-value chip x y)
(setf (aref (chip-video chip) (+ (* +screen-width+ y) x))
new-value))
(defun load-font (chip)
;; Thanks http://www.multigesture.net/articles/how-to-write-an-emulator-chip-8-interpreter/
(replace (chip-memory chip)
#(#xF0 #x90 #x90 #x90 #xF0 ; 0
#x20 #x60 #x20 #x20 #x70 ; 1
#xF0 #x10 #xF0 #x80 #xF0 ; 2
#xF0 #x10 #xF0 #x10 #xF0 ; 3
#x90 #x90 #xF0 #x10 #x10 ; 4
#xF0 #x80 #xF0 #x10 #xF0 ; 5
#xF0 #x80 #xF0 #x90 #xF0 ; 6
#xF0 #x10 #x20 #x40 #x40 ; 7
#xF0 #x90 #xF0 #x90 #xF0 ; 8
#xF0 #x90 #xF0 #x10 #xF0 ; 9
#xF0 #x90 #xF0 #x90 #x90 ; A
#xE0 #x90 #xE0 #x90 #xE0 ; B
#xF0 #x80 #x80 #x80 #xF0 ; C
#xE0 #x90 #x90 #x90 #xE0 ; D
#xF0 #x80 #xF0 #x80 #xF0 ; E
#xF0 #x80 #xF0 #x80 #x80) ; F
:start1 #x50))
(defun-inline font-location (character)
(+ #x50 (* character 5)))
(defun-inline wrap (chip x y)
(cond
((chip-screen-wrapping-enabled chip)
(values (mod x +screen-width+)
(mod y +screen-height+)
t))
((and (in-range-p 0 x +screen-width+)
(in-range-p 0 y +screen-height+))
(values x y t))
(t (values nil nil nil))))
(defun draw-sprite (chip start-x start-y size)
(with-chip (chip)
(setf flag 0)
(iterate (repeat size)
(for i :from index)
(for y :from start-y)
(for sprite = (aref memory i))
(iterate
(for x :from start-x)
(for col :from 7 :downto 0)
(multiple-value-bind (x y draw) (wrap chip x y)
(when draw
(for old-pixel = (plusp (vref chip x y)))
(for new-pixel = (plusp (get-bit col sprite)))
(when (and old-pixel new-pixel)
(setf flag 1))
(setf (vref chip x y)
(if (xor old-pixel new-pixel) 255 0))))))
(setf video-dirty t))
nil)
;;;; Keyboard -----------------------------------------------------------------
(defun keydown (chip key)
(setf (aref (chip-keys chip) key) t))
(defun keyup (chip key)
(setf (aref (chip-keys chip) key) nil))
;;;; Instructions -------------------------------------------------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun parse-instruction-argument-bindings (argument-list)
(flet ((normalize-arg (arg)
(destructuring-bind (symbol &optional (nibbles 1))
(ensure-list arg)
(list symbol nibbles))))
(iterate
(for (symbol nibbles) :in (mapcar #'normalize-arg argument-list))
(for position :first 3 :then (- position nibbles))
(when (not (eql symbol '_))
(collect `(,symbol (ldb (byte ,(* nibbles 4)
,(* position 4))
instruction))))))))
(defmacro define-instruction (name argument-list &body body)
`(progn
(declaim (ftype (function (chip int16)
(values null &optional))
,name))
(defun ,name (chip instruction)
(declare (ignorable instruction))
(with-chip (chip)
(macrolet ((register (index)
`(aref registers ,index)))
(let ,(parse-instruction-argument-bindings argument-list)
,@body))
nil))))
(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-instruction ,name ,arglist
(setf ,destination ,source)))
(define-instruction op-cls () ;; CLS
(fill video 0)
(setf video-dirty t))
(define-instruction op-jp-imm (_ (target 3)) ;; JP addr
(setf program-counter target))
(define-instruction op-jp-imm+reg (_ (target 3)) ;; JP V0 + addr
(setf program-counter (chop 12 (+ target (register 0)))))
(define-instruction op-call (_ (target 3)) ;; CALL addr
(vector-push program-counter stack)
(setf program-counter target))
(define-instruction op-ret () ;; RET
(setf program-counter (vector-pop stack)))
(define-instruction op-add-reg<imm (_ r (immediate 2)) ;; ADD Vx, Imm
;; For some weird reason the ADD immediate op doesn't set the flag
(zapf (register r) (+_8 % immediate)))
(define-instruction op-add-reg<reg (_ rx ry) ;; ADD Vx, Vy (8-bit)
(setf (values (register rx) flag)
(+_8 (register rx) (register ry))))
(define-instruction op-sub-reg<reg (_ rx ry) ;; SUB Vx, Vy (8-bit)
(setf (values (register rx) flag)
(-_8 (register rx) (register ry))))
(define-instruction op-add-index<reg (_ r) ;; ADD I, Vx (16-bit)
(zapf index (chop 16 (+ % (register r)))))
(define-instruction op-subn-reg<reg (_ rx ry) ;; SUBN Vx, Vy (8-bit)
(setf (values (register rx) flag)
;; subtraction order is swapped for SUBN
(-_8 (register ry) (register rx))))
(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-instruction ,name (_ ,x-arg ,y-arg)
(when (,test ,x-form ,y-form)
(incf program-counter 2))))
(macro-map ;; AND/OR/XOR
(NAME OP)
((op-and logand)
(op-or logior)
(op-xor logxor))
`(define-instruction ,name (_ destination source _)
(zapf (register destination) (,op % (register source)))))
(define-instruction op-rand (_ r (mask 2)) ;; RND
(setf (register r)
(logand (random 256) mask)))
(define-instruction op-skp (_ r _ _) ;; SKP
(when (aref keys (register r))
(incf program-counter 2)))
(define-instruction op-sknp (_ r _ _) ;; SKNP
(when (not (aref keys (register r)))
(incf program-counter 2)))
(define-instruction op-ld-mem<regs (_ n _ _) ;; LD [I] < Vn
(replace memory registers :start1 index :end2 (1+ n)))
(define-instruction op-ld-regs<mem (_ n _ _) ;; LD Vn < [I]
(replace registers memory :end1 (1+ n) :start2 index))
(define-instruction op-ld-reg<key (_ r _ _) ;; LD Vx, Key (await)
;; 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
;; they should pause while waiting, but I can't find anything in the docs that
;; spells it out.
;;
;; This implementation chooses the former (timers keep running) for now.
(let ((key (position t keys)))
(if key
(setf (register r) key)
;; If we don't have a key, just execute this instruction again next time.
(decf program-counter 2))))
(define-instruction op-shr (_ r _ _) ;; SHR
(setf (values (register r) flag)
(>>_8 (register r))))
(define-instruction op-shl (_ r _ _) ;; SHL
(setf (values (register r) flag)
(<<_8 (register r))))
(define-instruction op-ld-font<vx (_ r _ _) ;; LD F, Vx
(setf index (font-location (register r))))
(define-instruction op-ld-bcd<vx (_ r _ _) ;; LD B, Vx
(let ((number (register r)))
(setf (aref memory (+ index 0)) (digit 2 number)
(aref memory (+ index 1)) (digit 1 number)
(aref memory (+ index 2)) (digit 0 number))))
(define-instruction op-draw (_ rx ry size) ;; DRW Vx, Vy, size
(draw-sprite chip (register rx) (register ry) size))
;;;; Sound --------------------------------------------------------------------
(defconstant +pi+ (coerce pi 'single-float))
(defconstant +tau+ (* 2 +pi+))
(defconstant +1/4tau+ (* 1/4 +tau+))
(defconstant +1/2tau+ (* 1/2 +tau+))
(defconstant +3/4tau+ (* 3/4 +tau+))
(defconstant +sample-rate+ 44100d0)
(defconstant +audio-buffer-size+ 512
"The number of samples in the audio buffer.")
(defconstant +audio-buffer-time+ (* +audio-buffer-size+ (/ +sample-rate+))
"The total time the information in the audio buffer represents, in seconds.")
(defun sqr (angle)
(if (< (mod angle +tau+) +1/2tau+)
1.0
-1.0))
(defun saw (angle)
(let ((a (mod angle +tau+)))
(if (< a +1/2tau+)
(map-range 0 +1/2tau+
0.0 1.0
a)
(map-range +1/2tau+ +tau+
-1.0 0.0
a))))
(defun tri (angle)
(let ((a (mod angle +tau+)))
(if (< a +1/2tau+)
(map-range 0 +1/2tau+
-1.0 1.0
a)
(map-range +1/2tau+ +tau+
1.0 -1.0
a))))
(defun make-audio-buffer ()
(make-array +audio-buffer-size+
:element-type 'single-float
:initial-element 0.0))
(defun fill-buffer (buffer function rate start)
(iterate
(for i :index-of-vector buffer)
(for angle :from start :by rate)
(setf (aref buffer i) (funcall function angle))
(finally (return (mod angle +tau+)))))
(defun fill-square (buffer rate start)
(fill-buffer buffer #'sqr rate start))
(defun fill-sine (buffer rate start)
(fill-buffer buffer #'sin rate start))
(defun fill-sawtooth (buffer rate start)
(fill-buffer buffer #'saw rate start))
(defun fill-triangle (buffer rate start)
(fill-buffer buffer #'tri rate start))
(defun audio-buffer-filler (chip)
(ecase (chip-sound-type chip)
(:square #'fill-square)
(:sine #'fill-sine)
(:sawtooth #'fill-sawtooth)
(:triangle #'fill-triangle)))
(defun audio-rate (frequency)
(coerce (* (/ +tau+ +sample-rate+) frequency) 'single-float))
(defun run-sound (chip)
(portaudio:with-audio
(portaudio:with-default-audio-stream
(audio-stream 0 1
:sample-format :float
:sample-rate +sample-rate+
:frames-per-buffer +audio-buffer-size+)
(with-chip (chip)
(iterate (with buffer = (make-audio-buffer))
(with angle = 0.0)
(with rate = (audio-rate 440))
(while running)
(if (and (plusp sound-timer)
(not (debugger-paused-p debugger)))
(progn
(setf angle (funcall (audio-buffer-filler chip)
buffer rate angle))
(portaudio:write-stream audio-stream buffer))
(sleep +audio-buffer-time+))))))
nil)
;;;; Timers -------------------------------------------------------------------
(defun decrement-timers (chip)
(flet ((decrement (i)
(if (plusp i)
(1- i)
0)))
(with-chip (chip)
(sb-ext:atomic-update delay-timer #'decrement)
(sb-ext:atomic-update sound-timer #'decrement)))
nil)
(defun run-timers (chip)
(with-chip (chip)
(iterate
(while running)
(when (not (debugger-paused-p debugger))
(decrement-timers chip))
(sleep 1/60))))
;;;; CPU ----------------------------------------------------------------------
(defun reset (chip)
(with-chip (chip)
(fill memory 0)
(fill registers 0)
(fill keys nil)
(fill video 0)
(load-font chip)
(replace memory (read-file-into-byte-vector loaded-rom)
:start1 #x200)
(setf running t
video-dirty t
program-counter #x200
delay-timer 0
sound-timer 0
(fill-pointer stack) 0))
(values))
(defun load-rom (chip filename)
(setf (chip-loaded-rom chip) filename)
(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-arrive debugger chip)
(if (debugger-check-wait debugger program-counter)
(sleep 10/1000)
(let ((instruction (cat-bytes (aref memory program-counter)
(aref memory (1+ program-counter)))))
(zapf program-counter (chop 12 (+ % 2)))
(dispatch-instruction chip instruction)))
nil))
(defun run-cpu (chip)
(iterate
(while (chip-running chip))
(emulate-cycle chip)
(for tick :every-nth +cycles-before-sleep+ :do
(sleep (/ +cycles-before-sleep+ +cycles-per-second+)))))
;;;; Main ---------------------------------------------------------------------
(defparameter *c* nil)
(defun run (rom-filename &key start-paused)
(let ((chip (make-chip)))
(setf *c* chip)
(load-rom chip rom-filename)
(when start-paused
(debugger-pause (chip-debugger chip)))
(chip8.gui.screen::run-gui
chip
(lambda ()
;; Really it's just the sound that needs to be here...
(bt:make-thread (curry #'run-cpu chip))
(bt:make-thread (curry #'run-timers chip))
(bt:make-thread (curry #'run-sound chip))))))