src/compiler/ppc/insts.lisp

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