1 ;;; Code generation-related routines for m68k-assembler.
3 ;;; Julian Squires/2005
5 (in-package :m68k-assembler
)
7 ;;;; OPERAND CONSTRAINTS
10 ;; displacement-indirect w/o expression => vanilla-indirect
11 ;; register dX => data-register
12 ;; register aX => address-register
13 ;; indirect w/pc => pc-indexed or pc-displacement
15 (defun refine-type (operand modifier
)
17 ((eq (car operand
) 'displacement-indirect
)
18 (let ((displacement (indirect-displacement operand
'word
)))
19 (if (and (integerp displacement
) (zerop displacement
)
20 (address-register-p (indirect-base-register operand
)))
23 ((eq (car operand
) 'register
)
24 (case (char (caadr operand
) 0)
25 ((#\d
#\D
) 'data-register
)
26 ((#\a #\A
) 'address-register
)
28 ;; XXX: not sure if this is reasonable behavior, but it seems ok
30 ((eq (car operand
) 'absolute
)
32 ;(word 'absolute-short) (long 'absolute-long)
33 ;; default to absolute long, to avoid some gemdos
34 ;; relocation-related hassles. probably not the right thing to
39 (defun operand-type-matches-constraint-type-p (operand constraint modifier
)
40 (let ((refined-op (refine-type operand modifier
)))
41 (aif (find (car constraint
) *constraints-modes-table
* :key
#'car
)
42 (member refined-op
(second it
))
43 (eql refined-op
(car constraint
)))))
45 (defun satisfies-operand-constraints-p (operands constraints modifier
)
47 (lambda (op constraint
)
48 (and (operand-type-matches-constraint-type-p op constraint modifier
)
49 (operand-satisfies-value-constraints-p op
(cdr constraint
))))
50 operands constraints
))
52 (defun operand-satisfies-value-constraints-p (operand constraints
)
53 (every (lambda (constraint)
54 ;; bind value to the first string or whatever
55 (let* ((value (cond ((eq (first operand
) 'immediate
)
56 (resolve-expression (second operand
)))
57 ((eq (first operand
) 'register
)
58 (car (second operand
)))
59 (t (error "Dunno how to apply vconstraints to ~A." operand
))))
60 (subbed (subst value
'value constraint
)))
62 (apply (car subbed
) (cdr subbed
))
66 (defun satisfies-modifier-constraints-p (modifier mod-list
)
67 (cond ((null mod-list
) (null modifier
))
68 ((null modifier
) t
) ;; XXX for the moment
69 (t (member modifier mod-list
))))
72 (defun find-matching-entry (opcode operands modifier
)
74 (lambda (redirect) (find-matching-entry redirect operands modifier
))
77 (and (satisfies-modifier-constraints-p modifier
(caar entry
))
78 (satisfies-operand-constraints-p operands
(cdar entry
) modifier
)))
79 (cdr (get-asm-opcode opcode
))))
82 ;;;; CODE GENERATION HELPERS
84 ;;; Note that basically anything here wants to work with
85 ;;; pre-simplified parse trees.
87 (defun register-idx (operand &key both-sets
)
88 "If operand is a register or contains in some way a single register,
89 returns only the numeric index of that register, and the number of
90 bits that takes up, as a second value. Otherwise, an error is
94 (t (setf operand
(indirect-base-register operand
))))
96 (let ((idx (position (caadr operand
) *asm-register-table
*
97 :test
#'string-equal
:key
#'car
)))
98 (assert (<= 0 idx
15))
101 (values (logand idx
7) 3))))
103 (defun register-modifier (operand)
104 (assert (eql (car operand
) 'register
))
108 (defun data-register-p (operand)
109 (char-equal (char (caadr operand
) 0) #\D
))
110 (defun address-register-p (operand)
111 (char-equal (char (caadr operand
) 0) #\A
))
112 (defun pc-register-p (operand)
113 (string-equal (caadr operand
) "PC"))
115 (defun indirect-base-register (operand)
116 (find 'register
(cdr operand
) :key
#'carat
))
117 (defun indirect-index-register (operand)
118 (assert (eql (car operand
) 'indexed-indirect
))
119 (find 'register
(cdr operand
) :from-end t
:key
#'carat
))
120 (defun indirect-displacement (operand modifier
)
121 (let ((length (ecase modifier
(byte 8) (word 16))))
122 (cond ((= (length operand
) 2) 0)
123 ((and (consp (second operand
))
124 (eq (caadr operand
) 'register
)) 0)
125 (t (prog1 (resolve-expression (cadr operand
))
126 (fix-relocation-size length
))))))
128 (defun register-mask-list (operand &optional alterand
)
129 (let ((bitmask (make-array '(16) :element-type
'bit
:initial-element
0))
130 (flipped-p (and alterand
131 (eq (car alterand
) 'predecrement-indirect
))))
132 ;; iterate over operands
133 (dolist (r (if (eql (car operand
) 'register
)
136 (if (eql (car r
) 'register
)
137 (setf (aref bitmask
(register-idx r
:both-sets t
)) 1)
138 (warn "register-mask-list: ignoring ~A" r
)))
139 (values (bit-vector->int
(if flipped-p
(nreverse bitmask
) bitmask
))
142 (defun effective-address-mode (operand modifier
&key
(flipped-p nil
))
143 "Calculates the classic six-bit effective address mode and register
144 values. If FLIPPED-P, returns the mode and register values swapped."
145 (flet ((combine (m r
)
146 (logior (if flipped-p
(ash r
3) r
) (if flipped-p m
(ash m
3)))))
150 (cond ((data-register-p operand
) (combine 0 (register-idx operand
)))
151 ((address-register-p operand
)
152 (combine #b001
(register-idx operand
)))
153 ;; XXX I'm a bit iffy on this one, but so the book says...
154 ((string-equal (caadr operand
) "SR") (combine #b111
#b100
))))
155 (displacement-indirect
156 (let ((base (indirect-base-register operand
)))
157 (cond ((pc-register-p base
) (combine #b111
#b010
))
158 ((eql (refine-type operand modifier
) 'vanilla-indirect
)
159 (combine #b010
(register-idx base
)))
160 (t (combine #b101
(register-idx base
))))))
162 (let ((base (indirect-base-register operand
)))
163 (cond ((pc-register-p base
) (combine #b111
#b011
))
164 (t (combine #b110
(register-idx base
))))))
166 (ecase (refine-type operand modifier
)
167 (absolute-short (combine #b111
#b000
))
168 (absolute-long (combine #b111
#b001
))))
169 (immediate (combine #b111
#b100
))
170 (postincrement-indirect
171 (combine #b011
(register-idx (indirect-base-register operand
))))
172 (predecrement-indirect
173 (combine #b100
(register-idx (indirect-base-register operand
)))))
176 (defun effective-address-extra (operand modifier
)
177 "Returns the extra data required for addressing OPERAND, along with
178 the length of that data."
180 (register (values 0 0))
181 (displacement-indirect
182 (if (eql (refine-type operand modifier
) 'vanilla-indirect
)
184 (values (indirect-displacement operand
'word
) 16)))
186 (let ((index (indirect-index-register operand
)))
187 (if (not (pc-register-p (indirect-base-register operand
)))
188 ;; rrrr l000 dddd dddd
189 (let ((displacement (indirect-displacement operand
'byte
)))
190 (values (if (integerp displacement
)
191 (logior (ash (register-idx index
:both-sets t
) 12)
192 (if (aand (register-modifier index
)
195 (logand displacement
#xff
))
196 `(effective-address-extra ,operand
,modifier
))
198 (error "Not sure how to encode this!")))) ;XXX
200 (ecase (refine-type operand modifier
)
201 (absolute-short (values (absolute-value operand
'word
) 16))
202 (absolute-long (values (absolute-value operand
'long
) 32))))
203 ;; XXX test extent of value
204 (immediate (values (immediate-value operand
)
205 (if (eql modifier
'long
) 32 16)))
206 (postincrement-indirect (values 0 0))
207 (predecrement-indirect (values 0 0))))
209 ;; XXX this name sucks (too much like ABS)
210 (defun absolute-value (operand &optional
(modifier 'word
))
211 (let ((length (ecase modifier
(byte 8) (long 32) (word 16))))
212 (when (and (consp operand
) (eql (first operand
) 'absolute
))
213 (setf operand
(second operand
)))
214 (values (prog1 (resolve-expression operand
)
215 (fix-relocation-size length
))
218 ;;; XXX defaults to nil.
219 (defun absolute-definitely-needs-long-p (operand)
220 (let ((v (resolve-expression (second operand
))))
221 (and (integerp v
) (or (< v -
32768)
224 (defun immediate-value (operand &optional modifier
)
225 "Returns a certain number of bits from the immediate value of
226 OPERAND, based on MODIFIER, if specified."
227 ;; XXX default length is long?
228 (let ((length (case modifier
((byte word
) 16) (long 32) (t 32))))
229 (values (prog1 (resolve-expression (second operand
))
230 (fix-relocation-size length
))
233 (defun addq-immediate-value (operand &optional modifier
)
234 "Special hack for ADDQ/SUBQ. Returns OPERAND mod 8 and the rest as
235 per IMMEDIATE-VALUE."
236 (multiple-value-bind (v l
) (immediate-value operand modifier
)
237 (values (if (integerp v
) (mod v
8) v
) l
)))
239 (defun modifier-bits (modifier)
240 (values (ecase modifier
(byte #b00
) (word #b01
) (long #b10
)) 2))
242 (defun modifier-bits-for-move (modifier)
243 (values (ecase modifier
(byte #b01
) (word #b11
) (long #b10
)) 2))
246 (defun branch-displacement-bits (operand modifier
&key db-p
)
247 "Returns displacement of OPERAND relative to *PROGRAM-COUNTER*. If
248 :DB-P is T, calculate displacement as per the DBcc opcodes (always
249 16-bit). Otherwise, calculate displacement as per Bcc opcodes, where
250 displacement is either 8 bits or 16 padded to 24."
251 ;; Note PC+2 -- this is due to the way the m68k fetches
253 (let* ((*program-counter
* (if (oddp *program-counter
*)
254 (1+ *program-counter
*)
256 (value (absolute-value operand
(or modifier
'word
)))
257 (length (cond (db-p 16)
258 ((eq modifier
'byte
) 8)
260 ;; if there's a reloc at this pc, change to pc-relative
261 (pc-relativise-relocation)
262 (fix-relocation-size (if (= length
24) 16 length
))
264 (values (if (integerp value
)
265 (logand (- value
*program-counter
*) #xffff
)
270 ;;;; TEMPLATE EVALUATOR
273 (defun make-codegen-sublis (operands modifier
)
274 ;; Adjust as necessary for the number of operands possible.
276 '(modifier first-operand second-operand
)
277 (cons modifier operands
)))
279 (defun fill-codegen-template (list)
280 (do* ((item-> list
(cdr item-
>))
281 (fake-pc *program-counter
* (+ fake-pc
(/ length
8)))
282 (length (caar item-
>) (caar item-
>))
283 (formula (cadar item-
>) (cadar item-
>))
285 ((null item-
>) done-p
)
286 (when (consp formula
)
287 ;; We don't floor fake-pc because it should point out
288 ;; interesting bugs if we ever have to make use of it when it's
290 (let ((*program-counter
* fake-pc
))
291 (multiple-value-bind (val val-len
) (apply (car formula
)
293 (unless (integerp length
)
294 (setf length val-len
) ; for fake-pc
295 (setf (caar item-
>) val-len
))
296 ;; XXX shouldn't have to comment this out, but I do due to
297 ;; silly immediate-value hacks.
298 ;;(when (integerp val-len) (assert (= (caar item->) val-len)))
300 (setf (cadar item-
>) val
)
301 (setf done-p nil
)))))))
303 ;;; first do the sublis, then walk through each item doing the
304 ;;; evaluation when we can. if everything's reduced to an atom,
305 ;;; compile it and return it. otherwise, return the half-completed
308 ;; if the first is an integer, add it to the result-length. if the
309 ;; second is an atom, or it into the result. if the second is a list,
310 ;; evaluate it with first-operand, second-operand, and modifier bound.
312 (defun generate-code (template operands modifier
)
315 (list (sublis (make-codegen-sublis operands modifier
) template
)))
317 (cond ((fill-codegen-template list
)
319 (destructuring-bind (len val
) item
320 (setf result
(logior (ldb (byte len
0) val
)
322 (incf result-len len
)))
323 (values result result-len
))
324 (t (dolist (item list
) (incf result-len
(first item
)))
325 (values list result-len
)))))
327 ;;;; EOF codegen.lisp