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