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