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