src/compiler/ppc/insts.lisp

   1 ;;;; the instruction set definition for the PPC
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 ;(def-assembler-params
  15 ;    :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots"
  16 ;  :max-locations 70)
  17 \f
  18 ;;;; Constants, types, conversion functions, some disassembler stuff.
  19
  20 (defun reg-tn-encoding (tn)
  21   (declare (type tn tn))
  22   (sc-case tn
  23     (zero zero-offset)
  24     (null null-offset)
  25     (t
  26      (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
  27          (tn-offset tn)
  28          (error "~S isn't a register." tn)))))
  29
  30 (defun fp-reg-tn-encoding (tn)
  31   (declare (type tn tn))
  32   (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
  33     (error "~S isn't a floating-point register." tn))
  34   (tn-offset tn))
  35
  36 ;(sb!disassem:set-disassem-params :instruction-alignment 32)
  37
  38 (defvar *disassem-use-lisp-reg-names* t)
  39
  40 (!def-vm-support-routine location-number (loc)
  41   (etypecase loc
  42     (null)
  43     (number)
  44     (label)
  45     (fixup)
  46     (tn
  47      (ecase (sb-name (sc-sb (tn-sc loc)))
  48        (immediate-constant
  49         ;; Can happen if $ZERO or $NULL are passed in.
  50         nil)
  51        (registers
  52         (unless (zerop (tn-offset loc))
  53           (tn-offset loc)))
  54        (float-registers
  55         (+ (tn-offset loc) 32))))
  56     (symbol
  57      (ecase loc
  58        (:memory 0)
  59        (:ccr 64)
  60        (:xer 65)
  61        (:lr 66)
  62        (:ctr 67)
  63        (:fpscr 68)))))
  64
  65 (defparameter reg-symbols
  66   (map 'vector
  67        #'(lambda (name)
  68            (cond ((null name) nil)
  69                  (t (make-symbol (concatenate 'string "$" name)))))
  70        *register-names*))
  71
  72 (sb!disassem:define-arg-type reg
  73   :printer #'(lambda (value stream dstate)
  74                (declare (type stream stream) (fixnum value))
  75                (let ((regname (aref reg-symbols value)))
  76                  (princ regname stream)
  77                  (sb!disassem:maybe-note-associated-storage-ref
  78                   value
  79                   'registers
  80                   regname
  81                   dstate))))
  82
  83 (defparameter float-reg-symbols
  84   #.(coerce
  85      (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
  86      'vector))
  87
  88 (sb!disassem:define-arg-type fp-reg
  89   :printer #'(lambda (value stream dstate)
  90                (declare (type stream stream) (fixnum value))
  91                (let ((regname (aref float-reg-symbols value)))
  92                  (princ regname stream)
  93                  (sb!disassem:maybe-note-associated-storage-ref
  94                   value
  95                   'float-registers
  96                   regname
  97                   dstate))))
  98
  99 (eval-when (:compile-toplevel :load-toplevel :execute)
 100   (defparameter bo-kind-names
 101     #(:bo-dnzf :bo-dnzfp :bo-dzf :bo-dzfp :bo-f :bo-fp nil nil
 102       :bo-dnzt :bo-dnztp :bo-dzt :bo-dztp :bo-t :bo-tp nil nil
 103       :bo-dnz :bo-dnzp :bo-dz :bo-dzp :bo-u nil nil nil
 104       nil nil nil nil nil nil nil nil)))
 105
 106 (sb!disassem:define-arg-type bo-field
 107   :printer #'(lambda (value stream dstate)
 108                (declare (ignore dstate)
 109                         (type stream stream)
 110                         (type fixnum value))
 111                (princ (svref bo-kind-names value) stream)))
 112
 113 (eval-when (:compile-toplevel :load-toplevel :execute)
 114 (defun valid-bo-encoding (enc)
 115   (or (if (integerp enc)
 116         (and (= enc (logand #x1f enc))
 117              (not (null (svref bo-kind-names enc)))
 118              enc)
 119         (and enc (position enc bo-kind-names)))
 120       (error "Invalid BO field spec: ~s" enc)))
 121 )
 122
 123
 124 (defparameter cr-bit-names #(:lt :gt :eq :so))
 125 (defparameter cr-bit-inverse-names #(:ge :le :ne :ns))
 126
 127 (defparameter cr-field-names #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
 128
 129 (defun valid-cr-bit-encoding (enc &optional error-p)
 130   (or (if (integerp enc)
 131         (and (= enc (logand 3 enc))
 132              enc))
 133       (position enc cr-bit-names)
 134       (if error-p (error "Invalid condition bit specifier : ~s" enc))))
 135
 136 (defun valid-cr-field-encoding (enc)
 137   (let* ((field (if (integerp enc)
 138                   (and (= enc (logand #x7 enc)))
 139                   (position enc cr-field-names))))
 140     (if field
 141       (ash field 2)
 142       (error "Invalid condition register field specifier : ~s" enc))))
 143
 144 (defun valid-bi-encoding (enc)
 145   (or
 146    (if (atom enc)
 147      (if (integerp enc)
 148        (and (= enc (logand 31 enc)) enc)
 149        (position enc cr-bit-names))
 150      (+ (valid-cr-field-encoding (car enc))
 151         (valid-cr-bit-encoding (cadr enc))))
 152    (error "Invalid BI field spec : ~s" enc)))
 153
 154 (sb!disassem:define-arg-type bi-field
 155   :printer #'(lambda (value stream dstate)
 156                (declare (ignore dstate)
 157                         (type stream stream)
 158                         (type (unsigned-byte 5) value))
 159                (let* ((bitname (svref cr-bit-names (logand 3 value)))
 160                       (crfield (ash value -2)))
 161                  (declare (type (unsigned-byte 3) crfield))
 162                  (if (= crfield 0)
 163                    (princ bitname stream)
 164                    (princ (list (svref cr-field-names crfield) bitname) stream)))))
 165
 166 (sb!disassem:define-arg-type crf
 167   :printer #'(lambda (value stream dstate)
 168                (declare (ignore dstate)
 169                         (type stream stream)
 170                         (type (unsigned-byte 3) value))
 171                (princ (svref cr-field-names value) stream)))
 172
 173 (sb!disassem:define-arg-type relative-label
 174   :sign-extend t
 175   :use-label #'(lambda (value dstate)
 176                  (declare (type (signed-byte 14) value)
 177                           (type sb!disassem:disassem-state dstate))
 178                  (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
 179
 180 (eval-when (:compile-toplevel :load-toplevel :execute)
 181   (defparameter trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
 182                                    (:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
 183                                    (:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))))
 184
 185
 186 (defun valid-tcond-encoding (enc)
 187   (or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
 188       (cdr (assoc enc trap-values-alist))
 189       (error "Unknown trap condition: ~s" enc)))
 190
 191 (sb!disassem:define-arg-type to-field
 192   :sign-extend nil
 193   :printer #'(lambda (value stream dstate)
 194                (declare (ignore dstate)
 195                         (type stream stream)
 196                         (type fixnum value))
 197                (princ (or (car (rassoc value trap-values-alist))
 198                           value)
 199                       stream)))
 200
 201 (defun snarf-error-junk (sap offset &optional length-only)
 202   (let* ((length (sb!sys:sap-ref-8 sap offset))
 203          (vector (make-array length :element-type '(unsigned-byte 8))))
 204     (declare (type sb!sys:system-area-pointer sap)
 205              (type (unsigned-byte 8) length)
 206              (type (simple-array (unsigned-byte 8) (*)) vector))
 207     (cond (length-only
 208            (values 0 (1+ length) nil nil))
 209           (t
 210            (sb!kernel:copy-from-system-area sap (* sb!vm:n-byte-bits (1+ offset))
 211                                          vector (* sb!vm:n-word-bits
 212                                                    sb!vm:vector-data-offset)
 213                                          (* length sb!vm:n-byte-bits))
 214            (collect ((sc-offsets)
 215                      (lengths))
 216              (lengths 1)                ; the length byte
 217              (let* ((index 0)
 218                     (error-number (sb!c:read-var-integer vector index)))
 219                (lengths index)
 220                (loop
 221                  (when (>= index length)
 222                    (return))
 223                  (let ((old-index index))
 224                    (sc-offsets (sb!c:read-var-integer vector index))
 225                    (lengths (- index old-index))))
 226                (values error-number
 227                        (1+ length)
 228                        (sc-offsets)
 229                        (lengths))))))))
 230
 231 (defun emit-conditional-branch (segment bo bi target &optional aa-p lk-p)
 232   (declare (type boolean aa-p lk-p))
 233   (let* ((bo (valid-bo-encoding bo))
 234          (bi (valid-bi-encoding bi))
 235          (aa-bit (if aa-p 1 0))
 236          (lk-bit (if lk-p 1 0)))
 237     (if aa-p                            ; Not bloody likely, bwth.
 238       (emit-b-form-inst segment 16 bo bi target aa-bit lk-bit)
 239       ;; the target may be >32k away, in which case we have to invert the
 240       ;; test and do an absolute branch
 241       (emit-chooser
 242        ;; We emit either 4 or 8 bytes, so I think we declare this as
 243        ;; preserving 4 byte alignment.  If this gives us no joy, we can
 244        ;; stick a nop in the long branch and then we will be
 245        ;; preserving 8 byte alignment
 246        segment 8 2 ; 2^2 is 4 byte alignment.  I think
 247        #'(lambda (segment posn magic-value)
 248            (let ((delta (ash (- (label-position target posn magic-value) posn)
 249                              -2)))
 250              (when (typep delta '(signed-byte 14))
 251                (emit-back-patch segment 4
 252                                 #'(lambda (segment posn)
 253                                     (emit-b-form-inst
 254                                      segment 16 bo bi
 255                                      (ash (- (label-position target) posn) -2)
 256                                      aa-bit lk-bit)))
 257                t)))
 258        #'(lambda (segment posn)
 259            (let ((bo (logxor 8 bo))) ;; invert the test
 260              (emit-b-form-inst segment 16 bo bi
 261                                2 ; skip over next instruction
 262                                0 0)
 263              (emit-back-patch segment 4
 264                               #'(lambda (segment posn)
 265                                   (emit-i-form-branch segment target lk-p)))))
 266        ))))
 267
 268
 269
 270 ; non-absolute I-form: B, BL.
 271 (defun emit-i-form-branch (segment target &optional lk-p)
 272   (let* ((lk-bit (if lk-p 1 0)))
 273     (etypecase target
 274       (fixup
 275        (note-fixup segment :b target)
 276        (emit-i-form-inst segment 18 0 0 lk-bit))
 277       (label
 278        (emit-back-patch segment 4
 279                         #'(lambda (segment posn)
 280                             (emit-i-form-inst
 281                              segment
 282                              18
 283                              (ash (- (label-position target) posn) -2)
 284                              0
 285                              lk-bit)))))))
 286
 287 (eval-when (:compile-toplevel :execute :load-toplevel)
 288 (defparameter *spr-numbers-alist* '((:xer 1) (:lr 8) (:ctr 9))))
 289
 290 (sb!disassem:define-arg-type spr
 291   :printer #'(lambda (value stream dstate)
 292                (declare (ignore dstate)
 293                         (type (unsigned-byte 10) value))
 294                (let* ((name (car (rassoc value *spr-numbers-alist*))))
 295                    (if name
 296                      (princ name stream)
 297                      (princ value stream)))))
 298
 299 (eval-when (:compile-toplevel :load-toplevel :execute)
 300   (defparameter jump-printer
 301     #'(lambda (value stream dstate)
 302         (let ((addr (ash value 2)))
 303           (sb!disassem:maybe-note-assembler-routine addr t dstate)
 304           (write addr :base 16 :radix t :stream stream)))))
 305
 306
 307 \f
 308 ;;;; dissassem:define-instruction-formats
 309
 310 (eval-when (:compile-toplevel :execute)
 311   (defmacro ppc-byte (startbit &optional (endbit startbit))
 312     (unless (and (typep startbit '(unsigned-byte 32))
 313                  (typep endbit '(unsigned-byte 32))
 314                  (>= endbit startbit))
 315       (error "Bad bits."))
 316     ``(byte ,(1+ ,(- endbit startbit)) ,(- 31 ,endbit)))
 317
 318   (defparameter *ppc-field-specs-alist*
 319     `((aa :field ,(ppc-byte 30))
 320       (ba :field ,(ppc-byte 11 15) :type 'bi-field)
 321       (bb :field ,(ppc-byte 16 20) :type 'bi-field)
 322       (bd :field ,(ppc-byte 16 29) :type 'relative-label)
 323       (bf :field ,(ppc-byte 6 8) :type 'crf)
 324       (bfa :field ,(ppc-byte 11 13) :type 'crf)
 325       (bi :field ,(ppc-byte 11 15) :type 'bi-field)
 326       (bo :field ,(ppc-byte 6 10) :type 'bo-field)
 327       (bt :field ,(ppc-byte 6 10) :type 'bi-field)
 328       (d :field ,(ppc-byte 16 31) :sign-extend t)
 329       (flm :field ,(ppc-byte 7 14) :sign-extend nil)
 330       (fra :field ,(ppc-byte 11 15) :type 'fp-reg)
 331       (frb :field ,(ppc-byte 16 20) :type 'fp-reg)
 332       (frc :field ,(ppc-byte 21 25) :type 'fp-reg)
 333       (frs :field ,(ppc-byte 6 10) :type 'fp-reg)
 334       (frt :field ,(ppc-byte 6 10) :type 'fp-reg)
 335       (fxm :field ,(ppc-byte 12 19) :sign-extend nil)
 336       (l :field ,(ppc-byte 10) :sign-extend nil)
 337       (li :field ,(ppc-byte 6 29) :sign-extend t :type 'relative-label)
 338       (li-abs :field ,(ppc-byte 6 29) :sign-extend t :printer jump-printer)
 339       (lk :field ,(ppc-byte 31))
 340       (mb :field ,(ppc-byte 21 25) :sign-extend nil)
 341       (me :field ,(ppc-byte 26 30) :sign-extend nil)
 342       (nb :field ,(ppc-byte 16 20) :sign-extend nil)
 343       (oe :field ,(ppc-byte 21))
 344       (ra :field ,(ppc-byte 11 15) :type 'reg)
 345       (rb :field ,(ppc-byte 16 20) :type 'reg)
 346       (rc :field ,(ppc-byte 31))
 347       (rs :field ,(ppc-byte 6 10) :type 'reg)
 348       (rt :field ,(ppc-byte 6 10) :type 'reg)
 349       (sh :field ,(ppc-byte 16 20) :sign-extend nil)
 350       (si :field ,(ppc-byte 16 31) :sign-extend t)
 351       (spr :field ,(ppc-byte 11 20) :type 'spr)
 352       (to :field ,(ppc-byte 6 10) :type 'to-field)
 353       (u :field ,(ppc-byte 16 19) :sign-extend nil)
 354       (ui :field ,(ppc-byte 16 31) :sign-extend nil)
 355       (xo21-30 :field ,(ppc-byte 21 30) :sign-extend nil)
 356       (xo22-30 :field ,(ppc-byte 22 30) :sign-extend nil)
 357       (xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil)))
 358
 359
 360
 361 (sb!disassem:define-instruction-format (instr 32)
 362   (op :field (byte 6 26))
 363   (other :field (byte 26 0)))
 364
 365 (sb!disassem:define-instruction-format (xinstr 32 :default-printer '(:name :tab data))
 366   (op-to-a :field (byte 16 16))
 367   (data :field (byte 16 0)))
 368
 369 (sb!disassem:define-instruction-format (sc 32 :default-printer '(:name :tab rest))
 370   (op :field (byte 6 26))
 371   (rest :field (byte 26 0) :value 2))
 372
 373
 374
 375 (macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs)
 376                (flet ((specname-field (specname)
 377                         (or (assoc specname *ppc-field-specs-alist*)
 378                             (error "Unknown ppc instruction field spec ~s" specname))))
 379                  (labels ((spec-field (spec)
 380                             (if (atom spec)
 381                                 (specname-field spec)
 382                                 (cons (car spec)
 383                                       (cdr (specname-field (cadr spec)))))))
 384                    (collect ((field (list '(op :field (byte 6 26)))))
 385                             (dolist (spec specs)
 386                               (field (spec-field spec)))
 387                             `(sb!disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
 388                               ,@(field)))))))
 389
 390 (def-ppc-iformat (i '(:name :tab li))
 391   li aa lk)
 392
 393 (def-ppc-iformat (i-abs '(:name :tab li-abs))
 394   li-abs aa lk)
 395
 396 (def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
 397   bo bi bd aa lk)
 398
 399 (def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
 400   rt ra d)
 401
 402 (def-ppc-iformat (d-si '(:name :tab rt "," ra "," si ))
 403   rt ra si)
 404
 405 (def-ppc-iformat (d-rs '(:name :tab rs "," d "(" ra ")"))
 406   rs ra d)
 407
 408 (def-ppc-iformat (d-rs-ui '(:name :tab ra "," rs "," ui))
 409   rs ra ui)
 410
 411 (def-ppc-iformat (d-crf-si)
 412   bf l ra si)
 413
 414 (def-ppc-iformat (d-crf-ui)
 415   bf l ra ui)
 416
 417 (def-ppc-iformat (d-to '(:name :tab to "," ra "," si))
 418   to ra rb si)
 419
 420 (def-ppc-iformat (d-frt '(:name :tab frt "," d "(" ra ")"))
 421   frt ra d)
 422
 423 (def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
 424   frs ra d)
 425
 426
 427 \f
 428 ;;; There are around ... oh, 28 or so ... variants on the "X" format.
 429 ;;;  Some of them are only used by one instruction; some are used by dozens.
 430 ;;;  Some aren't used by instructions that we generate ...
 431
 432 (def-ppc-iformat (x '(:name :tab rt "," ra "," rb))
 433   rt ra rb (xo xo21-30))
 434
 435 (def-ppc-iformat (x-1 '(:name :tab rt "," ra "," nb))
 436   rt ra nb (xo xo21-30))
 437
 438 (def-ppc-iformat (x-4 '(:name :tab rt))
 439   rt (xo xo21-30))
 440
 441 (def-ppc-iformat (x-5 '(:name :tab ra "," rs "," rb))
 442   rs ra rb (xo xo21-30) rc)
 443
 444 (def-ppc-iformat (x-7 '(:name :tab ra "," rs "," rb))
 445   rs ra rb (xo xo21-30))
 446
 447 (def-ppc-iformat (x-8 '(:name :tab ra "," rs "," nb))
 448   rs ra nb (xo xo21-30))
 449
 450 (def-ppc-iformat (x-9 '(:name :tab ra "," rs "," sh))
 451   rs ra sh (xo xo21-30) rc)
 452
 453 (def-ppc-iformat (x-10 '(:name :tab ra "," rs))
 454   rs ra (xo xo21-30) rc)
 455
 456 (def-ppc-iformat (x-14 '(:name :tab bf "," l "," ra "," rb))
 457   bf l ra rb (xo xo21-30))
 458
 459 (def-ppc-iformat (x-15 '(:name :tab bf "," l "," fra "," frb))
 460   bf l fra frb (xo xo21-30))
 461
 462 (def-ppc-iformat (x-18 '(:name :tab bf))
 463   bf (xo xo21-30))
 464
 465 (def-ppc-iformat (x-19 '(:name :tab to "," ra "," rb))
 466   to ra rb (xo xo21-30))
 467
 468 (def-ppc-iformat (x-20 '(:name :tab frt "," ra "," rb))
 469   frt ra rb (xo xo21-30))
 470
 471 (def-ppc-iformat (x-21 '(:name :tab frt "," rb))
 472   frt rb (xo xo21-30) rc)
 473
 474 (def-ppc-iformat (x-22 '(:name :tab frt))
 475   frt (xo xo21-30) rc)
 476
 477 (def-ppc-iformat (x-23 '(:name :tab ra "," frs "," rb))
 478   frs ra rb (xo xo21-30))
 479
 480 (def-ppc-iformat (x-24 '(:name :tab bt))
 481   bt (xo xo21-30) rc)
 482
 483 (def-ppc-iformat (x-25 '(:name :tab ra "," rb))
 484   ra rb (xo xo21-30))
 485
 486 (def-ppc-iformat (x-26 '(:name :tab rb))
 487   rb (xo xo21-30))
 488
 489 (def-ppc-iformat (x-27 '(:name))
 490   (xo xo21-30))
 491
 492 \f
 493 ;;;;
 494
 495 (def-ppc-iformat (xl '(:name :tab bt "," ba "," bb))
 496   bt ba bb (xo xo21-30))
 497
 498 (def-ppc-iformat (xl-bo-bi '(:name :tab bo "," bi))
 499   bo bi (xo xo21-30) lk)
 500
 501 (def-ppc-iformat (xl-cr '(:name :tab bf "," bfa))
 502   bf bfa (xo xo21-30))
 503
 504 (def-ppc-iformat (xl-xo '(:name))
 505   (xo xo21-30))
 506
 507 \f
 508 ;;;;
 509
 510 (def-ppc-iformat (xfx)
 511   rt spr (xo xo21-30))
 512
 513 (def-ppc-iformat (xfx-fxm '(:name :tab fxm "," rs))
 514   rs fxm (xo xo21-30))
 515
 516 (def-ppc-iformat (xfl '(:name :tab flm "," frb))
 517   flm frb (xo xo21-30) rc)
 518
 519 \f
 520 ;;;
 521
 522 (def-ppc-iformat (xo '(:name :tab rt "," ra "," rb))
 523   rt ra rb oe (xo xo22-30) rc)
 524
 525 (def-ppc-iformat (xo-oe '(:name :tab rt "," ra "," rb))
 526   rt ra rb (xo xo22-30) rc)
 527
 528 (def-ppc-iformat (xo-a '(:name :tab rt "," ra))
 529   rt ra oe (xo xo22-30) rc)
 530
 531 \f
 532 ;;;
 533
 534 (def-ppc-iformat (a '(:name :tab frt "," fra "," frb "," frc))
 535   frt fra frb frc (xo xo26-30) rc)
 536
 537 (def-ppc-iformat (a-tab '(:name :tab frt "," fra "," frb))
 538   frt fra frb (xo xo26-30) rc)
 539
 540 (def-ppc-iformat (a-tac '(:name :tab frt "," fra "," frc))
 541   frt fra frc (xo xo26-30) rc)
 542
 543 (def-ppc-iformat (a-tbc '(:name :tab frt "," frb "," frc))
 544   frt frb frc (xo xo26-30) rc)
 545 \f
 546
 547 (def-ppc-iformat (m '(:name :tab ra "," rs "," rb "," mb "," me))
 548   rs ra rb mb me rc)
 549
 550 (def-ppc-iformat (m-sh '(:name :tab ra "," rs "," sh "," mb "," me))
 551   rs ra sh mb me rc)))
 552
 553
 554
 555 \f
 556 ;;;; Primitive emitters.
 557
 558
 559 (define-bitfield-emitter emit-word 32
 560   (byte 32 0))
 561
 562 (define-bitfield-emitter emit-short 16
 563   (byte 16 0))
 564
 565 (define-bitfield-emitter emit-i-form-inst 32
 566   (byte 6 26) (byte 24 2) (byte 1 1) (byte 1 0))
 567
 568 (define-bitfield-emitter emit-b-form-inst 32
 569   (byte 6 26) (byte 5 21) (byte 5 16) (byte 14 2) (byte 1 1) (byte 1 0))
 570
 571 (define-bitfield-emitter emit-sc-form-inst 32
 572   (byte 6 26) (byte 26 0))
 573
 574 (define-bitfield-emitter emit-d-form-inst 32
 575   (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
 576
 577 ; Also used for XL-form.  What's the difference ?
 578 (define-bitfield-emitter emit-x-form-inst 32
 579   (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 10 1) (byte 1 0))
 580
 581 (define-bitfield-emitter emit-xfx-form-inst 32
 582   (byte 6 26) (byte 5 21) (byte 10 11) (byte 10 1) (byte 1 0))
 583
 584 (define-bitfield-emitter emit-xfl-form-inst 32
 585   (byte 6 26) (byte 10  16) (byte 5 11) (byte 10 1) (byte 1 0))
 586
 587 ; XS is 64-bit only
 588 (define-bitfield-emitter emit-xo-form-inst 32
 589   (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 1 10) (byte 9 1) (byte 1 0))
 590
 591 (define-bitfield-emitter emit-a-form-inst 32
 592   (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 5 1) (byte 1 0))
 593
 594
 595 \f
 596
 597 (defun unimp-control (chunk inst stream dstate)
 598   (declare (ignore inst))
 599   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
 600     (case (xinstr-data chunk dstate)
 601       (#.sb!vm:error-trap
 602        (nt "Error trap")
 603        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 604       (#.sb!vm:cerror-trap
 605        (nt "Cerror trap")
 606        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
 607       (#.sb!vm:object-not-list-trap
 608        (nt "Object not list trap"))
 609       (#.sb!vm:breakpoint-trap
 610        (nt "Breakpoint trap"))
 611       (#.sb!vm:pending-interrupt-trap
 612        (nt "Pending interrupt trap"))
 613       (#.sb!vm:halt-trap
 614        (nt "Halt trap"))
 615       (#.sb!vm:fun-end-breakpoint-trap
 616        (nt "Function end breakpoint trap"))
 617       (#.sb!vm:object-not-instance-trap
 618        (nt "Object not instance trap"))
 619     )))
 620
 621 (eval-when (:compile-toplevel :execute)
 622
 623 (defun classify-dependencies (deplist)
 624   (collect ((reads) (writes))
 625     (dolist (dep deplist)
 626       (ecase (car dep)
 627         (reads (reads dep))
 628         (writes (writes dep))))
 629     (values (reads) (writes)))))
 630
 631 (macrolet ((define-xo-instruction
 632                (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
 633                `(define-instruction ,name (segment rt ra rb)
 634                  (:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
 635                  (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
 636                   (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
 637                  (:cost ,cost)
 638                  (:delay ,cost)
 639                  (:emitter
 640                   (emit-xo-form-inst segment ,op
 641                    (reg-tn-encoding rt)
 642                    (reg-tn-encoding ra)
 643                    (reg-tn-encoding rb)
 644                    ,(if oe-p 1 0)
 645                    ,xo
 646                    ,(if rc-p 1 0)))))
 647            (define-xo-oe-instruction
 648                (name op xo rc-p always-reads-xer always-writes-xer cost)
 649                `(define-instruction ,name (segment rt ra rb)
 650                  (:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
 651                  (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
 652                   (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))))
 653                  (:cost ,cost)
 654                  (:delay ,cost)
 655                  (:emitter
 656                   (emit-xo-form-inst segment ,op
 657                    (reg-tn-encoding rt)
 658                    (reg-tn-encoding ra)
 659                    (reg-tn-encoding rb)
 660                    0
 661                    ,xo
 662                    (if ,rc-p 1 0)))))
 663            (define-4-xo-instructions
 664                (base op xo &key always-reads-xer always-writes-xer (cost 1))
 665                `(progn
 666                  (define-xo-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
 667                  (define-xo-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
 668                  (define-xo-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
 669                  (define-xo-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
 670
 671            (define-2-xo-oe-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
 672                `(progn
 673                  (define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost)
 674                  (define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost)))
 675
 676            (define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
 677                `(define-instruction ,name (segment rt ra)
 678                  (:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0))))
 679                  (:dependencies (reads ra) ,@(if always-reads-xer '((reads :xer)))
 680                   (writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))) )
 681                  (:cost ,cost)
 682                  (:delay ,cost)
 683                  (:emitter
 684                   (emit-xo-form-inst segment ,op
 685                    (reg-tn-encoding rt)
 686                    (reg-tn-encoding ra)
 687                    0
 688                    (if ,oe-p 1 0)
 689                    ,xo
 690                    (if ,rc-p 1 0)))))
 691
 692            (define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
 693                `(progn
 694                  (define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
 695                  (define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
 696                  (define-xo-a-instruction ,(symbolicate base "O")  ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
 697                  (define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
 698
 699            (define-x-instruction (name op xo &key (cost 2) other-dependencies)
 700                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 701                  `(define-instruction ,name (segment rt ra rb)
 702                    (:printer x ((op ,op) (xo ,xo)))
 703                    (:delay ,cost)
 704                    (:cost ,cost)
 705                    (:dependencies (reads ra) (reads rb) ,@ other-reads
 706                     (writes rt) ,@other-writes)
 707                    (:emitter
 708                     (emit-x-form-inst segment ,op
 709                      (reg-tn-encoding rt)
 710                      (reg-tn-encoding ra)
 711                      (reg-tn-encoding rb)
 712                      ,xo
 713                      0)))))
 714
 715            (define-x-20-instruction (name op xo &key (cost 2) other-dependencies)
 716                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 717                  `(define-instruction ,name (segment frt ra rb)
 718                    (:printer x-20 ((op ,op) (xo ,xo)))
 719                    (:delay ,cost)
 720                    (:cost ,cost)
 721                    (:dependencies (reads ra) (reads rb) ,@other-reads
 722                     (writes frt) ,@other-writes)
 723                    (:emitter
 724                     (emit-x-form-inst segment ,op
 725                      (fp-reg-tn-encoding frt)
 726                      (reg-tn-encoding ra)
 727                      (reg-tn-encoding rb)
 728                      ,xo
 729                      0)))))
 730
 731            (define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies)
 732                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 733                  `(define-instruction ,name (segment ra rs rb)
 734                    (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
 735                    (:delay ,cost)
 736                    (:cost ,cost)
 737                    (:dependencies (reads rb) (reads rs) ,@other-reads
 738                     (writes ra) ,@other-writes)
 739                    (:emitter
 740                     (emit-x-form-inst segment ,op
 741                      (reg-tn-encoding rs)
 742                      (reg-tn-encoding ra)
 743                      (reg-tn-encoding rb)
 744                      ,xo
 745                      ,(if rc-p 1 0))))))
 746
 747
 748            (define-x-5-st-instruction (name op xo rc-p &key (cost 1) other-dependencies)
 749                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 750                  `(define-instruction ,name (segment rs ra rb)
 751                    (:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
 752                    (:delay ,cost)
 753                    (:cost ,cost)
 754                    (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads
 755                     ,@other-writes)
 756                    (:emitter
 757                     (emit-x-form-inst segment ,op
 758                      (reg-tn-encoding rs)
 759                      (reg-tn-encoding ra)
 760                      (reg-tn-encoding rb)
 761                      ,xo
 762                      ,(if rc-p 1 0))))))
 763
 764            (define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies)
 765                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 766                  `(define-instruction ,name (segment frs ra rb)
 767                    (:printer x-23 ((op ,op) (xo ,xo)))
 768                    (:delay ,cost)
 769                    (:cost ,cost)
 770                    (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads
 771                     ,@other-writes)
 772                    (:emitter
 773                     (emit-x-form-inst segment ,op
 774                      (fp-reg-tn-encoding frs)
 775                      (reg-tn-encoding ra)
 776                      (reg-tn-encoding rb)
 777                      ,xo
 778                      0)))))
 779
 780            (define-x-10-instruction (name op xo rc-p &key (cost 1) other-dependencies)
 781                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 782                  `(define-instruction ,name (segment ra rs)
 783                    (:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
 784                    (:delay ,cost)
 785                    (:cost ,cost)
 786                    (:dependencies (reads rs) ,@other-reads
 787                     (writes ra) ,@other-writes)
 788                    (:emitter
 789                     (emit-x-form-inst segment ,op
 790                      (reg-tn-encoding rs)
 791                      (reg-tn-encoding ra)
 792                      0
 793                      ,xo
 794                      ,(if rc-p 1 0))))))
 795
 796            (define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies)
 797                `(progn
 798                  (define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
 799                  (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
 800                                          :other-dependencies ,other-dependencies)))
 801
 802            (define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies)
 803                `(progn
 804                  (define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
 805                  (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
 806                                           :other-dependencies ,other-dependencies)))
 807
 808
 809            (define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies)
 810                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 811                  `(define-instruction ,name (segment frt frb)
 812                    (:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
 813                    (:cost ,cost)
 814                    (:delay ,cost)
 815                    (:dependencies (reads frb) ,@other-reads
 816                     (writes frt) ,@other-writes)
 817                    (:emitter
 818                     (emit-x-form-inst segment ,op
 819                      (fp-reg-tn-encoding frt)
 820                      0
 821                      (fp-reg-tn-encoding frb)
 822                      ,xo
 823                      ,(if rc-p 1 0))))))
 824
 825            (define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies)
 826                `(progn
 827                  (define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
 828                  (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
 829                                           :other-dependencies ,other-dependencies)))
 830
 831
 832            (define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies)
 833                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 834                  `(define-instruction ,name (segment rt ra si)
 835                    (:declare (type (signed-byte 16)))
 836                    (:printer d-si ((op ,op)))
 837                    (:delay ,cost)
 838                    (:cost ,cost)
 839                    (:dependencies (reads ra) ,@other-reads
 840                     (writes rt) ,@other-writes)
 841                    (:emitter
 842                     (when (typep si 'fixup)
 843                       (ecase ,fixup
 844                         ((:ha :l) (note-fixup segment ,fixup si)))
 845                       (setq si 0))
 846                     (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
 847
 848            (define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies)
 849                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 850                  `(define-instruction ,name (segment ra rs ui)
 851                    (:declare (type (unsigned-byte 16) ui))
 852                    (:printer d-rs-ui ((op ,op)))
 853                    (:cost ,cost)
 854                    (:delay ,cost)
 855                    (:dependencies (reads rs) ,@other-reads
 856                     (writes ra) ,@other-writes)
 857                    (:emitter
 858                     (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui)))))
 859
 860            (define-d-instruction (name op &key (cost 2) other-dependencies pinned)
 861                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 862                  `(define-instruction ,name (segment rt ra si)
 863                    (:declare (type (signed-byte 16) si))
 864                    (:printer d ((op ,op)))
 865                    (:delay ,cost)
 866                    (:cost ,cost)
 867                    ,@(when pinned '(:pinned))
 868                    (:dependencies (reads ra) ,@other-reads
 869                     (writes rt) ,@other-writes)
 870                    (:emitter
 871                     (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
 872
 873            (define-d-frt-instruction (name op &key (cost 3) other-dependencies)
 874                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 875                  `(define-instruction ,name (segment frt ra si)
 876                    (:declare (type (signed-byte 16) si))
 877                    (:printer d-frt ((op ,op)))
 878                    (:delay ,cost)
 879                    (:cost ,cost)
 880                    (:dependencies (reads ra) ,@other-reads
 881                     (writes frt) ,@other-writes)
 882                    (:emitter
 883                     (emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si)))))
 884
 885            (define-d-rs-instruction (name op &key (cost 1) other-dependencies pinned)
 886                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 887                  `(define-instruction ,name (segment rs ra si)
 888                    (:declare (type (signed-byte 16) si))
 889                    (:printer d-rs ((op ,op)))
 890                    (:delay ,cost)
 891                    (:cost ,cost)
 892                    ,@(when pinned '(:pinned))
 893                    (:dependencies (reads rs) (reads ra) ,@other-reads
 894                     (writes :memory :partially t) ,@other-writes)
 895                    (:emitter
 896                     (emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si)))))
 897
 898            (define-d-frs-instruction (name op &key (cost 1) other-dependencies)
 899                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 900                  `(define-instruction ,name (segment frs ra si)
 901                    (:declare (type (signed-byte 16) si))
 902                    (:printer d-frs ((op ,op)))
 903                    (:delay ,cost)
 904                    (:cost ,cost)
 905                    (:dependencies (reads frs) (reads ra) ,@other-reads
 906                     (writes :memory :partially t) ,@other-writes)
 907                    (:emitter
 908                     (emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si)))))
 909
 910            (define-a-instruction (name op xo rc &key (cost 1) other-dependencies)
 911                `(define-instruction ,name (segment frt fra frb frc)
 912                  (:printer a ((op ,op) (xo ,xo) (rc ,rc)))
 913                  (:cost ,cost)
 914                  (:delay ,cost)
 915                  (:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies)
 916                  (:emitter
 917                   (emit-a-form-inst segment
 918                    ,op
 919                    (fp-reg-tn-encoding frt)
 920                    (fp-reg-tn-encoding fra)
 921                    (fp-reg-tn-encoding frb)
 922                    (fp-reg-tn-encoding frb)
 923                    ,xo
 924                    ,rc))))
 925
 926            (define-2-a-instructions (name op xo &key (cost 1) other-dependencies)
 927                `(progn
 928                  (define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
 929                  (define-a-instruction ,(symbolicate name ".")
 930                      ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
 931
 932            (define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies)
 933                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 934                  `(define-instruction ,name (segment frt fra frb)
 935                    (:printer a-tab ((op ,op) (xo ,xo) (rc ,rc)))
 936                    (:cost ,cost)
 937                    (:delay 1)
 938                    (:dependencies (reads fra) (reads frb) ,@other-reads
 939                     (writes frt) ,@other-writes)
 940                    (:emitter
 941                     (emit-a-form-inst segment
 942                      ,op
 943                      (fp-reg-tn-encoding frt)
 944                      (fp-reg-tn-encoding fra)
 945                      (fp-reg-tn-encoding frb)
 946                      0
 947                      ,xo
 948                      ,rc)))))
 949
 950            (define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies)
 951                `(progn
 952                  (define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
 953                  (define-a-tab-instruction ,(symbolicate name ".")
 954                      ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
 955
 956            (define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies)
 957                (multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
 958                  `(define-instruction ,name (segment frt fra frc)
 959                    (:printer a-tac ((op ,op) (xo ,xo) (rc ,rc)))
 960                    (:cost ,cost)
 961                    (:delay 1)
 962                    (:dependencies (reads fra) (reads frb) ,@other-reads
 963                     (writes frt) ,@other-writes)
 964                    (:emitter
 965                     (emit-a-form-inst segment
 966                      ,op
 967                      (fp-reg-tn-encoding frt)
 968                      (fp-reg-tn-encoding fra)
 969                      0
 970                      (fp-reg-tn-encoding frc)
 971                      ,xo
 972                      ,rc)))))
 973
 974            (define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies)
 975                `(progn
 976                  (define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
 977                  (define-a-tac-instruction ,(symbolicate name ".")
 978                      ,op ,xo 1  :cost ,cost :other-dependencies ,other-dependencies)))
 979
 980            (define-crbit-instruction (name op xo)
 981                `(define-instruction ,name (segment dbit abit bbit)
 982                  (:printer xl ((op ,op ) (xo ,xo)))
 983                  (:delay 1)
 984                  (:cost 1)
 985                  (:dependencies (reads :ccr) (writes :ccr))
 986                  (:emitter (emit-x-form-inst segment 19
 987                             (valid-bi-encoding dbit)
 988                             (valid-bi-encoding abit)
 989                             (valid-bi-encoding bbit)
 990                             ,xo
 991                             0)))))
 992
 993    ;;; The instructions, in numerical order
 994
 995   (define-instruction unimp (segment data)
 996     (:declare (type (signed-byte 16) data))
 997     (:printer xinstr ((op-to-a #.(logior (ash 3 10) (ash 6 5) 0)))
 998               :default :control #'unimp-control)
 999     :pinned
1000     (:delay 0)
1001     (:emitter (emit-d-form-inst segment 3 6 0 data)))
1002
1003   (define-instruction twi (segment tcond ra si)
1004     (:printer d-to ((op 3)))
1005     (:delay 1)
1006     :pinned
1007     (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si)))
1008
1009   (define-d-si-instruction mulli 7 :cost 5)
1010   (define-d-si-instruction subfic 8)
1011
1012   (define-instruction cmplwi (segment crf ra &optional (ui nil ui-p))
1013     (:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui))
1014     (:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr))
1015     (:delay 1)
1016     (:emitter
1017      (unless ui-p
1018        (setq ui ra ra crf crf :cr0))
1019      (emit-d-form-inst segment
1020                        10
1021                        (valid-cr-field-encoding crf)
1022                        (reg-tn-encoding ra)
1023                        ui)))
1024
1025   (define-instruction cmpwi (segment crf ra  &optional (si nil si-p))
1026     (:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si))
1027     (:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr))
1028     (:delay 1)
1029     (:emitter
1030      (unless si-p
1031        (setq si ra ra crf crf :cr0))
1032      (emit-d-form-inst segment
1033                        11
1034                        (valid-cr-field-encoding crf)
1035                        (reg-tn-encoding ra)
1036                        si)))
1037
1038   (define-d-si-instruction addic 12 :other-dependencies ((writes :xer)))
1039   (define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr)))
1040
1041   (define-d-si-instruction addi 14 :fixup :l)
1042   (define-d-si-instruction addis 15 :fixup :ha)
1043
1044   ;; There's no real support here for branch options that decrement
1045   ;; and test the CTR :
1046   ;; (a) the instruction scheduler doesn't know that anything's happening
1047   ;;    to the CTR
1048   ;; (b) Lisp may have to assume that the CTR always has a lisp
1049   ;;    object/locative in it.
1050
1051   (define-instruction bc (segment bo bi target)
1052     (:declare (type label target))
1053     (:printer b ((op 16) (aa 0) (lk 0)))
1054     (:delay 1)
1055     (:dependencies (reads :ccr))
1056     (:emitter
1057      (emit-conditional-branch segment bo bi target)))
1058
1059   (define-instruction bcl (segment bo bi target)
1060     (:declare (type label target))
1061     (:printer b ((op 16) (aa 0) (lk 1)))
1062     (:delay 1)
1063     (:dependencies (reads :ccr))
1064     (:emitter
1065      (emit-conditional-branch segment bo bi target nil t)))
1066
1067   (define-instruction bca (segment bo bi target)
1068     (:declare (type label target))
1069     (:printer b ((op 16) (aa 1) (lk 0)))
1070     (:delay 1)
1071     (:dependencies (reads :ccr))
1072     (:emitter
1073      (emit-conditional-branch segment bo bi target t)))
1074
1075   (define-instruction bcla (segment bo bi target)
1076     (:declare (type label target))
1077     (:printer b ((op 16) (aa 1) (lk 1)))
1078     (:delay 1)
1079     (:dependencies (reads :ccr))
1080     (:emitter
1081      (emit-conditional-branch segment bo bi target t t)))
1082
1083 ;;; There may (or may not) be a good reason to use this in preference to "b[la] target".
1084 ;;; I can't think of a -bad- reason ...
1085
1086   (define-instruction bu (segment target)
1087     (:declare (type label target))
1088     (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0))
1089               '(:name :tab bd))
1090     (:delay 1)
1091     (:emitter
1092      (emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil)))
1093
1094
1095   (define-instruction bt (segment bi  target)
1096     (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-t)) (aa 0) (lk 0))
1097               '(:name :tab bi "," bd))
1098     (:delay 1)
1099     (:emitter
1100      (emit-conditional-branch segment #.(valid-bo-encoding :bo-t) bi target nil nil)))
1101
1102   (define-instruction bf (segment bi  target)
1103     (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-f)) (aa 0) (lk 0))
1104               '(:name :tab bi "," bd))
1105     (:delay 1)
1106     (:emitter
1107      (emit-conditional-branch segment #.(valid-bo-encoding :bo-f) bi target nil nil)))
1108
1109   (define-instruction b? (segment cr-field-name cr-name  &optional (target nil target-p))
1110     (:delay 1)
1111     (:emitter
1112      (unless target-p
1113        (setq target cr-name cr-name cr-field-name cr-field-name :cr0))
1114      (let*  ((+cond (position cr-name cr-bit-names))
1115              (-cond (position cr-name cr-bit-inverse-names))
1116              (b0 (if +cond :bo-t
1117                      (if -cond
1118                          :bo-f
1119                          (error "Unknown branch condition ~s" cr-name))))
1120              (cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond)))))
1121        (emit-conditional-branch segment b0 cr-form target))))
1122
1123   (define-instruction sc (segment)
1124     (:printer sc ((op 17)))
1125     (:delay 1)
1126     :pinned
1127     (:emitter (emit-sc-form-inst segment 17 2)))
1128
1129   (define-instruction b (segment target)
1130     (:printer i ((op 18) (aa 0) (lk 0)))
1131     (:delay 1)
1132     (:emitter
1133      (emit-i-form-branch segment target nil)))
1134
1135   (define-instruction ba (segment target)
1136     (:printer i-abs ((op 18) (aa 1) (lk 0)))
1137     (:delay 1)
1138     (:emitter
1139      (when (typep target 'fixup)
1140        (note-fixup segment :ba target)
1141        (setq target 0))
1142      (emit-i-form-inst segment 18 (ash target -2) 1 0)))
1143
1144
1145   (define-instruction bl (segment target)
1146     (:printer i ((op 18) (aa 0) (lk 1)))
1147     (:delay 1)
1148     (:emitter
1149      (emit-i-form-branch segment target t)))
1150
1151   (define-instruction bla (segment target)
1152     (:printer i-abs ((op 18) (aa 1) (lk 1)))
1153     (:delay 1)
1154     (:emitter
1155      (when (typep target 'fixup)
1156        (note-fixup segment :ba target)
1157        (setq target 0))
1158      (emit-i-form-inst segment 18 (ash target -2) 1 1)))
1159
1160   (define-instruction blr (segment)
1161     (:printer xl-bo-bi ((op 19) (xo 16) (bo #.(valid-bo-encoding :bo-u))(bi 0) (lk 0))  '(:name))
1162     (:delay 1)
1163     (:dependencies (reads :ccr) (reads :ctr))
1164     (:emitter
1165      (emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0)))
1166
1167   (define-instruction bclr (segment bo bi)
1168     (:printer xl-bo-bi ((op 19) (xo 16)))
1169     (:delay 1)
1170     (:dependencies (reads :ccr) (reads :lr))
1171     (:emitter
1172      (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0)))
1173
1174   (define-instruction bclrl (segment bo bi)
1175     (:printer xl-bo-bi ((op 19) (xo 16) (lk 1)))
1176     (:delay 1)
1177     (:dependencies (reads :ccr) (reads :lr))
1178     (:emitter
1179      (emit-x-form-inst segment 19 (valid-bo-encoding bo)
1180                        (valid-bi-encoding bi) 0 16 1)))
1181
1182   (define-crbit-instruction crnor 19 33)
1183   (define-crbit-instruction crandc 19 129)
1184   (define-instruction isync (segment)
1185     (:printer xl-xo ((op 19) (xo 150)))
1186     (:delay 1)
1187     :pinned
1188     (:emitter (emit-x-form-inst segment 19 0 0 0 150 0)))
1189
1190   (define-crbit-instruction crxor 19 193)
1191   (define-crbit-instruction crnand 19 225)
1192   (define-crbit-instruction crand 19 257)
1193   (define-crbit-instruction creqv 19 289)
1194   (define-crbit-instruction crorc 19 417)
1195   (define-crbit-instruction cror 19 449)
1196
1197   (define-instruction bcctr (segment bo bi)
1198     (:printer xl-bo-bi ((op 19) (xo 528)))
1199     (:delay 1)
1200     (:dependencies (reads :ccr) (reads :ctr))
1201     (:emitter
1202      (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0)))
1203
1204   (define-instruction bcctrl (segment bo bi)
1205     (:printer xl-bo-bi ((op 19) (xo 528) (lk 1)))
1206     (:delay 1)
1207     (:dependencies (reads :ccr) (reads :ctr) (writes :lr))
1208     (:emitter
1209      (emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1)))
1210
1211   (define-instruction bctr (segment)
1212     (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 0))  '(:name))
1213     (:delay 1)
1214     (:dependencies (reads :ccr) (reads :ctr))
1215     (:emitter
1216      (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0  528 0)))
1217
1218   (define-instruction bctrl (segment)
1219     (:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 1))  '(:name))
1220     (:delay 1)
1221     (:dependencies (reads :ccr) (reads :ctr))
1222     (:emitter
1223      (emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0  528 1)))
1224
1225   (define-instruction rlwimi (segment ra rs sh mb me)
1226     (:printer m-sh ((op 20) (rc 0)))
1227     (:dependencies (reads rs) (writes ra))
1228     (:delay 1)
1229     (:emitter
1230      (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1231
1232   (define-instruction rlwimi. (segment ra rs sh mb me)
1233     (:printer m-sh ((op 20) (rc 1)))
1234     (:dependencies (reads rs) (writes ra) (writes :ccr))
1235     (:delay 1)
1236     (:emitter
1237      (emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1238
1239   (define-instruction rlwinm (segment ra rs sh mb me)
1240     (:printer m-sh ((op 21) (rc 0)))
1241     (:delay 1)
1242     (:dependencies (reads rs) (writes ra))
1243     (:emitter
1244      (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
1245
1246   (define-instruction rlwinm. (segment ra rs sh mb me)
1247     (:printer m-sh ((op 21) (rc 1)))
1248     (:delay 1)
1249     (:dependencies (reads rs) (writes ra) (writes :ccr))
1250     (:emitter
1251      (emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
1252
1253   (define-instruction rlwnm (segment ra rs rb mb me)
1254     (:printer m ((op 23) (rc 0) (rb nil :type 'reg)))
1255     (:delay 1)
1256     (:dependencies (reads rs) (writes ra) (reads rb))
1257     (:emitter
1258      (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0)))
1259
1260   (define-instruction rlwnm. (segment ra rs rb mb me)
1261     (:printer m ((op 23) (rc 1) (rb nil :type 'reg)))
1262     (:delay 1)
1263     (:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr))
1264     (:emitter
1265      (emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1)))
1266
1267
1268   (define-d-rs-ui-instruction ori 24)
1269
1270   (define-instruction nop (segment)
1271     (:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name))
1272     (:cost 1)
1273     (:delay 1)
1274     (:emitter
1275      (emit-d-form-inst segment 24 0 0 0)))
1276
1277   (define-d-rs-ui-instruction oris 25)
1278   (define-d-rs-ui-instruction xori 26)
1279   (define-d-rs-ui-instruction xoris 27)
1280   (define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr)))
1281   (define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr)))
1282
1283   (define-instruction cmpw (segment crf ra  &optional (rb nil rb-p))
1284     (:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb))
1285     (:delay 1)
1286     (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1287     (:emitter
1288      (unless rb-p
1289        (setq rb ra ra crf crf :cr0))
1290      (emit-x-form-inst segment
1291                        31
1292                        (valid-cr-field-encoding crf)
1293                        (reg-tn-encoding ra)
1294                        (reg-tn-encoding rb)
1295                        0
1296                        0)))
1297
1298   (define-instruction tw (segment tcond ra rb)
1299     (:printer x-19 ((op 31) (xo 4)))
1300     (:delay 1)
1301     :pinned
1302     (:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0)))
1303
1304   (define-4-xo-instructions subfc 31 8 :always-writes-xer t)
1305   (define-4-xo-instructions addc 31 10 :always-writes-xer t)
1306   (define-2-xo-oe-instructions mulhwu 31 11 :cost 5)
1307
1308   (define-instruction mfcr (segment rd)
1309     (:printer x-4 ((op 31) (xo 19)))
1310     (:delay 1)
1311     (:dependencies (reads :ccr) (writes rd))
1312     (:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0)))
1313
1314   (define-x-instruction lwarx 31 20)
1315   (define-x-instruction lwzx 31 23)
1316   (define-2-x-5-instructions slw 31 24)
1317   (define-2-x-10-instructions cntlzw 31 26)
1318   (define-2-x-5-instructions and 31 28)
1319
1320   (define-instruction cmplw (segment crf ra  &optional (rb nil rb-p))
1321     (:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb))
1322     (:delay 1)
1323     (:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
1324     (:emitter
1325      (unless rb-p
1326        (setq rb ra ra crf crf :cr0))
1327      (emit-x-form-inst segment
1328                        31
1329                        (valid-cr-field-encoding crf)
1330                        (reg-tn-encoding ra)
1331                        (reg-tn-encoding rb)
1332                        32
1333                        0)))
1334
1335
1336   (define-4-xo-instructions subf 31 40)
1337                                         ; dcbst
1338   (define-x-instruction lwzux 31 55 :other-dependencies ((writes rt)))
1339   (define-2-x-5-instructions andc 31 60)
1340   (define-2-xo-oe-instructions mulhw 31 75 :cost 5)
1341
1342   (define-x-instruction lbzx 31 87)
1343   (define-4-xo-a-instructions neg 31 104)
1344   (define-x-instruction lbzux 31 119 :other-dependencies ((writes rt)))
1345   (define-2-x-5-instructions nor 31 124)
1346   (define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t)
1347
1348   (define-instruction-macro sube (rt ra rb)
1349     `(inst subfe ,rt ,rb ,ra))
1350
1351   (define-instruction-macro sube. (rt ra rb)
1352     `(inst subfe. ,rt ,rb ,ra))
1353
1354   (define-instruction-macro subeo (rt ra rb)
1355     `(inst subfeo ,rt ,rb ,ra))
1356
1357   (define-instruction-macro subeo. (rt ra rb)
1358     `(inst subfeo ,rt ,rb ,ra))
1359
1360   (define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t)
1361
1362   (define-instruction mtcrf (segment mask rt)
1363     (:printer xfx-fxm ((op 31) (xo 144)))
1364     (:delay 1)
1365     (:dependencies (reads rt) (writes :ccr))
1366     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0)))
1367
1368   (define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr)))
1369   (define-x-5-st-instruction stwx 31 151 nil)
1370   (define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra)))
1371   (define-4-xo-a-instructions subfze 31 200 :always-reads-xer t :always-writes-xer t)
1372   (define-4-xo-a-instructions addze 31 202 :always-reads-xer t :always-writes-xer t)
1373   (define-x-5-st-instruction stbx 31 215 nil)
1374   (define-4-xo-a-instructions subfme 31 232 :always-reads-xer t :always-writes-xer t)
1375   (define-4-xo-a-instructions addme 31 234 :always-reads-xer t :always-writes-xer t)
1376   (define-4-xo-instructions mullw 31 235 :cost 5)
1377   (define-x-5-st-instruction stbux 31 247 nil :other-dependencies ((writes ra)))
1378   (define-4-xo-instructions add 31 266)
1379   (define-x-instruction lhzx 31 279)
1380   (define-2-x-5-instructions eqv 31 284)
1381   (define-x-instruction lhzux 31 311 :other-dependencies ((writes ra)))
1382   (define-2-x-5-instructions xor 31 316)
1383
1384   (define-instruction mfmq (segment rt)
1385     (:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt))
1386     (:delay 1)
1387     (:dependencies (reads :xer) (writes rt))
1388     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0)))
1389
1390   (define-instruction mfxer (segment rt)
1391     (:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt))
1392     (:delay 1)
1393     (:dependencies (reads :xer) (writes rt))
1394     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0)))
1395
1396   (define-instruction mflr (segment rt)
1397     (:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt))
1398     (:delay 1)
1399     (:dependencies (reads :lr) (writes rt))
1400     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0)))
1401
1402   (define-instruction mfctr (segment rt)
1403     (:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt))
1404     (:delay 1)
1405     (:dependencies (reads rt) (reads :ctr))
1406     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0)))
1407
1408
1409   (define-x-instruction lhax 31 343)
1410   (define-x-instruction lhaux 31 375 :other-dependencies ((writes ra)))
1411   (define-x-5-st-instruction sthx 31 407 nil)
1412   (define-2-x-5-instructions orc 31 412)
1413   (define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra)))
1414
1415   (define-instruction or (segment ra rs rb)
1416     (:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond
1417                                                 ((rs :same-as rb) 'mr)
1418                                                 (t :name))
1419                                               :tab
1420                                               ra "," rs
1421                                               (:unless (:same-as rs) "," rb)))
1422     (:delay 1)
1423     (:cost 1)
1424     (:dependencies (reads rb) (reads rs) (writes ra))
1425     (:emitter
1426      (emit-x-form-inst segment
1427                        31
1428                        (reg-tn-encoding rs)
1429                        (reg-tn-encoding ra)
1430                        (reg-tn-encoding rb)
1431                        444
1432                        0)))
1433
1434   (define-instruction or. (segment ra rs rb)
1435     (:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond
1436                                                 ((rs :same-as rb) 'mr.)
1437                                                 (t :name))
1438                                               :tab
1439                                               ra "," rs
1440                                               (:unless (:same-as rs) "," rb)))
1441     (:delay 1)
1442     (:cost 1)
1443     (:dependencies (reads rb) (reads rs) (writes ra))
1444     (:emitter
1445      (emit-x-form-inst segment
1446                        31
1447                        (reg-tn-encoding rs)
1448                        (reg-tn-encoding ra)
1449                        (reg-tn-encoding rb)
1450                        444
1451                        1)))
1452
1453   (define-instruction-macro mr (ra rs)
1454     `(inst or ,ra ,rs ,rs))
1455
1456   (define-instruction-macro mr. (ra rs)
1457     `(inst or. ,ra ,rs ,rs))
1458
1459   (define-4-xo-instructions divwu 31 459 :cost 36)
1460
1461                                         ; This is a 601-specific instruction class.
1462   (define-4-xo-instructions div 31 331 :cost 36)
1463
1464                                         ; This is a 601-specific instruction.
1465   (define-instruction mtmq (segment rt)
1466     (:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt))
1467     (:delay 1)
1468     (:dependencies (reads rt) (writes :xer))
1469     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0)))
1470
1471   (define-instruction mtxer (segment rt)
1472     (:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt))
1473     (:delay 1)
1474     (:dependencies (reads rt) (writes :xer))
1475     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0)))
1476
1477   (define-instruction mtlr (segment rt)
1478     (:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt))
1479     (:delay 1)
1480     (:dependencies (reads rt) (writes :lr))
1481     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0)))
1482
1483   (define-instruction mtctr (segment rt)
1484     (:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt))
1485     (:delay 1)
1486     (:dependencies (reads rt) (writes :ctr))
1487     (:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0)))
1488
1489
1490   (define-2-x-5-instructions nand 31 476)
1491   (define-4-xo-instructions divw 31 491 :cost 36)
1492   (define-instruction mcrxr (segment crf)
1493     (:printer x-18 ((op 31) (xo 512)))
1494     (:delay 1)
1495     (:dependencies (reads :xer) (writes :ccr) (writes :xer))
1496     (:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0)))
1497
1498   (define-instruction lswx (segment rs ra rb)
1499     (:printer x ((op 31) (xo 533) (rc 0)))
1500     (:delay 1)
1501     :pinned
1502     (:cost 8)
1503     (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0)))
1504   (define-x-instruction lwbrx 31 534)
1505   (define-x-20-instruction lfsx 31 535)
1506   (define-2-x-5-instructions srw 31 536)
1507   (define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra)))
1508
1509   (define-instruction lswi (segment rt ra rb)
1510     (:printer x-1 ((op 31) (xo 597) (rc 0)))
1511     :pinned
1512     (:delay 8)
1513     (:cost 8)
1514     (:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0)))
1515
1516   (define-instruction sync (segment)
1517     (:printer x-27 ((op 31) (xo 598)))
1518     (:delay 1)
1519     :pinned
1520     (:emitter (emit-x-form-inst segment 31 0 0 0 598 0)))
1521   (define-x-20-instruction lfdx 31 599)
1522   (define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra)))
1523   (define-instruction stswx (segment rs ra rb)
1524     (:printer x-5 ((op 31) (xo 661)))
1525     :pinned
1526     (:cost 8)
1527     (:delay 1)
1528     (:emitter (emit-x-form-inst sb!assem:segment 31
1529                                 (reg-tn-encoding rs)
1530                                 (reg-tn-encoding ra)
1531                                 (reg-tn-encoding rb)
1532                                 661
1533                                 0)))
1534   (define-x-5-st-instruction stwbrx 31 662 nil)
1535   (define-x-23-st-instruction stfsx 31 663)
1536   (define-x-23-st-instruction stfsux 31 695 :other-dependencies ((writes ra)))
1537   (define-instruction stswi (segment rs ra nb)
1538     (:printer x-8 ((op 31) (xo 725)))
1539     :pinned
1540     (:delay 1)
1541     (:emitter
1542      (emit-x-form-inst segment 31
1543                        (reg-tn-encoding rs)
1544                        (reg-tn-encoding ra)
1545                        nb
1546                        725
1547                        0)))
1548
1549   (define-x-23-st-instruction stfdx 31 727)
1550   (define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra)))
1551   (define-x-instruction lhbrx 31 790)
1552   (define-2-x-5-instructions sraw 31 792)
1553
1554   (define-instruction srawi (segment ra rs rb)
1555     (:printer x-9 ((op 31) (xo 824) (rc 0)))
1556     (:cost 1)
1557     (:delay 1)
1558     (:dependencies (reads rs) (writes ra))
1559     (:emitter
1560      (emit-x-form-inst segment 31
1561                        (reg-tn-encoding rs)
1562                        (reg-tn-encoding ra)
1563                        rb
1564                        824
1565                        0)))
1566
1567   (define-instruction srawi. (segment ra rs rb)
1568     (:printer x-9 ((op 31) (xo 824) (rc 1)))
1569     (:cost 1)
1570     (:delay 1)
1571     (:dependencies (reads rs) (writes ra))
1572     (:emitter
1573      (emit-x-form-inst segment 31
1574                        (reg-tn-encoding rs)
1575                        (reg-tn-encoding ra)
1576                        rb
1577                        824
1578                         1)))
1579
1580   (define-instruction eieio (segment)
1581     (:printer x-27 ((op 31) (xo 854)))
1582     :pinned
1583     (:delay 1)
1584     (:emitter (emit-x-form-inst segment 31 0 0 0 854 0)))
1585
1586   (define-x-5-st-instruction sthbrx 31 918 nil)
1587
1588   (define-2-x-10-instructions extsb 31 954)
1589   (define-2-x-10-instructions extsh 31 922)
1590                                         ; Whew.
1591
1592   (define-instruction lwz (segment rt ra si)
1593     (:declare (type (or fixup (signed-byte 16)) si))
1594     (:printer d ((op 32)))
1595     (:delay 2)
1596     (:cost 2)
1597     (:dependencies (reads ra) (writes rt))
1598     (:emitter
1599      (when (typep si 'fixup)
1600        (note-fixup segment :l si)
1601        (setq si 0))
1602      (emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si)))
1603
1604   (define-d-instruction lwzu 33 :other-dependencies ((writes ra)))
1605   (define-d-instruction lbz 34)
1606   (define-d-instruction lbzu 35 :other-dependencies ((writes ra)))
1607   (define-d-rs-instruction stw 36)
1608   (define-d-rs-instruction stwu 37 :other-dependencies ((writes ra)))
1609   (define-d-rs-instruction stb 38)
1610   (define-d-rs-instruction stbu 39 :other-dependencies ((writes ra)))
1611   (define-d-instruction lhz 40)
1612   (define-d-instruction lhzu 41 :other-dependencies ((writes ra)))
1613   (define-d-instruction lha 42)
1614   (define-d-instruction lhau 43 :other-dependencies ((writes ra)))
1615   (define-d-rs-instruction sth 44)
1616   (define-d-rs-instruction sthu 45 :other-dependencies ((writes ra)))
1617   (define-d-instruction lmw 46 :pinned t)
1618   (define-d-rs-instruction stmw 47 :pinned t)
1619   (define-d-frt-instruction lfs 48)
1620   (define-d-frt-instruction lfsu 49 :other-dependencies ((writes ra)))
1621   (define-d-frt-instruction lfd 50)
1622   (define-d-frt-instruction lfdu 51 :other-dependencies ((writes ra)))
1623   (define-d-frs-instruction stfs 52)
1624   (define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra)))
1625   (define-d-frs-instruction stfd 54)
1626   (define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra)))
1627
1628   (define-2-a-tab-instructions fdivs 59 18 :cost 17)
1629   (define-2-a-tab-instructions fsubs 59 20)
1630   (define-2-a-tab-instructions fadds 59 21)
1631   (define-2-a-tac-instructions fmuls 59 25)
1632   (define-2-a-instructions fmsubs 59 28 :cost 4)
1633   (define-2-a-instructions fmadds 59 29 :cost 4)
1634   (define-2-a-instructions fnmsubs 59 30 :cost 4)
1635   (define-2-a-instructions fnmadds 59 31 :cost 4)
1636
1637   (define-instruction fcmpu (segment crfd fra frb)
1638     (:printer x-15 ((op 63) (xo 0)))
1639     (:dependencies (reads fra) (reads frb) (reads :fpscr)
1640                    (writes :fpscr) (writes :ccr))
1641     (:cost 4)
1642     (:delay 4)
1643     (:emitter (emit-x-form-inst segment
1644                                 63
1645                                 (valid-cr-field-encoding crfd)
1646                                 (fp-reg-tn-encoding fra)
1647                                 (fp-reg-tn-encoding frb)
1648                                 0
1649                                 0)))
1650
1651
1652   (define-2-x-21-instructions frsp 63 12)
1653   (define-2-x-21-instructions fctiw 63 14)
1654   (define-2-x-21-instructions fctiwz 63 15)
1655
1656   (define-2-a-tab-instructions fdiv 63 18 :cost 31)
1657   (define-2-a-tab-instructions fsub 63 20)
1658   (define-2-a-tab-instructions fadd 63 21)
1659   (define-2-a-tac-instructions fmul 63 25 :cost 5)
1660   (define-2-a-instructions fmsub 63 28 :cost 5)
1661   (define-2-a-instructions fmadd 63 29 :cost 5)
1662   (define-2-a-instructions fnmsub 63 30 :cost 5)
1663   (define-2-a-instructions fnmadd 63 31 :cost 5)
1664
1665   (define-instruction fcmpo (segment crfd fra frb)
1666     (:printer x-15 ((op 63) (xo 32)))
1667     (:dependencies (reads fra) (reads frb) (reads :fpscr)
1668                    (writes :fpscr) (writes :ccr))
1669     (:cost 4)
1670     (:delay 1)
1671     (:emitter (emit-x-form-inst segment
1672                                 63
1673                                 (valid-cr-field-encoding crfd)
1674                                 (fp-reg-tn-encoding fra)
1675                                 (fp-reg-tn-encoding frb)
1676                                 32
1677                               0)))
1678
1679   (define-2-x-21-instructions fneg 63 40)
1680
1681   (define-2-x-21-instructions fmr 63 72)
1682   (define-2-x-21-instructions fnabs 63 136)
1683   (define-2-x-21-instructions fabs 63 264)
1684
1685   (define-instruction mffs (segment frd)
1686   (:printer x-22 ((op 63)  (xo 583) (rc 0)))
1687   (:delay 1)
1688   (:dependencies (reads :fpscr) (writes frd))
1689   (:emitter (emit-x-form-inst segment
1690                           63
1691                           (fp-reg-tn-encoding frd)
1692                           0
1693                           0
1694                           583
1695                           0)))
1696
1697   (define-instruction mffs. (segment frd)
1698   (:printer x-22 ((op 63)  (xo 583) (rc 1)))
1699   (:delay 1)
1700   (:dependencies (reads :fpscr) (writes frd))
1701   (:emitter (emit-x-form-inst segment
1702                           63
1703                           (fp-reg-tn-encoding frd)
1704                           0
1705                           0
1706                           583
1707                           1)))
1708
1709   (define-instruction mtfsf (segment mask rb)
1710   (:printer xfl ((op 63) (xo 711) (rc 0)))
1711   (:dependencies (reads rb) (writes :fpscr))
1712   (:delay 1)
1713   (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 0)))
1714
1715   (define-instruction mtfsf. (segment mask rb)
1716   (:printer xfl ((op 63) (xo 711) (rc 1)))
1717   (:delay 1)
1718   (:dependencies (reads rb) (writes :ccr) (writes :fpscr))
1719   (:emitter (emit-xfl-form-inst segment 63  (ash mask 1) (fp-reg-tn-encoding rb) 711 1)))
1720
1721
1722
1723 \f
1724 ;;; Here in the future, macros are our friends.
1725
1726   (define-instruction-macro subis (rt ra simm)
1727     `(inst addis ,rt ,ra (- ,simm)))
1728
1729   (define-instruction-macro sub (rt rb ra)
1730     `(inst subf ,rt ,ra ,rb))
1731   (define-instruction-macro sub. (rt rb ra)
1732     `(inst subf. ,rt ,ra ,rb))
1733   (define-instruction-macro subo (rt rb ra)
1734     `(inst subfo ,rt ,ra ,rb))
1735   (define-instruction-macro subo. (rt rb ra)
1736     `(inst subfo. ,rt ,ra ,rb))
1737
1738
1739   (define-instruction-macro subic (rt ra simm)
1740     `(inst addic ,rt ,ra (- ,simm)))
1741
1742
1743   (define-instruction-macro subic. (rt ra simm)
1744     `(inst addic. ,rt ,ra (- ,simm)))
1745
1746
1747
1748   (define-instruction-macro subc (rt rb ra)
1749     `(inst subfc ,rt ,ra ,rb))
1750   (define-instruction-macro subc. (rt rb ra)
1751     `(inst subfc. ,rt ,ra ,rb))
1752   (define-instruction-macro subco (rt rb ra)
1753     `(inst subfco ,rt ,ra ,rb))
1754   (define-instruction-macro subco. (rt rb ra)
1755     `(inst subfco. ,rt ,ra ,rb))
1756
1757   (define-instruction-macro subi (rt ra simm)
1758     `(inst addi ,rt ,ra (- ,simm)))
1759
1760   (define-instruction-macro li (rt val)
1761     `(inst addi ,rt zero-tn ,val))
1762
1763   (define-instruction-macro lis (rt val)
1764     `(inst addis ,rt zero-tn ,val))
1765
1766
1767   (define-instruction-macro not (ra rs)
1768     `(inst nor ,ra ,rs ,rs))
1769
1770   (define-instruction-macro not. (ra rs)
1771     `(inst nor. ,ra ,rs ,rs))
1772
1773
1774   (!def-vm-support-routine emit-nop (segment)
1775                            (emit-word segment #x60000000))
1776
1777   (define-instruction-macro extlwi (ra rs n b)
1778     `(inst rlwinm ,ra ,rs ,b 0 (1- ,n)))
1779
1780   (define-instruction-macro extlwi. (ra rs n b)
1781     `(inst rlwinm. ,ra ,rs ,b 0 (1- ,n)))
1782
1783   (define-instruction-macro srwi (ra rs n)
1784     `(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31))
1785
1786   (define-instruction-macro srwi. (ra rs n)
1787     `(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31))
1788
1789   (define-instruction-macro clrrwi (ra rs n)
1790     `(inst rlwinm ,ra ,rs 0 0 (- 31 ,n)))
1791
1792   (define-instruction-macro clrrwi. (ra rs n)
1793     `(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n)))
1794
1795   (define-instruction-macro inslw (ra rs n b)
1796     `(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1797
1798   (define-instruction-macro inslw. (ra rs n b)
1799     `(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
1800
1801   (define-instruction-macro rotlw (ra rs rb)
1802     `(inst rlwnm ,ra ,rs ,rb 0 31))
1803
1804   (define-instruction-macro rotlw. (ra rs rb)
1805     `(inst rlwnm. ,ra ,rs ,rb 0 31))
1806
1807   (define-instruction-macro rotlwi (ra rs n)
1808     `(inst rlwinm ,ra ,rs ,n 0 31))
1809
1810   (define-instruction-macro rotrwi (ra rs n)
1811     `(inst rlwinm ,ra ,rs (- 32 ,n) 0 31))
1812
1813   (define-instruction-macro slwi (ra rs n)
1814     `(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n)))
1815
1816   (define-instruction-macro slwi. (ra rs n)
1817     `(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n))))
1818
1819
1820
1821
1822 #|
1823 (macrolet
1824   ((define-conditional-branches (name bo-name)
1825      (let* ((bo-enc (valid-bo-encoding bo-name)))
1826        `(progn
1827           (define-instruction-macro ,(symbolicate name "A") (bi target)
1828             ``(inst bca ,,,bo-enc ,,bi ,,target))
1829           (define-instruction-macro ,(symbolicate name "L") (bi target)
1830             ``(inst bcl ,,,bo-enc ,,bi ,,target))
1831           (define-instruction-macro ,(symbolicate name "LA") (bi target)
1832             ``(inst bcla ,,,bo-enc ,,bi ,,target))
1833           (define-instruction-macro ,(symbolicate name "CTR") (bi target)
1834             ``(inst bcctr ,,,bo-enc ,,bi ,,target))
1835           (define-instruction-macro ,(symbolicate name "CTRL") (bi target)
1836             ``(inst bcctrl ,,,bo-enc ,,bi ,,target))
1837           (define-instruction-macro ,(symbolicate name "LR") (bi target)
1838             ``(inst bclr ,,,bo-enc ,,bi ,,target))
1839           (define-instruction-macro ,(symbolicate name "LRL") (bi target)
1840             ``(inst bclrl ,,,bo-enc ,,bi ,,target))))))
1841   (define-conditional-branches bt :bo-t)
1842   (define-conditional-branches bf :bo-f))
1843 |#
1844
1845 (macrolet
1846   ((define-positive-conditional-branches (name cr-bit-name)
1847      `(progn
1848         (define-instruction-macro ,name (crf &optional (target nil target-p))
1849           (unless target-p
1850             (setq target crf crf :cr0))
1851           `(inst bt `(,,crf ,,,cr-bit-name) ,target))
1852 #|
1853         (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1854           ``(inst bta (,,cr-field ,,,cr-bit-name) ,,target))
1855         (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1856           ``(inst btl (,,cr-field ,,,cr-bit-name) ,,target))
1857         (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1858           ``(inst btla (,,cr-field ,,,cr-bit-name) ,,target))
1859         (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1860           ``(inst btctr (,,cr-field ,,,cr-bit-name) ,,target))
1861         (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1862           ``(inst btctrl (,,cr-field ,,,cr-bit-name) ,,target))
1863         (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1864           ``(inst btlr (,,cr-field ,,,cr-bit-name) ,,target))
1865         (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1866           ``(inst btlrl (,,cr-field ,,,cr-bit-name) ,,target))
1867 |#
1868         )))
1869   (define-positive-conditional-branches beq :eq)
1870   (define-positive-conditional-branches blt :lt)
1871   (define-positive-conditional-branches bgt :gt)
1872   (define-positive-conditional-branches bso :so)
1873   (define-positive-conditional-branches bun :so))
1874
1875
1876 (macrolet
1877   ((define-negative-conditional-branches (name cr-bit-name)
1878      `(progn
1879         (define-instruction-macro ,name (crf &optional (target nil target-p))
1880           (unless target-p
1881             (setq target crf crf :cr0))
1882           `(inst bf `(,,crf ,,,cr-bit-name) ,target))
1883 #|
1884         (define-instruction-macro ,(symbolicate name "A") (target &optional (cr-field :cr0))
1885           ``(inst bfa (,,cr-field ,,,cr-bit-name) ,,target))
1886         (define-instruction-macro ,(symbolicate name "L") (target &optional (cr-field :cr0))
1887           ``(inst bfl (,,cr-field ,,,cr-bit-name) ,,target))
1888         (define-instruction-macro ,(symbolicate name "LA") (target &optional (cr-field :cr0))
1889           ``(inst bfla (,,cr-field ,,,cr-bit-name) ,,target))
1890         (define-instruction-macro ,(symbolicate name "CTR") (target &optional (cr-field :cr0))
1891           ``(inst bfctr (,,cr-field ,,,cr-bit-name) ,,target))
1892         (define-instruction-macro ,(symbolicate name "CTRL") (target &optional (cr-field :cr0))
1893           ``(inst bfctrl (,,cr-field ,,,cr-bit-name) ,,target))
1894         (define-instruction-macro ,(symbolicate name "LR") (target &optional (cr-field :cr0))
1895           ``(inst bflr (,,cr-field ,,,cr-bit-name) ,,target))
1896         (define-instruction-macro ,(symbolicate name "LRL") (target &optional (cr-field :cr0))
1897           ``(inst bflrl (,,cr-field ,,,cr-bit-name) ,,target))
1898 |#
1899 )))
1900   (define-negative-conditional-branches bne :eq)
1901   (define-negative-conditional-branches bnl :lt)
1902   (define-negative-conditional-branches bge :lt)
1903   (define-negative-conditional-branches bng :gt)
1904   (define-negative-conditional-branches ble :gt)
1905   (define-negative-conditional-branches bns :so)
1906   (define-negative-conditional-branches bnu :so))
1907
1908
1909
1910 (define-instruction-macro j (func-tn offset)
1911   `(progn
1912     (inst addi lip-tn ,func-tn ,offset)
1913     (inst mtctr lip-tn)
1914     (inst bctr)))
1915
1916
1917 #|
1918 (define-instruction-macro bua (target)
1919   `(inst bca :bo-u 0 ,target))
1920
1921 (define-instruction-macro bul (target)
1922   `(inst bcl :bo-u 0 ,target))
1923
1924 (define-instruction-macro bula (target)
1925   `(inst bcla :bo-u 0 ,target))
1926
1927
1928 (define-instruction-macro blrl ()
1929   `(inst bclrl :bo-u 0))
1930
1931
1932
1933 |#
1934
1935
1936
1937
1938 \f
1939 ;;; Some more macros
1940
1941 (defun %lr (reg value)
1942   (etypecase value
1943     ((signed-byte 16)
1944      (inst li reg value))
1945     ((unsigned-byte 16)
1946      (inst ori reg zero-tn value))
1947     ((or (signed-byte 32) (unsigned-byte 32))
1948      (let* ((high-half (ldb (byte 16 16) value))
1949             (low-half (ldb (byte 16 0) value)))
1950        (declare (type (unsigned-byte 16) high-half low-half))
1951        (cond ((if (logbitp 15 low-half) (= high-half #xffff) (zerop high-half))
1952               (inst li reg low-half))
1953              (t
1954               (inst lis reg high-half)
1955               (unless (zerop low-half)
1956                 (inst ori reg reg low-half))))))
1957     (fixup
1958      (inst lis reg value)
1959      (inst addi reg reg value))))
1960
1961 (define-instruction-macro lr (reg value)
1962   `(%lr ,reg ,value))
1963
1964
1965 \f
1966 ;;;; Instructions for dumping data and header objects.
1967
1968 (define-instruction word (segment word)
1969   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
1970   :pinned
1971   (:delay 0)
1972   (:emitter
1973    (emit-word segment word)))
1974
1975 (define-instruction short (segment short)
1976   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
1977   :pinned
1978   (:delay 0)
1979   (:emitter
1980    (emit-short segment short)))
1981
1982 (define-instruction byte (segment byte)
1983   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
1984   :pinned
1985   (:delay 0)
1986   (:emitter
1987    (emit-byte segment byte)))
1988
1989 (define-bitfield-emitter emit-header-object 32
1990   (byte 24 8) (byte 8 0))
1991
1992 (defun emit-header-data (segment type)
1993   (emit-back-patch
1994    segment 4
1995    #'(lambda (segment posn)
1996        (emit-word segment
1997                   (logior type
1998                           (ash (+ posn (component-header-length))
1999                                (- n-widetag-bits word-shift)))))))
2000
2001 (define-instruction simple-fun-header-word (segment)
2002   :pinned
2003   (:delay 0)
2004   (:emitter
2005    (emit-header-data segment simple-fun-header-widetag)))
2006
2007 (define-instruction lra-header-word (segment)
2008   :pinned
2009   (:delay 0)
2010   (:emitter
2011    (emit-header-data segment return-pc-header-widetag)))
2012
2013 \f
2014 ;;;; Instructions for converting between code objects, functions, and lras.
2015 (defun emit-compute-inst (segment vop dst src label temp calc)
2016   (emit-chooser
2017    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
2018    segment 12 3
2019    #'(lambda (segment posn delta-if-after)
2020        (let ((delta (funcall calc label posn delta-if-after)))
2021          (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
2022            (emit-back-patch segment 4
2023                             #'(lambda (segment posn)
2024                                 (assemble (segment vop)
2025                                           (inst addi dst src
2026                                                 (funcall calc label posn 0)))))
2027            t)))
2028    #'(lambda (segment posn)
2029        (let ((delta (funcall calc label posn 0)))
2030          (assemble (segment vop)
2031                    (inst lis temp (ldb (byte 16 16) delta))
2032                    (inst ori temp temp (ldb (byte 16 0) delta))
2033                    (inst add dst src temp))))))
2034
2035 ;; this function is misnamed.  should be compute-code-from-lip,
2036 ;; if the use in xep-allocate-frame is typical
2037 ;; (someone says code = fn - header - label-offset + other-pointer-tag)
2038 (define-instruction compute-code-from-fn (segment dst src label temp)
2039   (:declare (type tn dst src temp) (type label label))
2040   (:attributes variable-length)
2041   (:dependencies (reads src) (writes dst) (writes temp))
2042   (:delay 0)
2043   (:vop-var vop)
2044   (:emitter
2045    (emit-compute-inst segment vop dst src label temp
2046                       #'(lambda (label posn delta-if-after)
2047                           (- other-pointer-lowtag
2048                              ;;function-pointer-type
2049                              (label-position label posn delta-if-after)
2050                              (component-header-length))))))
2051
2052 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
2053 (define-instruction compute-code-from-lra (segment dst src label temp)
2054   (:declare (type tn dst src temp) (type label label))
2055   (:attributes variable-length)
2056   (:dependencies (reads src) (writes dst) (writes temp))
2057   (:delay 0)
2058   (:vop-var vop)
2059   (:emitter
2060    (emit-compute-inst segment vop dst src label temp
2061                       #'(lambda (label posn delta-if-after)
2062                           (- (+ (label-position label posn delta-if-after)
2063                                 (component-header-length)))))))
2064
2065 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
2066 (define-instruction compute-lra-from-code (segment dst src label temp)
2067   (:declare (type tn dst src temp) (type label label))
2068   (:attributes variable-length)
2069   (:dependencies (reads src) (writes dst) (writes temp))
2070   (:delay 0)
2071   (:vop-var vop)
2072   (:emitter
2073    (emit-compute-inst segment vop dst src label temp
2074                       #'(lambda (label posn delta-if-after)
2075                           (+ (label-position label posn delta-if-after)
2076                              (component-header-length))))))