src/compiler/mips/insts.lisp

   1 ;;; the instruction set definition for MIPS
   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 (setf *assem-scheduler-p* t)
  15 (setf *assem-max-locations* 68)
  16 \f
  17 ;;;; Constants, types, conversion functions, some disassembler stuff.
  18
  19 (defun reg-tn-encoding (tn)
  20   (declare (type tn tn))
  21   (sc-case tn
  22     (zero zero-offset)
  23     (null null-offset)
  24     (t
  25      (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
  26          (tn-offset tn)
  27          (error "~S isn't a register." tn)))))
  28
  29 (defun fp-reg-tn-encoding (tn)
  30   (declare (type tn tn))
  31   (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
  32     (error "~S isn't a floating-point register." tn))
  33   (tn-offset tn))
  34
  35 ;;;(sb!disassem:set-disassem-params :instruction-alignment 32)
  36
  37 (defvar *disassem-use-lisp-reg-names* t)
  38
  39 (!def-vm-support-routine location-number (loc)
  40   (etypecase loc
  41     (null)
  42     (number)
  43     (label)
  44     (fixup)
  45     (tn
  46      (ecase (sb-name (sc-sb (tn-sc loc)))
  47        (immediate-constant
  48         ;; Can happen if $ZERO or $NULL are passed in.
  49         nil)
  50        (registers
  51         (unless (zerop (tn-offset loc))
  52           (tn-offset loc)))
  53        (float-registers
  54         (+ (tn-offset loc) 32))))
  55     (symbol
  56      (ecase loc
  57        (:memory 0)
  58        (:hi-reg 64)
  59        (:low-reg 65)
  60        (:float-status 66)
  61        (:ctrl-stat-reg 67)
  62        (:r31 31)))))
  63
  64 (defparameter reg-symbols
  65   (map 'vector
  66        #'(lambda (name)
  67            (cond ((null name) nil)
  68                  (t (make-symbol (concatenate 'string "$" name)))))
  69        *register-names*))
  70
  71 (sb!disassem:define-arg-type reg
  72   :printer #'(lambda (value stream dstate)
  73                (declare (stream stream) (fixnum value))
  74                (let ((regname (aref reg-symbols value)))
  75                  (princ regname stream)
  76                  (sb!disassem:maybe-note-associated-storage-ref
  77                   value
  78                   'registers
  79                   regname
  80                   dstate))))
  81
  82 (defparameter float-reg-symbols
  83   #.(coerce
  84      (loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
  85      'vector))
  86
  87 (sb!disassem:define-arg-type fp-reg
  88   :printer #'(lambda (value stream dstate)
  89                (declare (stream stream) (fixnum value))
  90                (let ((regname (aref float-reg-symbols value)))
  91                  (princ regname stream)
  92                  (sb!disassem:maybe-note-associated-storage-ref
  93                   value
  94                   'float-registers
  95                   regname
  96                   dstate))))
  97
  98 (sb!disassem:define-arg-type control-reg
  99   :printer "(CR:#x~X)")
 100
 101 (sb!disassem:define-arg-type relative-label
 102   :sign-extend t
 103   :use-label #'(lambda (value dstate)
 104                  (declare (type (signed-byte 16) value)
 105                           (type sb!disassem:disassem-state dstate))
 106                  (+ (ash (1+ value) 2) (sb!disassem:dstate-cur-addr dstate))))
 107
 108 (deftype float-format ()
 109   '(member :s :single :d :double :w :word))
 110
 111 (defun float-format-value (format)
 112   (ecase format
 113     ((:s :single) 0)
 114     ((:d :double) 1)
 115     ((:w :word) 4)))
 116
 117 (sb!disassem:define-arg-type float-format
 118   :printer #'(lambda (value stream dstate)
 119                (declare (ignore dstate)
 120                         (stream stream)
 121                         (fixnum value))
 122                (princ (case value
 123                         (0 's)
 124                         (1 'd)
 125                         (4 'w)
 126                         (t '?))
 127                       stream)))
 128
 129 (defconstant-eqx compare-kinds
 130   '(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)
 131   #'equalp)
 132
 133 (defconstant-eqx compare-kinds-vec
 134   (apply #'vector compare-kinds)
 135   #'equalp)
 136
 137 (deftype compare-kind ()
 138   `(member ,@compare-kinds))
 139
 140 (defun compare-kind (kind)
 141   (or (position kind compare-kinds)
 142       (error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
 143              kind
 144              compare-kinds)))
 145
 146 (sb!disassem:define-arg-type compare-kind
 147   :printer compare-kinds-vec)
 148
 149 (defconstant-eqx float-operations '(+ - * /) #'equalp)
 150
 151 (deftype float-operation ()
 152   `(member ,@float-operations))
 153
 154 (defconstant-eqx float-operation-names
 155   ;; this gets used for output only
 156   #(add sub mul div)
 157   #'equalp)
 158
 159 (defun float-operation (op)
 160   (or (position op float-operations)
 161       (error "Unknown floating point operation: ~S~%Must be one of: ~S"
 162              op
 163              float-operations)))
 164
 165 (sb!disassem:define-arg-type float-operation
 166   :printer float-operation-names)
 167
 168
 169 \f
 170 ;;;; Constants used by instruction emitters.
 171
 172 (defconstant special-op #b000000)
 173 (defconstant bcond-op #b000001)
 174 (defconstant cop0-op #b010000)
 175 (defconstant cop1-op #b010001)
 176 (defconstant cop2-op #b010010)
 177 (defconstant cop3-op #b010011)
 178
 179
 180 \f
 181 ;;;; dissassem:define-instruction-formats
 182
 183 (defconstant-eqx immed-printer
 184   '(:name :tab rt (:unless (:same-as rt) ", " rs) ", " immediate)
 185   #'equalp)
 186
 187 ;;; for things that use rt=0 as a nop
 188 (defconstant-eqx immed-zero-printer
 189   '(:name :tab rt (:unless (:constant 0) ", " rs) ", " immediate)
 190   #'equalp)
 191
 192 (sb!disassem:define-instruction-format
 193     (immediate 32 :default-printer immed-printer)
 194   (op :field (byte 6 26))
 195   (rs :field (byte 5 21) :type 'reg)
 196   (rt :field (byte 5 16) :type 'reg)
 197   (immediate :field (byte 16 0) :sign-extend t))
 198
 199 (eval-when (:compile-toplevel :load-toplevel :execute)
 200   (defparameter jump-printer
 201     #'(lambda (value stream dstate)
 202         (let ((addr (ash value 2)))
 203           (sb!disassem:maybe-note-assembler-routine addr t dstate)
 204           (write addr :base 16 :radix t :stream stream)))))
 205
 206 (sb!disassem:define-instruction-format
 207     (jump 32 :default-printer '(:name :tab target))
 208   (op :field (byte 6 26))
 209   (target :field (byte 26 0) :printer jump-printer))
 210
 211 (defconstant-eqx reg-printer
 212   '(:name :tab rd (:unless (:same-as rd) ", " rs) ", " rt)
 213   #'equalp)
 214
 215 (sb!disassem:define-instruction-format
 216     (register 32 :default-printer reg-printer)
 217   (op :field (byte 6 26))
 218   (rs :field (byte 5 21) :type 'reg)
 219   (rt :field (byte 5 16) :type 'reg)
 220   (rd :field (byte 5 11) :type 'reg)
 221   (shamt :field (byte 5 6) :value 0)
 222   (funct :field (byte 6 0)))
 223
 224 (sb!disassem:define-instruction-format
 225     (break 32 :default-printer
 226            '(:name :tab code (:unless (:constant 0) subcode)))
 227   (op :field (byte 6 26) :value special-op)
 228   (code :field (byte 10 16))
 229   (subcode :field (byte 10 6) :value 0)
 230   (funct :field (byte 6 0) :value #b001101))
 231
 232 (sb!disassem:define-instruction-format
 233     (coproc-branch 32 :default-printer '(:name :tab offset))
 234   (op :field (byte 6 26))
 235   (funct :field (byte 10 16))
 236   (offset :field (byte 16 0)))
 237
 238 (defconstant-eqx float-fmt-printer
 239   '((:unless :constant funct)
 240     (:choose (:unless :constant sub-funct) nil)
 241     "." format)
 242   #'equalp)
 243
 244 (defconstant-eqx float-printer
 245   `(:name ,@float-fmt-printer
 246           :tab
 247           fd
 248           (:unless (:same-as fd) ", " fs)
 249           ", " ft)
 250   #'equalp)
 251
 252 (sb!disassem:define-instruction-format
 253     (float 32 :default-printer float-printer)
 254   (op :field (byte 6 26) :value cop1-op)
 255   (filler :field (byte 1 25) :value 1)
 256   (format :field (byte 4 21) :type 'float-format)
 257   (ft :field (byte 5 16) :value 0)
 258   (fs :field (byte 5 11) :type 'fp-reg)
 259   (fd :field (byte 5 6) :type 'fp-reg)
 260   (funct :field (byte 6 0)))
 261
 262 (sb!disassem:define-instruction-format
 263     (float-aux 32 :default-printer float-printer)
 264   (op :field (byte 6 26) :value cop1-op)
 265   (filler-1 :field (byte 1 25) :value 1)
 266   (format :field (byte 4 21) :type 'float-format)
 267   (ft :field (byte 5 16) :type 'fp-reg)
 268   (fs :field (byte 5 11) :type 'fp-reg)
 269   (fd :field (byte 5 6) :type 'fp-reg)
 270   (funct :field (byte 2 4))
 271   (sub-funct :field (byte 4 0)))
 272
 273 (sb!disassem:define-instruction-format
 274     (float-op 32
 275               :include 'float
 276               :default-printer
 277                 '('f funct "." format
 278                   :tab
 279                   fd
 280                   (:unless (:same-as fd) ", " fs)
 281                   ", " ft))
 282   (funct        :field (byte 2 0) :type 'float-operation)
 283   (funct-filler :field (byte 4 2) :value 0)
 284   (ft           :value nil :type 'fp-reg))
 285
 286 \f
 287 ;;;; Primitive emitters.
 288
 289 (define-bitfield-emitter emit-word 32
 290   (byte 32 0))
 291
 292 (define-bitfield-emitter emit-short 16
 293   (byte 16 0))
 294
 295 (define-bitfield-emitter emit-immediate-inst 32
 296   (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
 297
 298 (define-bitfield-emitter emit-jump-inst 32
 299   (byte 6 26) (byte 26 0))
 300
 301 (define-bitfield-emitter emit-register-inst 32
 302   (byte 6 26) (byte 5 21) (byte 5 16) (byte 5 11) (byte 5 6) (byte 6 0))
 303
 304 (define-bitfield-emitter emit-break-inst 32
 305   (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
 306
 307 (define-bitfield-emitter emit-float-inst 32
 308   (byte 6 26) (byte 1 25) (byte 4 21) (byte 5 16)
 309   (byte 5 11) (byte 5 6) (byte 6 0))
 310
 311
 312 \f
 313 ;;;; Math instructions.
 314
 315 (defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode
 316                                &optional allow-fixups)
 317   (unless src2
 318     (setf src2 src1)
 319     (setf src1 dst))
 320   (etypecase src2
 321     (tn
 322      (emit-register-inst segment special-op (reg-tn-encoding src1)
 323                          (reg-tn-encoding src2) (reg-tn-encoding dst)
 324                          0 reg-opcode))
 325     (integer
 326      (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
 327                           (reg-tn-encoding dst) src2))
 328     (fixup
 329      (unless allow-fixups
 330        (error "Fixups aren't allowed."))
 331      (note-fixup segment :addi src2)
 332      (emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
 333                           (reg-tn-encoding dst) 0))))
 334
 335 (define-instruction add (segment dst src1 &optional src2)
 336   (:declare (type tn dst)
 337             (type (or tn (signed-byte 16) null) src1 src2))
 338   (:printer register ((op special-op) (funct #b100000)))
 339   (:printer immediate ((op #b001000)))
 340   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 341   (:delay 0)
 342   (:emitter
 343    (emit-math-inst segment dst src1 src2 #b100000 #b001000)))
 344
 345 (define-instruction addu (segment dst src1 &optional src2)
 346   (:declare (type tn dst)
 347             (type (or tn (signed-byte 16) fixup null) src1 src2))
 348   (:printer register ((op special-op) (funct #b100001)))
 349   (:printer immediate ((op #b001001)))
 350   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 351   (:delay 0)
 352   (:emitter
 353    (emit-math-inst segment dst src1 src2 #b100001 #b001001 t)))
 354
 355 (define-instruction sub (segment dst src1 &optional src2)
 356   (:declare
 357    (type tn dst)
 358    (type (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) null) src1 src2))
 359   (:printer register ((op special-op) (funct #b100010)))
 360   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 361   (:delay 0)
 362   (:emitter
 363    (unless src2
 364      (setf src2 src1)
 365      (setf src1 dst))
 366    (emit-math-inst segment dst src1
 367                    (if (integerp src2) (- src2) src2)
 368                    #b100010 #b001000)))
 369
 370 (define-instruction subu (segment dst src1 &optional src2)
 371   (:declare
 372    (type tn dst)
 373    (type
 374     (or tn (integer #.(- 1 (ash 1 15)) #.(ash 1 15)) fixup null) src1 src2))
 375   (:printer register ((op special-op) (funct #b100011)))
 376   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 377   (:delay 0)
 378   (:emitter
 379    (unless src2
 380      (setf src2 src1)
 381      (setf src1 dst))
 382    (emit-math-inst segment dst src1
 383                    (if (integerp src2) (- src2) src2)
 384                    #b100011 #b001001 t)))
 385
 386 (define-instruction and (segment dst src1 &optional src2)
 387   (:declare (type tn dst)
 388             (type (or tn (unsigned-byte 16) null) src1 src2))
 389   (:printer register ((op special-op) (funct #b100100)))
 390   (:printer immediate ((op #b001100) (immediate nil :sign-extend nil)))
 391   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 392   (:delay 0)
 393   (:emitter
 394    (emit-math-inst segment dst src1 src2 #b100100 #b001100)))
 395
 396 (define-instruction or (segment dst src1 &optional src2)
 397   (:declare (type tn dst)
 398             (type (or tn (unsigned-byte 16) null) src1 src2))
 399   (:printer register ((op special-op) (funct #b100101)))
 400   (:printer immediate ((op #b001101)))
 401   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 402   (:delay 0)
 403   (:emitter
 404    (emit-math-inst segment dst src1 src2 #b100101 #b001101)))
 405
 406 (define-instruction xor (segment dst src1 &optional src2)
 407   (:declare (type tn dst)
 408             (type (or tn (unsigned-byte 16) null) src1 src2))
 409   (:printer register ((op special-op) (funct #b100110)))
 410   (:printer immediate ((op #b001110)))
 411   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 412   (:delay 0)
 413   (:emitter
 414    (emit-math-inst segment dst src1 src2 #b100110 #b001110)))
 415
 416 (define-instruction nor (segment dst src1 &optional src2)
 417   (:declare (type tn dst src1) (type (or tn null) src2))
 418   (:printer register ((op special-op) (funct #b100111)))
 419   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 420   (:delay 0)
 421   (:emitter
 422    (emit-math-inst segment dst src1 src2 #b100111 #b000000)))
 423
 424 (define-instruction slt (segment dst src1 &optional src2)
 425   (:declare (type tn dst)
 426             (type (or tn (signed-byte 16) null) src1 src2))
 427   (:printer register ((op special-op) (funct #b101010)))
 428   (:printer immediate ((op #b001010)))
 429   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 430   (:delay 0)
 431   (:emitter
 432    (emit-math-inst segment dst src1 src2 #b101010 #b001010)))
 433
 434 (define-instruction sltu (segment dst src1 &optional src2)
 435   (:declare (type tn dst)
 436             (type (or tn (signed-byte 16) null) src1 src2))
 437   (:printer register ((op special-op) (funct #b101011)))
 438   (:printer immediate ((op #b001011)))
 439   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 440   (:delay 0)
 441   (:emitter
 442    (emit-math-inst segment dst src1 src2 #b101011 #b001011)))
 443
 444 (defconstant-eqx divmul-printer '(:name :tab rs ", " rt) #'equalp)
 445
 446 (define-instruction div (segment src1 src2)
 447   (:declare (type tn src1 src2))
 448   (:printer register ((op special-op) (rd 0) (funct #b011010)) divmul-printer)
 449   (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
 450   (:delay 1)
 451   (:emitter
 452    (emit-register-inst segment special-op (reg-tn-encoding src1)
 453                        (reg-tn-encoding src2) 0 0 #b011010)))
 454
 455 (define-instruction divu (segment src1 src2)
 456   (:declare (type tn src1 src2))
 457   (:printer register ((op special-op) (rd 0) (funct #b011011))
 458             divmul-printer)
 459   (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
 460   (:delay 1)
 461   (:emitter
 462    (emit-register-inst segment special-op (reg-tn-encoding src1)
 463                        (reg-tn-encoding src2) 0 0 #b011011)))
 464
 465 (define-instruction mult (segment src1 src2)
 466   (:declare (type tn src1 src2))
 467   (:printer register ((op special-op) (rd 0) (funct #b011000)) divmul-printer)
 468   (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
 469   (:delay 1)
 470   (:emitter
 471    (emit-register-inst segment special-op (reg-tn-encoding src1)
 472                        (reg-tn-encoding src2) 0 0 #b011000)))
 473
 474 (define-instruction multu (segment src1 src2)
 475   (:declare (type tn src1 src2))
 476   (:printer register ((op special-op) (rd 0) (funct #b011001)))
 477   (:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
 478   (:delay 1)
 479   (:emitter
 480    (emit-register-inst segment special-op (reg-tn-encoding src1)
 481                        (reg-tn-encoding src2) 0 0 #b011001)))
 482
 483 (defun emit-shift-inst (segment opcode dst src1 src2)
 484   (unless src2
 485     (setf src2 src1)
 486     (setf src1 dst))
 487   (etypecase src2
 488     (tn
 489      (emit-register-inst segment special-op (reg-tn-encoding src2)
 490                          (reg-tn-encoding src1) (reg-tn-encoding dst)
 491                          0 (logior #b000100 opcode)))
 492     ((unsigned-byte 5)
 493      (emit-register-inst segment special-op 0 (reg-tn-encoding src1)
 494                          (reg-tn-encoding dst) src2 opcode))))
 495
 496 (defconstant-eqx shift-printer
 497   '(:name :tab
 498           rd
 499           (:unless (:same-as rd) ", " rt)
 500           ", " (:cond ((rs :constant 0) shamt)
 501                       (t rs)))
 502   #'equalp)
 503
 504 (define-instruction sll (segment dst src1 &optional src2)
 505   (:declare (type tn dst)
 506             (type (or tn (unsigned-byte 5) null) src1 src2))
 507   (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000))
 508             shift-printer)
 509   (:printer register ((op special-op) (funct #b000100)) shift-printer)
 510   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 511   (:delay 0)
 512   (:emitter
 513    (emit-shift-inst segment #b00 dst src1 src2)))
 514
 515 (define-instruction sra (segment dst src1 &optional src2)
 516   (:declare (type tn dst)
 517             (type (or tn (unsigned-byte 5) null) src1 src2))
 518   (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011))
 519             shift-printer)
 520   (:printer register ((op special-op) (funct #b000111)) shift-printer)
 521   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 522   (:delay 0)
 523   (:emitter
 524    (emit-shift-inst segment #b11 dst src1 src2)))
 525
 526 (define-instruction srl (segment dst src1 &optional src2)
 527   (:declare (type tn dst)
 528             (type (or tn (unsigned-byte 5) null) src1 src2))
 529   (:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010))
 530             shift-printer)
 531   (:printer register ((op special-op) (funct #b000110)) shift-printer)
 532   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
 533   (:delay 0)
 534   (:emitter
 535    (emit-shift-inst segment #b10 dst src1 src2)))
 536
 537 \f
 538 ;;;; Floating point math.
 539
 540 (define-instruction float-op (segment operation format dst src1 src2)
 541   (:declare (type float-operation operation)
 542             (type float-format format)
 543             (type tn dst src1 src2))
 544   (:printer float-op ())
 545   (:dependencies (reads src1) (reads src2) (writes dst))
 546   (:delay 0)
 547   (:emitter
 548    (emit-float-inst segment cop1-op 1 (float-format-value format)
 549                     (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
 550                     (fp-reg-tn-encoding dst) (float-operation operation))))
 551
 552 (defconstant-eqx float-unop-printer
 553   `(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs))
 554   #'equalp)
 555
 556 (define-instruction fabs (segment format dst &optional (src dst))
 557   (:declare (type float-format format) (type tn dst src))
 558   (:printer float ((funct #b000101)) float-unop-printer)
 559   (:dependencies (reads src) (writes dst))
 560   (:delay 0)
 561   (:emitter
 562    (emit-float-inst segment cop1-op 1 (float-format-value format)
 563                     0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
 564                     #b000101)))
 565
 566 (define-instruction fneg (segment format dst &optional (src dst))
 567   (:declare (type float-format format) (type tn dst src))
 568   (:printer float ((funct #b000111)) float-unop-printer)
 569   (:dependencies (reads src) (writes dst))
 570   (:delay 0)
 571   (:emitter
 572    (emit-float-inst segment cop1-op 1 (float-format-value format)
 573                     0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
 574                     #b000111)))
 575
 576 (define-instruction fcvt (segment format1 format2 dst src)
 577   (:declare (type float-format format1 format2) (type tn dst src))
 578   (:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format))
 579            `(:name "." sub-funct "." format :tab fd ", " fs))
 580   (:dependencies (reads src) (writes dst))
 581   (:delay 0)
 582   (:emitter
 583    (emit-float-inst segment cop1-op 1 (float-format-value format2) 0
 584                     (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
 585                     (logior #b100000 (float-format-value format1)))))
 586
 587 (define-instruction fcmp (segment operation format fs ft)
 588   (:declare (type compare-kind operation)
 589             (type float-format format)
 590             (type tn fs ft))
 591   (:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind))
 592             `(:name "-" sub-funct "." format :tab fs ", " ft))
 593   (:dependencies (reads fs) (reads ft) (writes :float-status))
 594   (:delay 1)
 595   (:emitter
 596    (emit-float-inst segment cop1-op 1 (float-format-value format)
 597                     (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
 598                     (logior #b110000 (compare-kind operation)))))
 599
 600 \f
 601 ;;;; Branch/Jump instructions.
 602
 603 (defun emit-relative-branch (segment opcode r1 r2 target)
 604   (emit-chooser
 605    segment 20 2
 606       #'(lambda (segment posn magic-value)
 607           (declare (ignore magic-value))
 608           (let ((delta (ash (- (label-position target) (+ posn 4)) -2)))
 609             (when (typep delta '(signed-byte 16))
 610               (emit-back-patch segment 4
 611                 #'(lambda (segment posn)
 612                     (emit-immediate-inst segment
 613                                          opcode
 614                                          (if (fixnump r1)
 615                                              r1
 616                                              (reg-tn-encoding r1))
 617                                          (if (fixnump r2)
 618                                              r2
 619                                              (reg-tn-encoding r2))
 620                                          (ash (- (label-position target)
 621                                                  (+ posn 4))
 622                                               -2))))
 623               t)))
 624       #'(lambda (segment posn)
 625           (declare (ignore posn))
 626           (let ((linked))
 627             ;; invert branch condition
 628             (if (or (= opcode bcond-op) (= opcode cop1-op))
 629                 (setf r2 (logxor r2 #b00001))
 630                 (setf opcode (logxor opcode #b00001)))
 631             ;; check link flag
 632             (if (= opcode bcond-op)
 633                 (if (logand r2 #b10000)
 634                     (progn (setf r2 (logand r2 #b01111))
 635                            (setf linked t))))
 636             (emit-immediate-inst segment
 637                                  opcode
 638                                  (if (fixnump r1) r1 (reg-tn-encoding r1))
 639                                  (if (fixnump r2) r2 (reg-tn-encoding r2))
 640                                  4)
 641             (emit-nop segment)
 642             (emit-back-patch segment 8
 643               #'(lambda (segment posn)
 644                   (declare (ignore posn))
 645                   (emit-immediate-inst segment #b001111 0
 646                                        (reg-tn-encoding lip-tn)
 647                                        (ldb (byte 16 16)
 648                                             (label-position target)))
 649                   (emit-immediate-inst segment #b001101 0
 650                                        (reg-tn-encoding lip-tn)
 651                                        (ldb (byte 16 0)
 652                                             (label-position target)))))
 653             (emit-register-inst segment special-op (reg-tn-encoding lip-tn)
 654                                 0 (if linked 31 0) 0
 655                                 (if linked #b001001 #b001000))))))
 656
 657 (define-instruction b (segment target)
 658   (:declare (type label target))
 659   (:printer immediate ((op #b000100) (rs 0) (rt 0)
 660                        (immediate nil :type 'relative-label))
 661             '(:name :tab immediate))
 662   (:attributes branch)
 663   (:delay 1)
 664   (:emitter
 665    (emit-relative-branch segment #b000100 0 0 target)))
 666
 667 (define-instruction bal (segment target)
 668   (:declare (type label target))
 669   (:printer immediate ((op bcond-op) (rs 0) (rt #b01001)
 670                        (immediate nil :type 'relative-label))
 671             '(:name :tab immediate))
 672   (:attributes branch)
 673   (:dependencies (writes :r31))
 674   (:delay 1)
 675   (:emitter
 676    (emit-relative-branch segment bcond-op 0 #b10001 target)))
 677
 678 (define-instruction beq (segment r1 r2-or-target &optional target)
 679   (:declare (type tn r1)
 680             (type (or tn fixnum label) r2-or-target)
 681             (type (or label null) target))
 682   (:printer immediate ((op #b000100) (immediate nil :type 'relative-label)))
 683   (:attributes branch)
 684   (:dependencies (reads r1) (if target (reads r2-or-target)))
 685   (:delay 1)
 686   (:emitter
 687    (unless target
 688      (setf target r2-or-target)
 689      (setf r2-or-target 0))
 690    (emit-relative-branch segment #b000100 r1 r2-or-target target)))
 691
 692 (define-instruction bne (segment r1 r2-or-target &optional target)
 693   (:declare (type tn r1)
 694             (type (or tn fixnum label) r2-or-target)
 695             (type (or label null) target))
 696   (:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
 697   (:attributes branch)
 698   (:dependencies (reads r1) (if target (reads r2-or-target)))
 699   (:delay 1)
 700   (:emitter
 701    (unless target
 702      (setf target r2-or-target)
 703      (setf r2-or-target 0))
 704    (emit-relative-branch segment #b000101 r1 r2-or-target target)))
 705
 706 (defconstant-eqx cond-branch-printer
 707   '(:name :tab rs ", " immediate)
 708   #'equalp)
 709
 710 (define-instruction blez (segment reg target)
 711   (:declare (type label target) (type tn reg))
 712   (:printer
 713    immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label))
 714             cond-branch-printer)
 715   (:attributes branch)
 716   (:dependencies (reads reg))
 717   (:delay 1)
 718   (:emitter
 719    (emit-relative-branch segment #b000110 reg 0 target)))
 720
 721 (define-instruction bgtz (segment reg target)
 722   (:declare (type label target) (type tn reg))
 723   (:printer
 724    immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label))
 725             cond-branch-printer)
 726   (:attributes branch)
 727   (:dependencies (reads reg))
 728   (:delay 1)
 729   (:emitter
 730    (emit-relative-branch segment #b000111 reg 0 target)))
 731
 732 (define-instruction bltz (segment reg target)
 733   (:declare (type label target) (type tn reg))
 734   (:printer
 735    immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label))
 736             cond-branch-printer)
 737   (:attributes branch)
 738   (:dependencies (reads reg))
 739   (:delay 1)
 740   (:emitter
 741    (emit-relative-branch segment bcond-op reg #b00000 target)))
 742
 743 (define-instruction bgez (segment reg target)
 744   (:declare (type label target) (type tn reg))
 745   (:printer
 746    immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label))
 747             cond-branch-printer)
 748   (:attributes branch)
 749   (:dependencies (reads reg))
 750   (:delay 1)
 751   (:emitter
 752    (emit-relative-branch segment bcond-op reg #b00001 target)))
 753
 754 (define-instruction bltzal (segment reg target)
 755   (:declare (type label target) (type tn reg))
 756   (:printer
 757    immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label))
 758             cond-branch-printer)
 759   (:attributes branch)
 760   (:dependencies (reads reg) (writes :r31))
 761   (:delay 1)
 762   (:emitter
 763    (emit-relative-branch segment bcond-op reg #b10000 target)))
 764
 765 (define-instruction bgezal (segment reg target)
 766   (:declare (type label target) (type tn reg))
 767   (:printer
 768    immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label))
 769             cond-branch-printer)
 770   (:attributes branch)
 771   (:delay 1)
 772   (:dependencies (reads reg) (writes :r31))
 773   (:emitter
 774    (emit-relative-branch segment bcond-op reg #b10001 target)))
 775
 776 (defconstant-eqx j-printer
 777   '(:name :tab (:choose rs target))
 778   #'equalp)
 779
 780 (define-instruction j (segment target)
 781   (:declare (type (or tn fixup) target))
 782   (:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000))
 783             j-printer)
 784   (:printer jump ((op #b000010)) j-printer)
 785   (:attributes branch)
 786   (:dependencies (reads target))
 787   (:delay 1)
 788   (:emitter
 789    (etypecase target
 790      (tn
 791       (emit-register-inst segment special-op (reg-tn-encoding target)
 792                           0 0 0 #b001000))
 793      (fixup
 794       (note-fixup segment :jump target)
 795       (emit-jump-inst segment #b000010 0)))))
 796
 797 (define-instruction jal (segment reg-or-target &optional target)
 798   (:declare (type (or null tn fixup) target)
 799             (type (or tn fixup (integer -16 31)) reg-or-target))
 800   (:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer)
 801   (:printer jump ((op #b000011)) j-printer)
 802   (:attributes branch)
 803   (:dependencies (if target (writes reg-or-target) (writes :r31)))
 804   (:delay 1)
 805   (:emitter
 806    (unless target
 807      (setf target reg-or-target)
 808      (setf reg-or-target 31))
 809    (etypecase target
 810      (tn
 811       (emit-register-inst segment special-op (reg-tn-encoding target) 0
 812                           reg-or-target 0 #b001001))
 813      (fixup
 814       (note-fixup segment :jump target)
 815       (emit-jump-inst segment #b000011 0)))))
 816
 817 (define-instruction bc1f (segment target)
 818   (:declare (type label target))
 819   (:printer coproc-branch ((op cop1-op) (funct #x100)
 820                            (offset nil :type 'relative-label)))
 821   (:attributes branch)
 822   (:dependencies (reads :float-status))
 823   (:delay 1)
 824   (:emitter
 825    (emit-relative-branch segment cop1-op #b01000 #b00000 target)))
 826
 827 (define-instruction bc1t (segment target)
 828   (:declare (type label target))
 829   (:printer coproc-branch ((op cop1-op) (funct #x101)
 830                            (offset nil :type 'relative-label)))
 831   (:attributes branch)
 832   (:dependencies (reads :float-status))
 833   (:delay 1)
 834   (:emitter
 835    (emit-relative-branch segment cop1-op #b01000 #b00001 target)))
 836
 837
 838 \f
 839 ;;;; Random movement instructions.
 840
 841 (define-instruction lui (segment reg value)
 842   (:declare (type tn reg)
 843             (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
 844   (:printer immediate ((op #b001111)
 845                        (immediate nil :sign-extend nil :printer "#x~4,'0X")))
 846   (:dependencies (writes reg))
 847   (:delay 0)
 848   (:emitter
 849    (when (fixup-p value)
 850      (note-fixup segment :lui value)
 851      (setf value 0))
 852    (emit-immediate-inst segment #b001111 0 (reg-tn-encoding reg) value)))
 853
 854 (defconstant-eqx mvsreg-printer '(:name :tab rd)
 855   #'equalp)
 856
 857 (define-instruction mfhi (segment reg)
 858   (:declare (type tn reg))
 859   (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000))
 860             mvsreg-printer)
 861   (:dependencies (reads :hi-reg) (writes reg))
 862   (:delay 2)
 863   (:emitter
 864    (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
 865                         #b010000)))
 866
 867 (define-instruction mthi (segment reg)
 868   (:declare (type tn reg))
 869   (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001))
 870             mvsreg-printer)
 871   (:dependencies (reads reg) (writes :hi-reg))
 872   (:delay 0)
 873   (:emitter
 874    (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
 875                         #b010001)))
 876
 877 (define-instruction mflo (segment reg)
 878   (:declare (type tn reg))
 879   (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010))
 880             mvsreg-printer)
 881   (:dependencies (reads :low-reg) (writes reg))
 882   (:delay 2)
 883   (:emitter
 884    (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
 885                         #b010010)))
 886
 887 (define-instruction mtlo (segment reg)
 888   (:declare (type tn reg))
 889   (:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011))
 890             mvsreg-printer)
 891   (:dependencies (reads reg) (writes :low-reg))
 892   (:delay 0)
 893   (:emitter
 894    (emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
 895                         #b010011)))
 896
 897 (define-instruction move (segment dst src)
 898   (:declare (type tn dst src))
 899   (:printer register ((op special-op) (rt 0) (funct #b100001))
 900             '(:name :tab rd ", " rs))
 901   (:attributes flushable)
 902   (:dependencies (reads src) (writes dst))
 903   (:delay 0)
 904   (:emitter
 905    (emit-register-inst segment special-op (reg-tn-encoding src) 0
 906                        (reg-tn-encoding dst) 0 #b100001)))
 907
 908 (define-instruction fmove (segment format dst src)
 909   (:declare (type float-format format) (type tn dst src))
 910   (:printer float ((funct #b000110)) '(:name "." format :tab fd ", " fs))
 911   (:attributes flushable)
 912   (:dependencies (reads src) (writes dst))
 913   (:delay 0)
 914   (:emitter
 915    (emit-float-inst segment cop1-op 1 (float-format-value format) 0
 916                     (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
 917                     #b000110)))
 918
 919 (defun %li (reg value)
 920   (etypecase value
 921     ((unsigned-byte 16)
 922      (inst or reg zero-tn value))
 923     ((signed-byte 16)
 924      (inst addu reg zero-tn value))
 925     ((or (signed-byte 32) (unsigned-byte 32))
 926      (inst lui reg (ldb (byte 16 16) value))
 927      (inst or reg (ldb (byte 16 0) value)))
 928     (fixup
 929      (inst lui reg value)
 930      (inst addu reg value))))
 931
 932 (define-instruction-macro li (reg value)
 933   `(%li ,reg ,value))
 934
 935 (defconstant-eqx sub-op-printer '(:name :tab rd ", " rt) #'equalp)
 936
 937 (define-instruction mtc1 (segment to from)
 938   (:declare (type tn to from))
 939   (:printer register ((op cop1-op) (rs #b00100) (funct 0)) sub-op-printer)
 940   (:dependencies (reads from) (writes to))
 941   (:delay 1)
 942   (:emitter
 943    (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
 944                        (fp-reg-tn-encoding to) 0 0)))
 945
 946 (define-instruction mtc1-odd (segment to from)
 947   (:declare (type tn to from))
 948   (:dependencies (reads from) (writes to))
 949   (:delay 1)
 950   (:emitter
 951    (emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
 952                        (1+ (fp-reg-tn-encoding to)) 0 0)))
 953
 954 (define-instruction mfc1 (segment to from)
 955   (:declare (type tn to from))
 956   (:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0))
 957             sub-op-printer)
 958   (:dependencies (reads from) (writes to))
 959   (:delay 1)
 960   (:emitter
 961    (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
 962                        (fp-reg-tn-encoding from) 0 0)))
 963
 964 (define-instruction mfc1-odd (segment to from)
 965   (:declare (type tn to from))
 966   (:dependencies (reads from) (writes to))
 967   (:delay 1)
 968   (:emitter
 969    (emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
 970                        (1+ (fp-reg-tn-encoding from)) 0 0)))
 971
 972 (define-instruction mfc1-odd2 (segment to from)
 973   (:declare (type tn to from))
 974   (:dependencies (reads from) (writes to))
 975   (:delay 1)
 976   (:emitter
 977    (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
 978                        (fp-reg-tn-encoding from) 0 0)))
 979
 980 (define-instruction mfc1-odd3 (segment to from)
 981   (:declare (type tn to from))
 982   (:dependencies (reads from) (writes to))
 983   (:delay 1)
 984   (:emitter
 985    (emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
 986                        (1+ (fp-reg-tn-encoding from)) 0 0)))
 987
 988 (define-instruction cfc1 (segment reg cr)
 989   (:declare (type tn reg) (type (unsigned-byte 5) cr))
 990   (:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg)
 991                       (funct 0)) sub-op-printer)
 992   (:dependencies (reads :ctrl-stat-reg) (writes reg))
 993   (:delay 1)
 994   (:emitter
 995    (emit-register-inst segment cop1-op #b00010 (reg-tn-encoding reg)
 996                        cr 0 0)))
 997
 998 (define-instruction ctc1 (segment reg cr)
 999   (:declare (type tn reg) (type (unsigned-byte 5) cr))
1000   (:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg)
1001                       (funct 0)) sub-op-printer)
1002   (:dependencies (reads reg) (writes :ctrl-stat-reg))
1003   (:delay 1)
1004   (:emitter
1005    (emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg)
1006                        cr 0 0)))
1007
1008
1009 \f
1010 ;;;; Random system hackery and other noise
1011
1012 (define-instruction-macro entry-point ()
1013   nil)
1014
1015 #+nil
1016 (define-bitfield-emitter emit-break-inst 32
1017   (byte 6 26) (byte 10 16) (byte 10 6) (byte 6 0))
1018
1019 (defun snarf-error-junk (sap offset &optional length-only)
1020   (let* ((length (sb!sys:sap-ref-8 sap offset))
1021          (vector (make-array length :element-type '(unsigned-byte 8))))
1022     (declare (type sb!sys:system-area-pointer sap)
1023              (type (unsigned-byte 8) length)
1024              (type (simple-array (unsigned-byte 8) (*)) vector))
1025     (cond (length-only
1026            (values 0 (1+ length) nil nil))
1027           (t
1028            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
1029                                                 vector 0 length)
1030            (collect ((sc-offsets)
1031                      (lengths))
1032              (lengths 1)                ; the length byte
1033              (let* ((index 0)
1034                     (error-number (sb!c:read-var-integer vector index)))
1035                (lengths index)
1036                (loop
1037                  (when (>= index length)
1038                    (return))
1039                  (let ((old-index index))
1040                    (sc-offsets (sb!c:read-var-integer vector index))
1041                    (lengths (- index old-index))))
1042                (values error-number
1043                        (1+ length)
1044                        (sc-offsets)
1045                        (lengths))))))))
1046
1047 (defmacro break-cases (breaknum &body cases)
1048   (let ((bn-temp (gensym)))
1049     (collect ((clauses))
1050       (dolist (case cases)
1051         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
1052       `(let ((,bn-temp ,breaknum))
1053          (cond ,@(clauses))))))
1054
1055 (defun break-control (chunk inst stream dstate)
1056   (declare (ignore inst))
1057   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1058     (case (break-code chunk dstate)
1059       (#.error-trap
1060        (nt "Error trap")
1061        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1062       (#.cerror-trap
1063        (nt "Cerror trap")
1064        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1065       (#.breakpoint-trap
1066        (nt "Breakpoint trap"))
1067       (#.pending-interrupt-trap
1068        (nt "Pending interrupt trap"))
1069       (#.halt-trap
1070        (nt "Halt trap"))
1071       (#.fun-end-breakpoint-trap
1072        (nt "Function end breakpoint trap"))
1073     )))
1074
1075 (define-instruction break (segment code &optional (subcode 0))
1076   (:declare (type (unsigned-byte 10) code subcode))
1077   (:printer break ((op special-op) (funct #b001101))
1078             '(:name :tab code (:unless (:constant 0) subcode))
1079             :control #'break-control )
1080   :pinned
1081   (:cost 0)
1082   (:delay 0)
1083   (:emitter
1084    (emit-break-inst segment special-op code subcode #b001101)))
1085
1086 (define-instruction syscall (segment)
1087   (:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100))
1088             '(:name))
1089   :pinned
1090   (:delay 0)
1091   (:emitter
1092    (emit-register-inst segment special-op 0 0 0 0 #b001100)))
1093
1094 (define-instruction nop (segment)
1095   (:printer register ((op 0) (rd 0) (rd 0) (rs 0) (funct 0)) '(:name))
1096   (:attributes flushable)
1097   (:delay 0)
1098   (:emitter
1099    (emit-word segment 0)))
1100
1101 (!def-vm-support-routine emit-nop (segment)
1102   (emit-word segment 0))
1103
1104 (define-instruction word (segment word)
1105   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
1106   :pinned
1107   (:cost 0)
1108   (:delay 0)
1109   (:emitter
1110    (emit-word segment word)))
1111
1112 (define-instruction short (segment short)
1113   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
1114   :pinned
1115   (:cost 0)
1116   (:delay 0)
1117   (:emitter
1118    (emit-short segment short)))
1119
1120 (define-instruction byte (segment byte)
1121   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
1122   :pinned
1123   (:cost 0)
1124   (:delay 0)
1125   (:emitter
1126    (emit-byte segment byte)))
1127
1128
1129 (defun emit-header-data (segment type)
1130   (emit-back-patch
1131    segment 4
1132    #'(lambda (segment posn)
1133        (emit-word segment
1134                   (logior type
1135                           (ash (+ posn (component-header-length))
1136                                (- n-widetag-bits word-shift)))))))
1137
1138 (define-instruction fun-header-word (segment)
1139   :pinned
1140   (:cost 0)
1141   (:delay 0)
1142   (:emitter
1143    (emit-header-data segment simple-fun-header-widetag)))
1144
1145 (define-instruction lra-header-word (segment)
1146   :pinned
1147   (:cost 0)
1148   (:delay 0)
1149   (:emitter
1150    (emit-header-data segment return-pc-header-widetag)))
1151
1152
1153 (defun emit-compute-inst (segment vop dst src label temp calc)
1154   (emit-chooser
1155    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
1156    segment 12 3
1157    #'(lambda (segment posn delta-if-after)
1158        (let ((delta (funcall calc label posn delta-if-after)))
1159           (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
1160             (emit-back-patch segment 4
1161                              #'(lambda (segment posn)
1162                                  (assemble (segment vop)
1163                                            (inst addu dst src
1164                                                  (funcall calc label posn 0)))))
1165             t)))
1166    #'(lambda (segment posn)
1167        (let ((delta (funcall calc label posn 0)))
1168          (assemble (segment vop)
1169                    (inst lui temp (ldb (byte 16 16) delta))
1170                    (inst or temp (ldb (byte 16 0) delta))
1171                    (inst addu dst src temp))))))
1172
1173 ;; code = fn - header - label-offset + other-pointer-tag
1174 (define-instruction compute-code-from-fn (segment dst src label temp)
1175   (:declare (type tn dst src temp) (type label label))
1176   (:attributes variable-length)
1177   (:dependencies (reads src) (writes dst) (writes temp))
1178   (:delay 0)
1179   (:vop-var vop)
1180   (:emitter
1181    (emit-compute-inst segment vop dst src label temp
1182                       #'(lambda (label posn delta-if-after)
1183                           (- other-pointer-lowtag
1184                              (label-position label posn delta-if-after)
1185                              (component-header-length))))))
1186
1187 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1188 ;;      = lra - (header + label-offset)
1189 (define-instruction compute-code-from-lra (segment dst src label temp)
1190   (:declare (type tn dst src temp) (type label label))
1191   (:attributes variable-length)
1192   (:dependencies (reads src) (writes dst) (writes temp))
1193   (:delay 0)
1194   (:vop-var vop)
1195   (:emitter
1196    (emit-compute-inst segment vop dst src label temp
1197                       #'(lambda (label posn delta-if-after)
1198                           (- (+ (label-position label posn delta-if-after)
1199                                 (component-header-length)))))))
1200
1201 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1202 (define-instruction compute-lra-from-code (segment dst src label temp)
1203   (:declare (type tn dst src temp) (type label label))
1204   (:attributes variable-length)
1205   (:dependencies (reads src) (writes dst) (writes temp))
1206   (:delay 0)
1207   (:vop-var vop)
1208   (:emitter
1209    (emit-compute-inst segment vop dst src label temp
1210                       #'(lambda (label posn delta-if-after)
1211                           (+ (label-position label posn delta-if-after)
1212                              (component-header-length))))))
1213
1214 \f
1215 ;;;; Loads and Stores
1216
1217 (defun emit-load/store-inst (segment opcode reg base index
1218                                      &optional (oddhack 0))
1219   (when (fixup-p index)
1220     (note-fixup segment :addi index)
1221     (setf index 0))
1222   (emit-immediate-inst segment opcode (reg-tn-encoding reg)
1223                        (+ (reg-tn-encoding base) oddhack) index))
1224
1225 (defconstant-eqx load-store-printer
1226   '(:name :tab
1227           rt ", "
1228           rs
1229           (:unless (:constant 0) "[" immediate "]"))
1230   #'equalp)
1231
1232 (define-instruction lb (segment reg base &optional (index 0))
1233   (:declare (type tn reg base)
1234             (type (or (signed-byte 16) fixup) index))
1235   (:printer immediate ((op #b100000)) load-store-printer)
1236   (:dependencies (reads base) (reads :memory) (writes reg))
1237   (:delay 1)
1238   (:emitter
1239    (emit-load/store-inst segment #b100000 base reg index)))
1240
1241 (define-instruction lh (segment reg base &optional (index 0))
1242   (:declare (type tn reg base)
1243             (type (or (signed-byte 16) fixup) index))
1244   (:printer immediate ((op #b100001)) load-store-printer)
1245   (:dependencies (reads base) (reads :memory) (writes reg))
1246   (:delay 1)
1247   (:emitter
1248    (emit-load/store-inst segment #b100001 base reg index)))
1249
1250 (define-instruction lwl (segment reg base &optional (index 0))
1251   (:declare (type tn reg base)
1252             (type (or (signed-byte 16) fixup) index))
1253   (:printer immediate ((op #b100010)) load-store-printer)
1254   (:dependencies (reads base) (reads :memory) (writes reg))
1255   (:delay 1)
1256   (:emitter
1257    (emit-load/store-inst segment #b100010 base reg index)))
1258
1259 (define-instruction lw (segment reg base &optional (index 0))
1260   (:declare (type tn reg base)
1261             (type (or (signed-byte 16) fixup) index))
1262   (:printer immediate ((op #b100011)) load-store-printer)
1263   (:dependencies (reads base) (reads :memory) (writes reg))
1264   (:delay 1)
1265   (:emitter
1266    (emit-load/store-inst segment #b100011 base reg index)))
1267
1268 ;; next is just for ease of coding double-in-int c-call convention
1269 (define-instruction lw-odd (segment reg base &optional (index 0))
1270   (:declare (type tn reg base)
1271             (type (or (signed-byte 16) fixup) index))
1272   (:dependencies (reads base) (reads :memory) (writes reg))
1273   (:delay 1)
1274   (:emitter
1275    (emit-load/store-inst segment #b100011 base reg index 1)))
1276
1277 (define-instruction lbu (segment reg base &optional (index 0))
1278   (:declare (type tn reg base)
1279             (type (or (signed-byte 16) fixup) index))
1280   (:printer immediate ((op #b100100)) load-store-printer)
1281   (:dependencies (reads base) (reads :memory) (writes reg))
1282   (:delay 1)
1283   (:emitter
1284    (emit-load/store-inst segment #b100100 base reg index)))
1285
1286 (define-instruction lhu (segment reg base &optional (index 0))
1287   (:declare (type tn reg base)
1288             (type (or (signed-byte 16) fixup) index))
1289   (:printer immediate ((op #b100101)) load-store-printer)
1290   (:dependencies (reads base) (reads :memory) (writes reg))
1291   (:delay 1)
1292   (:emitter
1293    (emit-load/store-inst segment #b100101 base reg index)))
1294
1295 (define-instruction lwr (segment reg base &optional (index 0))
1296   (:declare (type tn reg base)
1297             (type (or (signed-byte 16) fixup) index))
1298   (:printer immediate ((op #b100110)) load-store-printer)
1299   (:dependencies (reads base) (reads :memory) (writes reg))
1300   (:delay 1)
1301   (:emitter
1302    (emit-load/store-inst segment #b100110 base reg index)))
1303
1304 (define-instruction sb (segment reg base &optional (index 0))
1305   (:declare (type tn reg base)
1306             (type (or (signed-byte 16) fixup) index))
1307   (:printer immediate ((op #b101000)) load-store-printer)
1308   (:dependencies (reads base) (reads reg) (writes :memory))
1309   (:delay 0)
1310   (:emitter
1311    (emit-load/store-inst segment #b101000 base reg index)))
1312
1313 (define-instruction sh (segment reg base &optional (index 0))
1314   (:declare (type tn reg base)
1315             (type (or (signed-byte 16) fixup) index))
1316   (:printer immediate ((op #b101001)) load-store-printer)
1317   (:dependencies (reads base) (reads reg) (writes :memory))
1318   (:delay 0)
1319   (:emitter
1320    (emit-load/store-inst segment #b101001 base reg index)))
1321
1322 (define-instruction swl (segment reg base &optional (index 0))
1323   (:declare (type tn reg base)
1324             (type (or (signed-byte 16) fixup) index))
1325   (:printer immediate ((op #b101010)) load-store-printer)
1326   (:dependencies (reads base) (reads reg) (writes :memory))
1327   (:delay 0)
1328   (:emitter
1329    (emit-load/store-inst segment #b101010 base reg index)))
1330
1331 (define-instruction sw (segment reg base &optional (index 0))
1332   (:declare (type tn reg base)
1333             (type (or (signed-byte 16) fixup) index))
1334   (:printer immediate ((op #b101011)) load-store-printer)
1335   (:dependencies (reads base) (reads reg) (writes :memory))
1336   (:delay 0)
1337   (:emitter
1338    (emit-load/store-inst segment #b101011 base reg index)))
1339
1340 (define-instruction swr (segment reg base &optional (index 0))
1341   (:declare (type tn reg base)
1342             (type (or (signed-byte 16) fixup) index))
1343   (:printer immediate ((op #b101110)) load-store-printer)
1344   (:dependencies (reads base) (reads reg) (writes :memory))
1345   (:delay 0)
1346   (:emitter
1347    (emit-load/store-inst segment #b101110 base reg index)))
1348
1349
1350 (defun emit-fp-load/store-inst (segment opcode reg odd base index)
1351   (when (fixup-p index)
1352     (note-fixup segment :addi index)
1353     (setf index 0))
1354   (emit-immediate-inst segment opcode (reg-tn-encoding base)
1355                        (+ (fp-reg-tn-encoding reg) odd) index))
1356
1357 (define-instruction lwc1 (segment reg base &optional (index 0))
1358   (:declare (type tn reg base)
1359             (type (or (signed-byte 16) fixup) index))
1360   (:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer)
1361   (:dependencies (reads base) (reads :memory) (writes reg))
1362   (:delay 1)
1363   (:emitter
1364    (emit-fp-load/store-inst segment #b110001 reg 0 base index)))
1365
1366 (define-instruction lwc1-odd (segment reg base &optional (index 0))
1367   (:declare (type tn reg base)
1368             (type (or (signed-byte 16) fixup) index))
1369   (:dependencies (reads base) (reads :memory) (writes reg))
1370   (:delay 1)
1371   (:emitter
1372    (emit-fp-load/store-inst segment #b110001 reg 1 base index)))
1373
1374 (define-instruction swc1 (segment reg base &optional (index 0))
1375   (:declare (type tn reg base)
1376             (type (or (signed-byte 16) fixup) index))
1377   (:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer)
1378   (:dependencies (reads base) (reads reg) (writes :memory))
1379   (:delay 0)
1380   (:emitter
1381    (emit-fp-load/store-inst segment #b111001 reg 0 base index)))
1382
1383 (define-instruction swc1-odd (segment reg base &optional (index 0))
1384   (:declare (type tn reg base)
1385             (type (or (signed-byte 16) fixup) index))
1386   (:dependencies (reads base) (reads reg) (writes :memory))
1387   (:delay 0)
1388   (:emitter
1389    (emit-fp-load/store-inst segment #b111001 reg 1 base index)))
1390