codegen.lisp

   1 ;;; Code generation-related routines for m68k-assembler.
   2 ;;;
   3 ;;; Julian Squires/2005
   4
   5 (in-package :m68k-assembler)
   6
   7 ;;;; OPERAND CONSTRAINTS
   8
   9 (defparameter *all-ea-modes*
  10   '(immediate pc-index pc-displacement absolute-long absolute-short
  11     postincrement-indirect predecrement-indirect displacement-indirect
  12     indexed-indirect vanilla-indirect address-register data-register))
  13
  14 (defparameter *constraints-modes-table*
  15   `((all-ea-modes ,*all-ea-modes*)
  16     (alterable-modes ,(set-difference *all-ea-modes*
  17      '(immediate pc-index pc-displacement)))
  18     (data-alterable-modes ,(set-difference *all-ea-modes*
  19      '(immediate pc-index pc-displacement address-register)))
  20     (memory-alterable-modes ,(set-difference *all-ea-modes*
  21      '(immediate pc-index pc-displacement address-register data-register)))
  22     (data-addressing-modes ,(set-difference *all-ea-modes*
  23                                             '(address-register)))
  24     (control-addressing-modes ,(set-difference *all-ea-modes*
  25      '(address-register data-register immediate predecrement-indirect
  26        postincrement-indirect)))
  27     (movem-pre-modes (vanilla-indirect predecrement-indirect
  28                       displacement-indirect indexed-indirect absolute-short
  29                       absolute-long))
  30     (movem-post-modes (vanilla-indirect postincrement-indirect
  31                        displacement-indirect indexed-indirect absolute-short
  32                        absolute-long pc-displacement pc-index))
  33     (absolute (absolute-short absolute-long))))
  34
  35
  36 ;; transforms...
  37 ;;    displacement-indirect w/o expression => vanilla-indirect
  38 ;;    register dX => data-register
  39 ;;    register aX => address-register
  40 ;;    indirect w/pc => pc-indexed or pc-displacement
  41
  42 (defun refine-type (operand modifier)
  43   (cond
  44     ;; XXX: should try to evaluate expression if it exists.
  45     ((and (eq (car operand) 'displacement-indirect)
  46           (zerop (indirect-displacement operand 'word))
  47           (address-register-p (indirect-base-register operand)))
  48      'vanilla-indirect)
  49     ((eq (car operand) 'register)
  50      (case (char (caadr operand) 0)
  51        ((#\d #\D) 'data-register)
  52        ((#\a #\A) 'address-register)
  53        (t 'register)))
  54     ;; XXX: not sure if this is reasonable behavior, but it seems ok
  55     ;; to me.
  56     ((eq (car operand) 'absolute)
  57      (case modifier
  58        ;(word 'absolute-short) (long 'absolute-long)
  59        ;; default to absolute long, to avoid some gemdos
  60        ;; relocation-related hassles.  probably not the right thing to
  61        ;; do (XXX).
  62        (t 'absolute-long)))
  63     (t (car operand))))
  64
  65 (defun operand-type-matches-constraint-type-p (operand constraint modifier)
  66   (let ((refined-op (refine-type operand modifier)))
  67     (aif (find (car constraint) *constraints-modes-table* :key #'car)
  68          (member refined-op (second it))
  69          (eql refined-op (car constraint)))))
  70
  71 (defun satisfies-operand-constraints-p (operands constraints modifier)
  72   (block top
  73     (when (equal (length operands) (length constraints))
  74       (do ((op-> operands (cdr op->))
  75            (co-> constraints (cdr co->)))
  76           ((and (null op->) (null co->)) t)
  77         (unless (operand-type-matches-constraint-type-p (car op->)
  78                                                         (car co->)
  79                                                         modifier)
  80           (return-from top nil))
  81         (dolist (v-constraint (cdar co->))
  82           ;; bind value to the first string or whatever
  83           (let ((subbed (subst (cond ((eq (caar op->) 'immediate)
  84                                       (resolve-expression (cadar op->)))
  85                                      ((eq (caar op->) 'register)
  86                                       (caadar op->))
  87                                      (t (error "Dunno how to apply vconstraints to a ~A." (caar op->))))
  88                                'value v-constraint)))
  89             (unless (apply (car subbed) (cdr subbed))
  90               (return-from top nil))))))))
  91
  92 (defun satisfies-modifier-constraints-p (modifier mod-list)
  93   (cond ((null mod-list) (null modifier))
  94         ((null modifier) t) ;; XXX for the moment
  95         (t (member modifier mod-list))))
  96
  97
  98 (defun find-matching-entry (opcode operands modifier)
  99   (dolist (entry (cdr (find opcode *asm-opcode-table* :key #'car
 100                             :test #'string-equal)))
 101     (cond ((stringp entry)              ; redirect.
 102            (awhen (find-matching-entry entry operands modifier)
 103              (format t "~&redirecting: ~A ~A => ~A" opcode modifier entry)
 104              (return it)))
 105           ((consp entry)
 106            (when (and (satisfies-modifier-constraints-p modifier
 107                                                         (caar entry))
 108                       (satisfies-operand-constraints-p operands
 109                                                        (cdar entry)
 110                                                        modifier))
 111              (return entry)))
 112           (t (error "Bad entry in opcode table: ~A: ~A" opcode entry)))))
 113
 114
 115 ;;;; CODE GENERATION HELPERS
 116
 117 ;;; Note that basically anything here wants to work with
 118 ;;; pre-simplified parse trees.
 119
 120 (defun register-idx (operand &key both-sets)
 121   "If operand is a register or contains in some way a single register,
 122 returns only the numeric index of that register, and the number of
 123 bits that takes up, as a second value.  Otherwise, an error is
 124 signalled."
 125   (case (car operand)
 126     (register)
 127     (t (setf operand (indirect-base-register operand))))
 128
 129   (let ((idx (position (caadr operand) *asm-register-table*
 130                        :test #'string-equal :key #'car)))
 131     (assert (<= 0 idx 15))
 132     (if both-sets
 133         (values idx 4)
 134         (values (logand idx 7) 3))))
 135
 136 (defun register-modifier (operand)
 137   (assert (eql (car operand) 'register))
 138   (cadadr operand))
 139
 140 ;;; XXX: naive
 141 (defun data-register-p (operand)
 142   (char-equal (char (caadr operand) 0) #\D))
 143 (defun address-register-p (operand)
 144   (char-equal (char (caadr operand) 0) #\A))
 145 (defun pc-register-p (operand)
 146   (string-equal (caadr operand) "PC"))
 147
 148 (defun indirect-base-register (operand)
 149   (find 'register (cdr operand) :key #'carat))
 150 (defun indirect-index-register (operand)
 151   (assert (eql (car operand) 'indexed-indirect))
 152   (find 'register (cdr operand) :from-end t :key #'carat))
 153 (defun indirect-displacement (operand modifier)
 154   (let ((length (ecase modifier (byte 8) (word 16))))
 155     (cond ((= (length operand) 2) 0)
 156           ((and (consp (second operand))
 157                 (eq (caadr operand) 'register)) 0)
 158           (t (prog1 (resolve-expression (cadr operand))
 159                (fix-relocation-size length))))))
 160
 161 (defun register-mask-list (operand &optional alterand)
 162   (let ((bitmask (make-array '(16) :element-type 'bit :initial-element 0))
 163         (flipped-p (and alterand
 164                         (eq (car alterand) 'predecrement-indirect))))
 165     ;; iterate over operands
 166     (dolist (r (if (eql (car operand) 'register)
 167                    (list operand)
 168                    (cdr operand)))
 169       (if (eql (car r) 'register)
 170         (setf (aref bitmask (register-idx r :both-sets t)) 1)
 171         (warn "register-mask-list: ignoring ~A" r)))
 172     (values (bit-vector->int (if flipped-p (nreverse bitmask) bitmask))
 173             16)))
 174
 175 (defun effective-address-mode (operand modifier &key (flipped-p nil))
 176   "Calculates the classic six-bit effective address mode and register
 177 values.  If FLIPPED-P, returns the mode and register values swapped."
 178   (flet ((combine (m r)
 179            (logior (if flipped-p (ash r 3) r) (if flipped-p m (ash m 3)))))
 180     (values
 181      (ecase (car operand)
 182        (register
 183         (cond ((data-register-p operand) (combine 0 (register-idx operand)))
 184               ((address-register-p operand)
 185                (combine #b001 (register-idx operand)))
 186               ;; XXX I'm a bit iffy on this one, but so the book says...
 187               ((string-equal (caadr operand) "SR") (combine #b111 #b100))))
 188        (displacement-indirect
 189         (let ((base (indirect-base-register operand)))
 190           (cond ((pc-register-p base) (combine #b111 #b010))
 191                 ((eql (refine-type operand modifier) 'vanilla-indirect)
 192                  (combine #b010 (register-idx base)))
 193                 (t (combine #b101 (register-idx base))))))
 194        (indexed-indirect
 195         (let ((base (indirect-base-register operand)))
 196           (cond ((pc-register-p base) (combine #b111 #b011))
 197                 (t (combine #b110 (register-idx base))))))
 198        (absolute
 199         (ecase (refine-type operand modifier)
 200           (absolute-short (combine #b111 #b000))
 201           (absolute-long (combine #b111 #b001))))
 202        (immediate (combine #b111 #b100))
 203        (postincrement-indirect
 204         (combine #b011 (register-idx (indirect-base-register operand))))
 205        (predecrement-indirect
 206         (combine #b100 (register-idx (indirect-base-register operand)))))
 207      6)))
 208
 209 (defun effective-address-extra (operand modifier)
 210   "Returns the extra data required for addressing OPERAND, along with
 211 the length of that data."
 212   (ecase (car operand)
 213     (register (values 0 0))
 214     (displacement-indirect
 215      (if (eql (refine-type operand modifier) 'vanilla-indirect)
 216          (values 0 0)
 217          (values (indirect-displacement operand 'word) 16)))
 218     (indexed-indirect
 219      (let ((index (indirect-index-register operand)))
 220        (if (not (pc-register-p (indirect-base-register operand)))
 221            ;; rrrr l000 dddd dddd
 222            (values (logior (ash (register-idx index :both-sets t) 12)
 223                            (if (aand (register-modifier index)
 224                                      (eql it 'long))
 225                                (ash #b1 11) 0)
 226                            (logand (indirect-displacement operand 'byte)
 227                                    #xff))
 228                    16)
 229            (error "Not sure how to encode this!")))) ;XXX
 230     (absolute
 231       (ecase (refine-type operand modifier)
 232         (absolute-short (values (absolute-value operand 'word) 16))
 233         (absolute-long (values (absolute-value operand 'long) 32))))
 234     ;; XXX test extent of value
 235     (immediate (values (immediate-value operand)
 236                        (if (eql modifier 'long) 32 16)))
 237     (postincrement-indirect (values 0 0))
 238     (predecrement-indirect (values 0 0))))
 239
 240 ;; XXX this name sucks (too much like ABS)
 241 (defun absolute-value (operand &optional (modifier 'word))
 242   (let ((length (ecase modifier (byte 8) (long 32) (word 16))))
 243     (when (and (consp operand) (eql (first operand) 'absolute))
 244       (setf operand (second operand)))
 245     (values (prog1 (resolve-expression operand)
 246               (fix-relocation-size length))
 247             length)))
 248
 249 ;;; XXX defaults to nil.
 250 (defun absolute-definitely-needs-long-p (operand)
 251   (let ((v (resolve-expression (second operand))))
 252     (and (integerp v) (or (< v -32768)
 253                           (> v 65535)))))
 254
 255 (defun immediate-value (operand &optional modifier)
 256   "Returns a certain number of bits from the immediate value of
 257 OPERAND, based on MODIFIER, if specified."
 258   ;; XXX default length is long?
 259   (let ((length (case modifier ((byte word) 16) (long 32) (t 32))))
 260     (values (prog1 (resolve-expression (second operand))
 261               (fix-relocation-size length))
 262             length)))
 263
 264 (defun addq-immediate-value (operand &optional modifier)
 265   "Special hack for ADDQ/SUBQ.  Returns OPERAND mod 8 and the rest as
 266 per IMMEDIATE-VALUE."
 267   (multiple-value-bind (v l) (immediate-value operand modifier)
 268     (values (mod v 8) l)))
 269
 270 (defun modifier-bits (modifier)
 271   (values (ecase modifier (byte #b00) (word #b01) (long #b10)) 2))
 272
 273 (defun modifier-bits-for-move (modifier)
 274   (values (ecase modifier (byte #b01) (word #b11) (long #b10)) 2))
 275
 276
 277 (defun branch-displacement-bits (operand modifier &key db-p)
 278   "Returns displacement of OPERAND relative to *PROGRAM-COUNTER*.  If
 279 :DB-P is T, calculate displacement as per the DBcc opcodes (always
 280 16-bit).  Otherwise, calculate displacement as per Bcc opcodes, where
 281 displacement is either 8 bits or 16 padded to 24."
 282   (let ((value (absolute-value operand (or modifier
 283                                            (if db-p 'word 'byte))))
 284         (length (cond (db-p 16)
 285                       ((eq modifier 'byte) 8)
 286                       (t 24))))
 287     ;; if there's a reloc at this pc, change to pc-relative
 288     (pc-relativise-relocation)
 289     (fix-relocation-size length)
 290
 291     ;; Note PC+2 -- this is due to the way the m68k fetches
 292     ;; instructions. XXX
 293     (values (or (and (integerp value)
 294                      (logand
 295                       (- value (if (oddp *program-counter*)
 296                                    (1+ *program-counter*)
 297                                    *program-counter*))
 298                       #xffff))
 299                 value)
 300             length)))
 301
 302
 303 ;;;; TEMPLATE EVALUATOR
 304
 305
 306 (defun make-codegen-sublis (operands modifier)
 307   (let ((sub (list (cons 'modifier modifier))))
 308     ;; Adjust as necessary for the number of operands possible.
 309     (do ((a-> operands (cdr a->))
 310          (b-> '(first-operand second-operand third-operand) (cdr b->)))
 311         ((or (null a->) (null b->)) sub)
 312       (push (cons (car b->) (car a->)) sub))))
 313
 314 (defun fill-codegen-template (list)
 315   (do* ((item-> list (cdr item->))
 316         (fake-pc *program-counter* (+ fake-pc (/ length 8)))
 317         (length (caar item->) (caar item->))
 318         (formula (cadar item->) (cadar item->))
 319         (done-p t))
 320        ((null item->) done-p)
 321     (when (consp formula)
 322       ;; We don't floor fake-pc because it should point out
 323       ;; interesting bugs if we ever have to make use of it when it's
 324       ;; not an integer.
 325       (let ((*program-counter* fake-pc))
 326         (multiple-value-bind (val val-len) (apply (car formula)
 327                                                   (cdr formula))
 328           (unless (integerp length)
 329             (setf length val-len)       ; for fake-pc
 330             (setf (caar item->) val-len))
 331           ;; XXX shouldn't have to comment this out, but I do due to
 332           ;; silly immediate-value hacks.
 333           ;;(when (integerp val-len) (assert (= (caar item->) val-len)))
 334           (if (integerp val)
 335               (setf (cadar item->) val)
 336               (setf done-p nil)))))))
 337
 338 ;;; first do the sublis, then walk through each item doing the
 339 ;;; evaluation when we can.  if everything's reduced to an atom,
 340 ;;; compile it and return it.  otherwise, return the half-completed
 341 ;;; list.
 342
 343 ;; if the first is an integer, add it to the result-length.  if the
 344 ;; second is an atom, or it into the result.  if the second is a list,
 345 ;; evaluate it with first-operand, second-operand, and modifier bound.
 346
 347 (defun generate-code (template operands modifier)
 348   (let ((result 0)
 349         (result-len 0)
 350         (list (sublis (make-codegen-sublis operands modifier) template)))
 351
 352     (cond ((fill-codegen-template list)
 353            (dolist (item list)
 354              (destructuring-bind (len val) item
 355                (setf result (logior (ldb (byte len 0) val)
 356                                     (ash result len)))
 357                (incf result-len len)))
 358            (values result result-len))
 359           (t (dolist (item list) (incf result-len (first item)))
 360              (values list result-len)))))
 361
 362 ;;;; EOF codegen.lisp