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