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