-
Notifications
You must be signed in to change notification settings - Fork 8
/
6502-utils.lisp
174 lines (145 loc) · 5.76 KB
/
6502-utils.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
(in-package :asm6502-utility)
(defconstant +nmi-vector+ #xFFFA)
(defconstant +reset-vector+ #xFFFC)
(defconstant +irq-vector+ #xFFFE)
;;;; Small utilities
(defun poke (value address)
(when (typep value '(or integer promise))
(setf value (imm value)))
(lda value)
(sta (typecase address
((integer 0 255) (zp address))
((or integer promise) (mem address))
(t address))))
;;; 16-Bit Values / Variables
(defstruct (wordvar (:constructor wordvar (address))) address)
(defmethod lsb ((of wordvar))
(etypecase (wordvar-address of)
((integer 0 255) (zp (wordvar-address of)))
(t (wordvar-address of))))
(defmethod msb ((of wordvar))
(etypecase (wordvar-address of)
((integer 0 255) (zp (1+ (wordvar-address of))))
(promise (mem (delay :msb-of-wordvar ((address (wordvar-address of))) (1+ address))))))
(defmethod asm6502::assemble ((opcode (eql 'JMP))
(of wordvar))
(asm6502::assemble 'JMP (indirect (wordvar-address of))))
(defstruct (wordval (:constructor wordval (value))) value)
(defmethod lsb ((of wordval)) (imm (lsb (wordval-value of))))
(defmethod msb ((of wordval)) (imm (msb (wordval-value of))))
(defun pushword (value)
(when (typep value '(or integer promise))
(setf value (wordval value)))
(lda (msb value))
(pha)
(lda (lsb value))
(pha))
(defgeneric pokeword (value address))
(defmethod pokeword (value (address integer))
(poke (lsb value) address)
(poke (msb value) (1+ address)))
(defmethod pokeword (value (address promise))
(pokeword (lsb value) address)
(pokeword (msb value) (delay :pokeword-addr-msb (address) (1+ address))))
(defmethod pokeword (value (address wordvar))
(poke (lsb value) (lsb address))
(poke (msb value) (msb address)))
;;;; Control structures
;;; Assemble an if-then-else construct. The 'branch-compiler' is invoked
;;; to generate conditional branch to the else clause. If the 'else-compiler'
;;; is omitted, the jump following the "then" clause will be optimized away.
(defgeneric condition-to-branch (condition)
(:documentation "Return a function capable of generating a branch to
the given argument if the condition is *NOT* true." ))
(defmethod condition-to-branch ((condition symbol))
(or
(cdr
(assoc condition
'((:positive . bmi)
(:negative . bpl)
(:carry . bcc)
(:no-carry . bcs)
(:zero . bne)
(:not-zero . beq)
(:equal . bne)
(:not-equal . beq)
(:overflow . bvc)
(:no-overflow . bvs))))
(error "Unknown condition ~A" condition)))
(defun assemble-if (branch-compiler then-compiler &optional else-compiler)
(let ((else-sym (gensym "ELSE"))
(finally-sym (gensym "FINALLY")))
(funcall branch-compiler (rel else-sym))
(funcall then-compiler)
(when else-compiler (jmp (mem (label finally-sym))))
(set-label else-sym)
(when else-compiler (funcall else-compiler))
(set-label finally-sym)))
(defmacro asif (condition &body statements)
(let ((then statements)
(else nil)
(part (position :else statements)))
(when part
(setf then (subseq statements 0 part)
else (subseq statements (1+ part) nil)))
`(assemble-if
',(condition-to-branch condition)
(lambda () ,@then)
,(and else `(lambda () ,@else)))))
(defmacro as/until (condition &body body)
(let ((sym (gensym)))
`(with-label ,sym
,@body
(funcall (condition-to-branch ',condition) (rel ',sym)))))
(defmacro with-label (label &body body)
(when (and (listp label) (eql (first label) 'quote))
(warn "Quoted label name ~A, probably not what you intended" label))
`(progn (set-label ',label) ,@body))
(defmacro procedure (name &body body)
`(progn
(set-label ',name)
(let ((*context* (make-instance 'local-context :parent *context*)))
,@body)))
;;; Delays and timed sections
(defun emit-delay (delay-cycles)
"Emit a delay of the specified number of CPU cycles. Kills the X register."
(loop while (>= delay-cycles 11)
as iterations = (min 256 (floor (- delay-cycles 5) 5))
as n = (mod iterations 256) do
#+NIL
(format t "~&Inserting delay loop (~A cycles left), ~A iterations (should burn ~A cycles)~%"
delay-cycles iterations (1+ (* 5 iterations)))
(decf delay-cycles)
(ldx (imm n))
(unless (<= (lsb *origin*) 253) ; I could work around this..
(error "Can't assemble a timed loop on a page crossing. Sorry."))
(as/until :zero (dex))
(decf delay-cycles (* 5 iterations)))
(when (= 1 delay-cycles)
(error "Not possible to delay for 1 cycle."))
(when (oddp delay-cycles)
;;(format t "~&~A cycles to burn -- Inserting LDY instruction.~%" delay-cycles)
(ldx (imm 0))
(decf delay-cycles 3))
(loop while (>= delay-cycles 6) do
(ldx (imm 0))
(ldx (imm 0))
(decf delay-cycles 6))
(unless (zerop delay-cycles)
;;(format t "~&~A cycles to burn -- Inserting ~A NOPs~%" delay-cycles (/ delay-cycles 2))
(dotimes (i (/ delay-cycles 2)) (nop) (decf delay-cycles 2)))
(assert (zerop delay-cycles)))
(defmacro timed-section ((cycle-count &key loop) &body body)
`(let ((timed-section-head (set-label (gensym)))
(cycles (counting-cycles ,@body))
(cycle-count ,cycle-count)
(loop-p ,loop))
(when loop-p (decf cycle-count 3))
(unless (> cycle-count 0)
(error "Cycle count for timed section is too small."))
(unless (>= ,cycle-count cycles)
(error "Timed section takes ~D cycles, which is longer than ~D cycles."
cycles ,cycle-count))
(emit-delay (- cycle-count cycles))
(when loop-p (jmp (mem timed-section-head)))
(values)))