src/compiler/ppc/insts.lisp

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