src/compiler/ppc/insts.lisp

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