src/compiler/sparc/insts.lisp

   1 ;;;; the instruction set definition for the Sparc
   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 (eval-when (:compile-toplevel :load-toplevel :execute)
  15   (setf sb!assem:*assem-scheduler-p* t)
  16   (setf sb!assem:*assem-max-locations* 100))
  17 \f
  18 ;;; Constants, types, conversion functions, some disassembler stuff.
  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   (let ((offset (tn-offset tn)))
  34     (cond ((> offset 31)
  35            (aver (member :sparc-v9 *backend-subfeatures*))
  36            ;; No single register encoding greater than reg 31.
  37            (aver (zerop (mod offset 2)))
  38            ;; Upper bit of the register number is encoded in the low bit.
  39            (1+ (- offset 32)))
  40           (t
  41            (tn-offset tn)))))
  42
  43 ;;;(sb!disassem:set-disassem-params :instruction-alignment 32
  44 ;;;                              :opcode-column-width 11)
  45
  46 (defvar *disassem-use-lisp-reg-names* t
  47   #!+sb-doc
  48   "If non-NIL, print registers using the Lisp register names.
  49 Otherwise, use the Sparc register names")
  50
  51 (defun location-number (loc)
  52   (etypecase loc
  53     (null)
  54     (number)
  55     (fixup)
  56     (tn
  57      (ecase (sb-name (sc-sb (tn-sc loc)))
  58        (registers
  59         (unless (zerop (tn-offset loc))
  60           (tn-offset loc)))
  61        (float-registers
  62         (sc-case loc
  63           (single-reg
  64            (+ (tn-offset loc) 32))
  65           (double-reg
  66            (let ((offset (tn-offset loc)))
  67              (aver (zerop (mod offset 2)))
  68              (values (+ offset 32) 2)))
  69           #!+long-float
  70           (long-reg
  71            (let ((offset (tn-offset loc)))
  72              (aver (zerop (mod offset 4)))
  73              (values (+ offset 32) 4)))))
  74        (control-registers
  75         96)
  76        (immediate-constant
  77         nil)))
  78     (symbol
  79      (ecase loc
  80        (:memory 0)
  81        (:psr 97)
  82        (:fsr 98)
  83        (:y 99)))))
  84
  85 ;;; symbols used for disassembly printing
  86 (defparameter reg-symbols
  87   (map 'vector
  88        (lambda (name)
  89            (cond ((null name) nil)
  90                  (t (make-symbol (concatenate 'string "%" name)))))
  91        *register-names*)
  92   #!+sb-doc "The Lisp names for the Sparc integer registers")
  93
  94 (defparameter sparc-reg-symbols
  95   #("%G0" "%G1" "%G2" "%G3" "%G4" "%G5" NIL NIL
  96     "%O0" "%O1" "%O2" "%O3" "%O4" "%O5" "%O6" "%O7"
  97     "%L0" "%L1" "%L2" "%L3" "%L4" "%L5" "%L6" "%L7"
  98     "%I0" "%I1" "%I2" "%I3" "%I4" "%I5" NIL "%I7")
  99   #!+sb-doc "The standard names for the Sparc integer registers")
 100
 101 (defun get-reg-name (index)
 102   (if *disassem-use-lisp-reg-names*
 103       (aref reg-symbols index)
 104       (aref sparc-reg-symbols index)))
 105
 106 (defvar *note-sethi-inst* nil
 107   "An alist for the disassembler indicating the target register and
 108 value used in a SETHI instruction.  This is used to make annotations
 109 about function addresses and register values.")
 110
 111 (defvar *pseudo-atomic-set* nil)
 112
 113 (defun sign-extend-immed-value (val)
 114   ;; val is a 13-bit signed number.  Extend the sign appropriately.
 115   (if (logbitp 12 val)
 116       (- val (ash 1 13))
 117       val))
 118
 119 ;; Look at the current instruction and see if we can't add some notes
 120 ;; about what's happening.
 121
 122 (defun maybe-add-notes (reg dstate)
 123   (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
 124                                       (sb!disassem::dstate-cur-offs dstate)
 125                                       n-word-bytes
 126                                       (sb!disassem::dstate-byte-order dstate)))
 127          (format (ldb (byte 2 30) word))
 128          (op3 (ldb (byte 6 19) word))
 129          (rs1 (ldb (byte 5 14) word))
 130          (rd (ldb (byte 5 25) word))
 131          (immed-p (not (zerop (ldb (byte 1 13) word))))
 132          (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
 133     (declare (ignore immed-p))
 134     ;; Only the value of format and rd are guaranteed to be correct
 135     ;; because the disassembler is trying to print out the value of a
 136     ;; register.  The other values may not be right.
 137     (case format
 138       (2
 139        (case op3
 140          (#b000000
 141           (when (= reg rs1)
 142             (handle-add-inst rs1 immed-val rd dstate)))
 143          (#b111000
 144           (when (= reg rs1)
 145             (handle-jmpl-inst rs1 immed-val rd dstate)))
 146          (#b010001
 147           (when (= reg rs1)
 148             (handle-andcc-inst rs1 immed-val rd dstate)))))
 149       (3
 150        (case op3
 151          ((#b000000 #b000100)
 152           (when (= reg rs1)
 153             (handle-ld/st-inst rs1 immed-val rd dstate))))))
 154     ;; If this is not a SETHI instruction, and RD is the same as some
 155     ;; register used by SETHI, we delete the entry.  (In case we have
 156     ;; a SETHI without any additional instruction because the low bits
 157     ;; were zero.)
 158     (unless (and (zerop format) (= #b100 (ldb (byte 3 22) word)))
 159       (let ((sethi (assoc rd *note-sethi-inst*)))
 160         (when sethi
 161           (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))
 162
 163 (defun handle-add-inst (rs1 immed-val rd dstate)
 164   (let* ((sethi (assoc rs1 *note-sethi-inst*)))
 165     (cond
 166       (sethi
 167        ;; RS1 was used in a SETHI instruction.  Assume that
 168        ;; this is the offset part of the SETHI instruction for
 169        ;; a full 32-bit address of something.  Make a note
 170        ;; about this usage as a Lisp assembly routine or
 171        ;; foreign routine, if possible.  If not, just note the
 172        ;; final value.
 173        (let ((addr (+ immed-val (ash (cdr sethi) 10))))
 174          (or (sb!disassem::note-code-constant-absolute addr dstate)
 175              (sb!disassem:maybe-note-assembler-routine addr t dstate)
 176              (sb!disassem:note (format nil "~A = #x~8,'0X"
 177                                      (get-reg-name rd) addr)
 178                              dstate)))
 179        (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
 180       ((= rs1 null-offset)
 181        ;; We have an ADD %NULL, <n>, RD instruction.  This is a
 182        ;; reference to a static symbol.
 183        (sb!disassem:maybe-note-nil-indexed-object immed-val
 184                                                dstate))
 185       ((= rs1 alloc-offset)
 186        ;; ADD %ALLOC, n.  This must be some allocation or
 187        ;; pseudo-atomic stuff
 188        (cond ((and (= immed-val 4) (= rd alloc-offset)
 189                    (not *pseudo-atomic-set*))
 190               ;; "ADD 4, %ALLOC" sets the flag
 191               (sb!disassem::note "Set pseudo-atomic flag" dstate)
 192               (setf *pseudo-atomic-set* t))
 193              ((= rd alloc-offset)
 194               ;; "ADD n, %ALLOC" is reseting the flag, with extra
 195               ;; allocation.
 196               (sb!disassem:note
 197                (format nil "Reset pseudo-atomic, allocated ~D bytes"
 198                        (+ immed-val 4)) dstate)
 199               (setf *pseudo-atomic-set* nil))))
 200       #+nil ((and (= rs1 zero-offset) *pseudo-atomic-set*)
 201        ;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very
 202        ;; likely loading up a header word.  Make a note to that
 203        ;; effect.
 204        (let ((type (second (assoc (logand immed-val #xff) header-word-type-alist)))
 205              (size (ldb (byte 24 8) immed-val)))
 206          (when type
 207            (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
 208                           dstate)))))))
 209
 210 (defun handle-jmpl-inst (rs1 immed-val rd dstate)
 211   (declare (ignore rd))
 212   (let* ((sethi (assoc rs1 *note-sethi-inst*)))
 213     (when sethi
 214       ;; RS1 was used in a SETHI instruction.  Assume that
 215       ;; this is the offset part of the SETHI instruction for
 216       ;; a full 32-bit address of something.  Make a note
 217       ;; about this usage as a Lisp assembly routine or
 218       ;; foreign routine, if possible.  If not, just note the
 219       ;; final value.
 220       (let ((addr (+ immed-val (ash (cdr sethi) 10))))
 221         (sb!disassem:maybe-note-assembler-routine addr t dstate)
 222         (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))
 223
 224 (defun handle-ld/st-inst (rs1 immed-val rd dstate)
 225   (declare (ignore rd))
 226   ;; Got an LDUW/LD or STW instruction, with immediate offset.
 227   (case rs1
 228     (29
 229      ;; A reference to a code constant (reg = %CODE)
 230      (sb!disassem:note-code-constant immed-val dstate))
 231     (2
 232      ;; A reference to a static symbol or static function (reg =
 233      ;; %NULL)
 234      (or (sb!disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
 235                                                       dstate)
 236          #+nil (sb!disassem::maybe-note-static-function immed-val dstate)))
 237     (t
 238      (let ((sethi (assoc rs1 *note-sethi-inst*)))
 239        (when sethi
 240          (let ((addr (+ immed-val (ash (cdr sethi) 10))))
 241            (sb!disassem:maybe-note-assembler-routine addr nil dstate)
 242            (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))
 243
 244 (defun handle-andcc-inst (rs1 immed-val rd dstate)
 245   ;; ANDCC %ALLOC, 3, %ZERO instruction
 246   (when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3))
 247     (sb!disassem:note "pseudo-atomic interrupted?" dstate)))
 248
 249 (sb!disassem:define-arg-type reg
 250   :printer (lambda (value stream dstate)
 251                (declare (stream stream) (fixnum value))
 252                (let ((regname (get-reg-name value)))
 253                  (princ regname stream)
 254                  (sb!disassem:maybe-note-associated-storage-ref value
 255                                                                 'registers
 256                                                                 regname
 257                                                                 dstate)
 258                  (maybe-add-notes value dstate))))
 259
 260 (defparameter float-reg-symbols
 261   #.(coerce
 262      (loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
 263      'vector))
 264
 265 (sb!disassem:define-arg-type fp-reg
 266   :printer (lambda (value stream dstate)
 267                (declare (stream stream) (fixnum value))
 268                (let ((regname (aref float-reg-symbols value)))
 269                  (princ regname stream)
 270                  (sb!disassem:maybe-note-associated-storage-ref
 271                   value
 272                   'float-registers
 273                   regname
 274                   dstate))))
 275
 276 ;;; The extended 6 bit floating point register encoding for the double
 277 ;;; and long instructions of the sparc v9.
 278 (sb!disassem:define-arg-type fp-ext-reg
 279   :printer (lambda (value stream dstate)
 280                (declare (stream stream) (fixnum value))
 281                (let* (;; Decode the register number.
 282                       (value (if (oddp value) (+ value 31) value))
 283                       (regname (aref float-reg-symbols value)))
 284                  (princ regname stream)
 285                  (sb!disassem:maybe-note-associated-storage-ref
 286                   value
 287                   'float-registers
 288                   regname
 289                   dstate))))
 290
 291 (sb!disassem:define-arg-type relative-label
 292   :sign-extend t
 293   :use-label (lambda (value dstate)
 294                (declare (type (signed-byte 22) value)
 295                         (type sb!disassem:disassem-state dstate))
 296                (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
 297
 298 (defconstant-eqx branch-conditions
 299   '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
 300   #'equalp)
 301
 302 ;;; Note that these aren't the standard names for branch-conditions, I
 303 ;;; think they're a bit more readable (e.g., "eq" instead of "e").
 304 ;;; You could just put a vector of the normal ones here too.
 305
 306 (sb!disassem:define-arg-type branch-condition
 307   :printer (coerce branch-conditions 'vector))
 308
 309 (deftype branch-condition ()
 310   `(member ,@branch-conditions))
 311
 312 (defun branch-condition (condition)
 313   (or (position condition branch-conditions)
 314       (error "Unknown branch condition: ~S~%Must be one of: ~S"
 315              condition branch-conditions)))
 316
 317 (def!constant branch-cond-true
 318   #b1000)
 319
 320 (defconstant-eqx branch-fp-conditions
 321   '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)
 322   #'equalp)
 323
 324 (sb!disassem:define-arg-type branch-fp-condition
 325   :printer (coerce branch-fp-conditions 'vector))
 326
 327 (sb!disassem:define-arg-type call-fixup :use-label t)
 328
 329 (deftype fp-branch-condition ()
 330   `(member ,@branch-fp-conditions))
 331
 332 (defun fp-branch-condition (condition)
 333   (or (position condition branch-fp-conditions)
 334       (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
 335              condition branch-fp-conditions)))
 336
 337 \f
 338 ;;;; dissassem:define-instruction-formats
 339
 340 (sb!disassem:define-instruction-format
 341     (format-1 32 :default-printer '(:name :tab disp))
 342   (op   :field (byte 2 30) :value 1)
 343   (disp :field (byte 30 0)))
 344
 345 (sb!disassem:define-instruction-format
 346     (format-2-immed 32 :default-printer '(:name :tab immed ", " rd))
 347   (op    :field (byte 2 30) :value 0)
 348   (rd    :field (byte 5 25) :type 'reg)
 349   (op2   :field (byte 3 22))
 350   (immed :field (byte 22 0)))
 351
 352
 353
 354 (sb!disassem:define-instruction-format
 355     (format-2-branch 32 :default-printer `(:name (:unless (:constant ,branch-cond-true) cond)
 356                                            (:unless (a :constant 0) "," 'A)
 357                                            :tab
 358                                            disp))
 359   (op   :field (byte 2 30) :value 0)
 360   (a    :field (byte 1 29) :value 0)
 361   (cond :field (byte 4 25) :type 'branch-condition)
 362   (op2  :field (byte 3 22))
 363   (disp :field (byte 22 0) :type 'relative-label))
 364
 365 ;; Branch with prediction instruction for V9
 366
 367 ;; Currently only %icc and %xcc are used of the four possible values
 368
 369 (defconstant-eqx integer-condition-registers
 370   '(:icc :reserved :xcc :reserved)
 371   #'equalp)
 372
 373 (defconstant-eqx integer-cond-reg-name-vec
 374   (coerce integer-condition-registers 'vector)
 375   #'equalp)
 376
 377 (deftype integer-condition-register ()
 378   `(member ,@(remove :reserved integer-condition-registers)))
 379
 380 (defparameter integer-condition-reg-symbols
 381   (map 'vector
 382        (lambda (name)
 383            (make-symbol (concatenate 'string "%" (string name))))
 384        integer-condition-registers))
 385
 386 (sb!disassem:define-arg-type integer-condition-register
 387     :printer (lambda (value stream dstate)
 388                  (declare (stream stream) (fixnum value) (ignore dstate))
 389                  (let ((regname (aref integer-condition-reg-symbols value)))
 390                    (princ regname stream))))
 391
 392 (defconstant-eqx branch-predictions
 393   '(:pn :pt)
 394   #'equalp)
 395
 396 (sb!disassem:define-arg-type branch-prediction
 397     :printer (coerce branch-predictions 'vector))
 398
 399 (defun integer-condition (condition-reg)
 400   (declare (type (member :icc :xcc) condition-reg))
 401   (or (position condition-reg integer-condition-registers)
 402       (error "Unknown integer condition register:  ~S~%"
 403              condition-reg)))
 404
 405 (defun branch-prediction (pred)
 406   (or (position pred branch-predictions)
 407       (error "Unknown branch prediction:  ~S~%Must be one of: ~S~%"
 408              pred branch-predictions)))
 409
 410 (defconstant-eqx branch-pred-printer
 411   `(:name (:unless (:constant ,branch-cond-true) cond)
 412           (:unless (a :constant 0) "," 'A)
 413           (:unless (p :constant 1) "," 'pn)
 414           :tab
 415           cc
 416           ", "
 417           disp)
 418   #'equalp)
 419
 420 (sb!disassem:define-instruction-format
 421     (format-2-branch-pred 32 :default-printer branch-pred-printer)
 422   (op   :field (byte 2 30) :value 0)
 423   (a    :field (byte 1 29) :value 0)
 424   (cond :field (byte 4 25) :type 'branch-condition)
 425   (op2  :field (byte 3 22))
 426   (cc   :field (byte 2 20) :type 'integer-condition-register)
 427   (p    :field (byte 1 19))
 428   (disp :field (byte 19 0) :type 'relative-label))
 429
 430 (defconstant-eqx fp-condition-registers
 431   '(:fcc0 :fcc1 :fcc2 :fcc3)
 432   #'equalp)
 433
 434 (defconstant-eqx fp-cond-reg-name-vec
 435   (coerce fp-condition-registers 'vector)
 436   #'equalp)
 437
 438 (defparameter fp-condition-reg-symbols
 439   (map 'vector
 440        (lambda (name)
 441            (make-symbol (concatenate 'string "%" (string name))))
 442        fp-condition-registers))
 443
 444 (sb!disassem:define-arg-type fp-condition-register
 445     :printer (lambda (value stream dstate)
 446                  (declare (stream stream) (fixnum value) (ignore dstate))
 447                  (let ((regname (aref fp-condition-reg-symbols value)))
 448                    (princ regname stream))))
 449
 450 (sb!disassem:define-arg-type fp-condition-register-shifted
 451     :printer (lambda (value stream dstate)
 452                  (declare (stream stream) (fixnum value) (ignore dstate))
 453                  (let ((regname (aref fp-condition-reg-symbols (ash value -1))))
 454                    (princ regname stream))))
 455
 456 (defun fp-condition (condition-reg)
 457   (or (position condition-reg fp-condition-registers)
 458       (error "Unknown integer condition register:  ~S~%"
 459              condition-reg)))
 460
 461 (defconstant-eqx fp-branch-pred-printer
 462   `(:name (:unless (:constant ,branch-cond-true) cond)
 463           (:unless (a :constant 0) "," 'A)
 464           (:unless (p :constant 1) "," 'pn)
 465           :tab
 466           fcc
 467           ", "
 468           disp)
 469   #'equalp)
 470
 471 (sb!disassem:define-instruction-format
 472     (format-2-fp-branch-pred 32 :default-printer fp-branch-pred-printer)
 473   (op   :field (byte 2 30) :value 0)
 474   (a    :field (byte 1 29) :value 0)
 475   (cond :field (byte 4 25) :type 'branch-fp-condition)
 476   (op2  :field (byte 3 22))
 477   (fcc  :field (byte 2 20) :type 'fp-condition-register)
 478   (p    :field (byte 1 19))
 479   (disp :field (byte 19 0) :type 'relative-label))
 480
 481
 482
 483 (sb!disassem:define-instruction-format
 484     (format-2-unimp 32 :default-printer '(:name :tab data))
 485   (op     :field (byte 2 30) :value 0)
 486   (ignore :field (byte 5 25) :value 0)
 487   (op2    :field (byte 3 22) :value 0)
 488   (data   :field (byte 22 0)))
 489
 490 (defconstant-eqx f3-printer
 491   '(:name :tab
 492           (:unless (:same-as rd) rs1 ", ")
 493           (:choose rs2 immed) ", "
 494           rd)
 495   #'equalp)
 496
 497 (sb!disassem:define-instruction-format
 498     (format-3-reg 32 :default-printer f3-printer)
 499   (op  :field (byte 2 30))
 500   (rd  :field (byte 5 25) :type 'reg)
 501   (op3 :field (byte 6 19))
 502   (rs1 :field (byte 5 14) :type 'reg)
 503   (i   :field (byte 1 13) :value 0)
 504   (asi :field (byte 8 5)  :value 0)
 505   (rs2 :field (byte 5 0)  :type 'reg))
 506
 507 (sb!disassem:define-instruction-format
 508     (format-3-immed 32 :default-printer f3-printer)
 509   (op    :field (byte 2 30))
 510   (rd    :field (byte 5 25) :type 'reg)
 511   (op3   :field (byte 6 19))
 512   (rs1   :field (byte 5 14) :type 'reg)
 513   (i     :field (byte 1 13) :value 1)
 514   (immed :field (byte 13 0) :sign-extend t))    ; usually sign extended
 515
 516 (sb!disassem:define-instruction-format
 517     (format-binary-fpop 32
 518      :default-printer '(:name :tab rs1 ", " rs2 ", " rd))
 519   (op   :field (byte 2 30))
 520   (rd   :field (byte 5 25) :type 'fp-reg)
 521   (op3  :field (byte 6 19))
 522   (rs1  :field (byte 5 14) :type 'fp-reg)
 523   (opf  :field (byte 9 5))
 524   (rs2  :field (byte 5 0) :type 'fp-reg))
 525
 526 ;;; Floating point load/save instructions encoding.
 527 (sb!disassem:define-instruction-format
 528     (format-unary-fpop 32 :default-printer '(:name :tab rs2 ", " rd))
 529   (op   :field (byte 2 30))
 530   (rd   :field (byte 5 25) :type 'fp-reg)
 531   (op3  :field (byte 6 19))
 532   (rs1  :field (byte 5 14) :value 0)
 533   (opf  :field (byte 9 5))
 534   (rs2  :field (byte 5 0) :type 'fp-reg))
 535
 536 ;;; Floating point comparison instructions encoding.
 537
 538 ;; This is a merge of the instructions for FP comparison and FP
 539 ;; conditional moves available in the Sparc V9.  The main problem is
 540 ;; that the new instructions use part of the opcode space used by the
 541 ;; comparison instructions.  In particular, the OPF field is arranged
 542 ;; as so:
 543 ;;
 544 ;; Bit          1       0
 545 ;;              3       5
 546 ;; FMOVcc       0nn0000xx       %fccn
 547 ;;              1000000xx       %icc
 548 ;;              1100000xx       %xcc
 549 ;; FMOVR        0ccc001yy
 550 ;; FCMP         001010zzz
 551 ;;
 552 ;; So we see that if we break up the OPF field into 4 pieces, opf0,
 553 ;; opf1, opf2, and opf3, we can distinguish between these
 554 ;; instructions. So bit 9 (opf2) can be used to distinguish between
 555 ;; FCMP and the rest.  Also note that the nn field overlaps with the
 556 ;; ccc.  We need to take this into account as well.
 557 ;;
 558 (sb!disassem:define-instruction-format
 559     (format-fpop2 32
 560                   :default-printer #!-sparc-v9 '(:name :tab rs1 ", " rs2)
 561                                    #!+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2))
 562   (op   :field (byte 2 30))
 563   (rd   :field (byte 5 25) :value 0)
 564   (op3  :field (byte 6 19))
 565   (rs1  :field (byte 5 14))
 566   (opf0 :field (byte 1 13))
 567   (opf1 :field (byte 3 10))
 568   (opf2 :field (byte 1 9))
 569   (opf3 :field (byte 4 5))
 570   (rs2  :field (byte 5 0) :type 'fp-reg))
 571
 572 ;;; Shift instructions
 573 (sb!disassem:define-instruction-format
 574     (format-3-shift-reg 32 :default-printer f3-printer)
 575   (op   :field (byte 2 30))
 576   (rd    :field (byte 5 25) :type 'reg)
 577   (op3  :field (byte 6 19))
 578   (rs1   :field (byte 5 14) :type 'reg)
 579   (i     :field (byte 1 13) :value 0)
 580   (x     :field (byte 1 12))
 581   (asi   :field (byte 7 5) :value 0)
 582   (rs2   :field (byte 5 0) :type 'reg))
 583
 584 (sb!disassem:define-instruction-format
 585     (format-3-shift-immed 32 :default-printer f3-printer)
 586   (op   :field (byte 2 30))
 587   (rd    :field (byte 5 25) :type 'reg)
 588   (op3  :field (byte 6 19))
 589   (rs1   :field (byte 5 14) :type 'reg)
 590   (i     :field (byte 1 13) :value 1)
 591   (x     :field (byte 1 12))
 592   (immed :field (byte 12 0) :sign-extend nil))
 593
 594 \f
 595 ;;; Conditional moves (only available for Sparc V9 architectures)
 596
 597 ;; The names of all of the condition registers on the V9: 4 FP
 598 ;; conditions, the original integer condition register and the new
 599 ;; extended register.  The :reserved register is reserved on the V9.
 600
 601 (defconstant-eqx cond-move-condition-registers
 602   '(:fcc0 :fcc1 :fcc2 :fcc3 :icc :reserved :xcc :reserved)
 603   #'equalp)
 604
 605 (defconstant-eqx cond-move-cond-reg-name-vec
 606   (coerce cond-move-condition-registers 'vector)
 607   #'equalp)
 608
 609 (deftype cond-move-condition-register ()
 610     `(member ,@(remove :reserved cond-move-condition-registers)))
 611
 612 (defparameter cond-move-condition-reg-symbols
 613   (map 'vector
 614        (lambda (name)
 615            (make-symbol (concatenate 'string "%" (string name))))
 616        cond-move-condition-registers))
 617
 618 (sb!disassem:define-arg-type cond-move-condition-register
 619     :printer (lambda (value stream dstate)
 620                  (declare (stream stream) (fixnum value) (ignore dstate))
 621                  (let ((regname (aref cond-move-condition-reg-symbols value)))
 622                    (princ regname stream))))
 623
 624 ;; From the given condition register, figure out what the cc2, cc1,
 625 ;; and cc0 bits should be.  Return cc2 and cc1/cc0 concatenated.
 626 (defun cond-move-condition-parts (condition-reg)
 627   (let ((posn (position condition-reg cond-move-condition-registers)))
 628     (if posn
 629         (truncate posn 4)
 630         (error "Unknown conditional move condition register:  ~S~%"
 631                condition-reg))))
 632
 633 (defun cond-move-condition (condition-reg)
 634   (or (position condition-reg cond-move-condition-registers)
 635       (error "Unknown conditional move condition register:  ~S~%"
 636              condition-reg)))
 637
 638 (defconstant-eqx cond-move-printer
 639   `(:name cond :tab
 640           cc ", " (:choose immed rs2) ", " rd)
 641   #'equalp)
 642
 643 ;; Conditional move integer register on integer or FP condition code
 644 (sb!disassem:define-instruction-format
 645     (format-4-cond-move 32 :default-printer cond-move-printer)
 646   (op   :field (byte 2 30))
 647   (rd    :field (byte 5 25) :type 'reg)
 648   (op3  :field (byte 6 19))
 649   (cc2   :field (byte 1 18) :value 1)
 650   (cond  :field (byte 4 14) :type 'branch-condition)
 651   (i     :field (byte 1 13) :value 0)
 652   (cc    :field (byte 2 11) :type 'integer-condition-register)
 653   (empty :field (byte 6 5) :value 0)
 654   (rs2   :field (byte 5 0) :type 'reg))
 655
 656 (sb!disassem:define-instruction-format
 657     (format-4-cond-move-immed 32 :default-printer cond-move-printer)
 658   (op    :field (byte 2 30))
 659   (rd    :field (byte 5 25) :type 'reg)
 660   (op3   :field (byte 6 19))
 661   (cc2   :field (byte 1 18) :value 1)
 662   (cond  :field (byte 4 14) :type 'branch-condition)
 663   (i     :field (byte 1 13) :value 1)
 664   (cc    :field (byte 2 11) :type 'integer-condition-register)
 665   (immed :field (byte 11 0) :sign-extend t))
 666
 667 ;; Floating-point versions of the above integer conditional moves
 668 (defconstant-eqx cond-fp-move-printer
 669   `(:name rs1 :tab opf1 ", " rs2 ", " rd)
 670   #'equalp)
 671
 672 ;;; Conditional move on integer register condition (only on Sparc
 673 ;;; V9). That is, move an integer register if some other integer
 674 ;;; register satisfies some condition.
 675
 676 (defconstant-eqx cond-move-integer-conditions
 677   '(:reserved :z :lez :lz :reserved :nz :gz :gez)
 678   #'equalp)
 679
 680 (defconstant-eqx cond-move-integer-condition-vec
 681   (coerce cond-move-integer-conditions 'vector)
 682   #'equalp)
 683
 684 (deftype cond-move-integer-condition ()
 685   `(member ,@(remove :reserved cond-move-integer-conditions)))
 686
 687 (sb!disassem:define-arg-type register-condition
 688     :printer (lambda (value stream dstate)
 689                  (declare (stream stream) (fixnum value) (ignore dstate))
 690                  (let ((regname (aref cond-move-integer-condition-vec value)))
 691                    (princ regname stream))))
 692
 693 (defconstant-eqx cond-move-integer-printer
 694   `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)
 695   #'equalp)
 696
 697 (defun register-condition (rcond)
 698   (or (position rcond cond-move-integer-conditions)
 699       (error "Unknown register condition:  ~S~%" rcond)))
 700
 701 (sb!disassem:define-instruction-format
 702     (format-4-cond-move-integer 32 :default-printer cond-move-integer-printer)
 703   (op    :field (byte 2 30))
 704   (rd    :field (byte 5 25) :type 'reg)
 705   (op3   :field (byte 6 19))
 706   (rs1   :field (byte 5 14) :type 'reg)
 707   (i     :field (byte 1 13) :value 0)
 708   (rcond :field (byte 3 10) :type 'register-condition)
 709   (opf   :field (byte 5 5))
 710   (rs2   :field (byte 5 0) :type 'reg))
 711
 712 (sb!disassem:define-instruction-format
 713     (format-4-cond-move-integer-immed 32 :default-printer cond-move-integer-printer)
 714   (op    :field (byte 2 30))
 715   (rd    :field (byte 5 25) :type 'reg)
 716   (op3   :field (byte 6 19))
 717   (rs1   :field (byte 5 14) :type 'reg)
 718   (i     :field (byte 1 13) :value 1)
 719   (rcond :field (byte 3 10) :type 'register-condition)
 720   (immed :field (byte 10 0) :sign-extend t))
 721
 722 (defconstant-eqx trap-printer
 723   `(:name rd :tab cc ", " immed)
 724   #'equalp)
 725
 726 (sb!disassem:define-instruction-format
 727     (format-4-trap 32 :default-printer trap-printer)
 728   (op    :field (byte 2 30))
 729   (rd    :field (byte 5 25) :type 'reg)
 730   (op3   :field (byte 6 19))
 731   (rs1   :field (byte 5 14) :type 'reg)
 732   (i     :field (byte 1 13) :value 1)
 733   (cc    :field (byte 2 11) :type 'integer-condition-register)
 734   (immed :field (byte 11 0) :sign-extend t))    ; usually sign extended
 735
 736
 737 (defconstant-eqx cond-fp-move-integer-printer
 738   `(:name opf1 :tab rs1 ", " rs2 ", " rd)
 739   #'equalp)
 740
 741 \f
 742 ;;;; Primitive emitters.
 743
 744 (define-bitfield-emitter emit-word 32
 745   (byte 32 0))
 746
 747 (define-bitfield-emitter emit-short 16
 748   (byte 16 0))
 749
 750 (define-bitfield-emitter emit-format-1 32
 751   (byte 2 30) (byte 30 0))
 752
 753 (define-bitfield-emitter emit-format-2-immed 32
 754   (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
 755
 756 (define-bitfield-emitter emit-format-2-branch 32
 757   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
 758
 759 ;; Integer and FP branches with prediction for V9
 760 (define-bitfield-emitter emit-format-2-branch-pred 32
 761   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
 762 (define-bitfield-emitter emit-format-2-fp-branch-pred 32
 763   (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
 764
 765 (define-bitfield-emitter emit-format-2-unimp 32
 766   (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
 767
 768 (define-bitfield-emitter emit-format-3-reg 32
 769   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
 770   (byte 5 0))
 771
 772 (define-bitfield-emitter emit-format-3-immed 32
 773   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
 774
 775 (define-bitfield-emitter emit-format-3-fpop 32
 776   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
 777
 778 (define-bitfield-emitter emit-format-3-fpop2 32
 779   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14)
 780   (byte 1 13) (byte 3 10) (byte 1 9) (byte 4 5)
 781   (byte 5 0))
 782
 783 ;;; Shift instructions
 784
 785 (define-bitfield-emitter emit-format-3-shift-reg 32
 786   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 7 5)
 787   (byte 5 0))
 788
 789 (define-bitfield-emitter emit-format-3-shift-immed 32
 790   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 12 0))
 791
 792 ;;; Conditional moves
 793
 794 ;; Conditional move in condition code
 795 (define-bitfield-emitter emit-format-4-cond-move 32
 796   (byte 2 30) (byte 5 25) (byte 6 19) (byte 1 18) (byte 4 14) (byte 1 13) (byte 2 11)
 797   (byte 11 0))
 798
 799 ;; Conditional move on integer condition
 800 (define-bitfield-emitter emit-format-4-cond-move-integer 32
 801   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) (byte 5 5)
 802   (byte 5 0))
 803
 804 (define-bitfield-emitter emit-format-4-cond-move-integer-immed 32
 805   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10)
 806   (byte 10 0))
 807
 808 (define-bitfield-emitter emit-format-4-trap 32
 809   (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11)
 810   (byte 11 0))
 811
 812 \f
 813 ;;;; Most of the format-3-instructions.
 814
 815 (defun emit-format-3-inst (segment op op3 dst src1 src2
 816                                    &key load-store fixup dest-kind)
 817   (unless src2
 818     (cond ((and (typep src1 'tn) load-store)
 819            (setf src2 0))
 820           (t
 821            (setf src2 src1)
 822            (setf src1 dst))))
 823   (etypecase src2
 824     (tn
 825      (emit-format-3-reg segment op
 826                         (if dest-kind
 827                             (fp-reg-tn-encoding dst)
 828                             (reg-tn-encoding dst))
 829                         op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
 830     (integer
 831      (emit-format-3-immed segment op
 832                           (if dest-kind
 833                               (fp-reg-tn-encoding dst)
 834                               (reg-tn-encoding dst))
 835                           op3 (reg-tn-encoding src1) 1 src2))
 836     (fixup
 837      (unless (or load-store fixup)
 838        (error "Fixups aren't allowed."))
 839      (note-fixup segment :add src2)
 840      (emit-format-3-immed segment op
 841                           (if dest-kind
 842                               (fp-reg-tn-encoding dst)
 843                               (reg-tn-encoding dst))
 844                           op3 (reg-tn-encoding src1) 1 0))))
 845
 846 ;;; Shift instructions because an extra bit is used in Sparc V9's to
 847 ;;; indicate whether the shift is a 32-bit or 64-bit shift.
 848 ;;;
 849 (defun emit-format-3-shift-inst (segment op op3 dst src1 src2 &key extended)
 850   (unless src2
 851     (setf src2 src1)
 852     (setf src1 dst))
 853   (etypecase src2
 854     (tn
 855      (emit-format-3-shift-reg segment op (reg-tn-encoding dst)
 856                               op3 (reg-tn-encoding src1) 0 (if extended 1 0)
 857                               0 (reg-tn-encoding src2)))
 858     (integer
 859      (emit-format-3-shift-immed segment op (reg-tn-encoding dst)
 860                                 op3 (reg-tn-encoding src1) 1
 861                                 (if extended 1 0) src2))))
 862
 863
 864 (eval-when (:compile-toplevel :execute)
 865
 866 ;;; have to do this because def!constant is evalutated in the null lex env.
 867 (defmacro with-ref-format (printer)
 868   `(let* ((addend
 869            '(:choose (:plus-integer immed) ("+" rs2)))
 870           (ref-format
 871            `("[" rs1 (:unless (:constant 0) ,addend) "]"
 872              (:choose (:unless (:constant 0) asi) nil))))
 873      ,printer))
 874
 875 (defconstant-eqx load-printer
 876   (with-ref-format `(:NAME :TAB ,ref-format ", " rd))
 877   #'equalp)
 878
 879 (defconstant-eqx store-printer
 880   (with-ref-format `(:NAME :TAB rd ", " ,ref-format))
 881   #'equalp)
 882
 883 ) ; EVAL-WHEN
 884
 885 (macrolet ((define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
 886                                  (printer :default) reads writes flushable print-name)
 887   (let ((printer
 888          (if (eq printer :default)
 889              (case load-store
 890                ((nil) :default)
 891                ((:load t) 'load-printer)
 892                (:store 'store-printer))
 893              printer)))
 894     (when (and (atom reads) (not (null reads)))
 895       (setf reads (list reads)))
 896     (when (and (atom writes) (not (null writes)))
 897        (setf writes (list writes)))
 898     `(define-instruction ,name (segment dst src1 &optional src2)
 899        (:declare (type tn dst)
 900                  ,(if (or fixup load-store)
 901                       '(type (or tn (signed-byte 13) null fixup) src1 src2)
 902                       '(type (or tn (signed-byte 13) null) src1 src2)))
 903        (:printer format-3-reg
 904                  ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
 905                  ,printer
 906                  ,@(when print-name `(:print-name ,print-name)))
 907        (:printer format-3-immed
 908                  ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
 909                  ,printer
 910                  ,@(when print-name `(:print-name ,print-name)))
 911        ,@(when flushable
 912            '((:attributes flushable)))
 913        (:dependencies
 914         (reads src1)
 915         ,@(let ((reads-list nil))
 916             (dolist (read reads)
 917               (push (list 'reads read) reads-list))
 918             reads-list)
 919         ,@(cond ((eq load-store :store)
 920                  '((reads dst)
 921                    (if src2 (reads src2))))
 922                  ((eq load-store t)
 923                   '((reads :memory)
 924                     (reads dst)
 925                     (if src2 (reads src2))))
 926                 ((eq load-store :load)
 927                  '((reads :memory)
 928                    (if src2 (reads src2) (reads dst))))
 929                 (t
 930                  '((if src2 (reads src2) (reads dst)))))
 931         ,@(let ((writes-list nil))
 932             (dolist (write writes)
 933               (push (list 'writes write) writes-list))
 934             writes-list)
 935         ,@(cond ((eq load-store :store)
 936                  '((writes :memory :partially t)))
 937                 ((eq load-store t)
 938                  '((writes :memory :partially t)
 939                    (writes dst)))
 940                 ((eq load-store :load)
 941                  '((writes dst)))
 942                 (t
 943                  '((writes dst)))))
 944        (:delay 0)
 945        (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
 946                                      :load-store ,load-store
 947                                      :fixup ,fixup
 948                                      :dest-kind (not (eq ',dest-kind 'reg)))))))
 949
 950            (define-f3-shift-inst (name op op3 &key extended)
 951                `(define-instruction ,name (segment dst src1 &optional src2)
 952                  (:declare (type tn dst)
 953                   (type (or tn (unsigned-byte 6) null) src1 src2))
 954                  (:printer format-3-shift-reg
 955                   ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
 956                  (:printer format-3-shift-immed
 957                   ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
 958                  (:dependencies
 959                   (reads src1)
 960                   (if src2 (reads src2) (reads dst))
 961                   (writes dst))
 962                  (:delay 0)
 963                  (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
 964                             :extended ,extended)))))
 965
 966   (define-f3-inst ldsb #b11 #b001001 :load-store :load)
 967   (define-f3-inst ldsh #b11 #b001010 :load-store :load)
 968   (define-f3-inst ldub #b11 #b000001 :load-store :load)
 969   (define-f3-inst lduh #b11 #b000010 :load-store :load)
 970
 971   ;; This instruction is called lduw for V9 , but looks exactly like ld
 972   ;; on previous architectures.
 973   (define-f3-inst ld #b11 #b000000 :load-store :load
 974                   #!+sparc-v9 :print-name #!+sparc-v9 'lduw)
 975
 976   (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9
 977
 978   ;; ldd is deprecated on the Sparc V9.
 979   (define-f3-inst ldd #b11 #b000011 :load-store :load)
 980
 981   (define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9
 982
 983   (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
 984   (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
 985   (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-reg :load-store :load)       ; v9
 986   (define-f3-inst stb #b11 #b000101 :load-store :store)
 987   (define-f3-inst sth #b11 #b000110 :load-store :store)
 988   (define-f3-inst st #b11 #b000100 :load-store :store)
 989
 990   ;; std is deprecated on the Sparc V9.
 991   (define-f3-inst std #b11 #b000111 :load-store :store)
 992
 993   (define-f3-inst stx #b11 #b001110 :load-store :store) ; v9
 994
 995   (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
 996   (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
 997   (define-f3-inst stqf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9
 998   (define-f3-inst ldstub #b11 #b001101 :load-store t)
 999
1000   ;; swap is deprecated on the Sparc V9
1001   (define-f3-inst swap #b11 #b001111 :load-store t)
1002
1003   (define-f3-inst add #b10 #b000000 :fixup t)
1004   (define-f3-inst addcc #b10 #b010000 :writes :psr)
1005   (define-f3-inst addx #b10 #b001000 :reads :psr)
1006   (define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr)
1007   (define-f3-inst taddcc #b10 #b100000 :writes :psr)
1008
1009   ;; taddcctv is deprecated on the Sparc V9.  Use taddcc and bpvs or
1010   ;; taddcc and trap to get a similar effect.  (Requires changing the C
1011   ;; code though!)
1012   ;;(define-f3-inst taddcctv #b10 #b100010 :writes :psr)
1013
1014   (define-f3-inst sub #b10 #b000100)
1015   (define-f3-inst subcc #b10 #b010100 :writes :psr)
1016   (define-f3-inst subx #b10 #b001100 :reads :psr)
1017   (define-f3-inst subxcc #b10 #b011100 :reads :psr :writes :psr)
1018   (define-f3-inst tsubcc #b10 #b100001 :writes :psr)
1019
1020   ;; tsubcctv is deprecated on the Sparc V9.  Use tsubcc and bpvs or
1021   ;; tsubcc and trap to get a similar effect.  (Requires changing the C
1022   ;; code though!)
1023   ;;(define-f3-inst tsubcctv #b10 #b100011 :writes :psr)
1024
1025   (define-f3-inst mulscc #b10 #b100100 :reads :y :writes (:psr :y))
1026   (define-f3-inst and #b10 #b000001)
1027   (define-f3-inst andcc #b10 #b010001 :writes :psr)
1028   (define-f3-inst andn #b10 #b000101)
1029   (define-f3-inst andncc #b10 #b010101 :writes :psr)
1030   (define-f3-inst or #b10 #b000010)
1031   (define-f3-inst orcc #b10 #b010010 :writes :psr)
1032   (define-f3-inst orn #b10 #b000110)
1033   (define-f3-inst orncc #b10 #b010110 :writes :psr)
1034   (define-f3-inst xor #b10 #b000011)
1035   (define-f3-inst xorcc #b10 #b010011 :writes :psr)
1036   (define-f3-inst xnor #b10 #b000111)
1037   (define-f3-inst xnorcc #b10 #b010111 :writes :psr)
1038
1039   (define-f3-shift-inst sll #b10 #b100101)
1040   (define-f3-shift-inst srl #b10 #b100110)
1041   (define-f3-shift-inst sra #b10 #b100111)
1042   (define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9
1043   (define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9
1044   (define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9
1045
1046   (define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
1047   (define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)
1048
1049   ;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are
1050   ;; deprecated on the Sparc V9.  Use mulx, sdivx, and udivx instead.
1051   (define-f3-inst smul #b10 #b001011 :writes :y)                        ; v8
1052   (define-f3-inst smulcc #b10 #b011011 :writes (:psr :y))               ; v8
1053   (define-f3-inst umul #b10 #b001010 :writes :y)                        ; v8
1054   (define-f3-inst umulcc #b10 #b011010 :writes (:psr :y))               ; v8
1055   (define-f3-inst sdiv #b10 #b001111 :reads :y)                 ; v8
1056   (define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr)  ; v8
1057   (define-f3-inst udiv #b10 #b001110 :reads :y)                 ; v8
1058   (define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr)  ; v8
1059
1060   (define-f3-inst mulx #b10 #b001001)   ; v9 for both signed and unsigned
1061   (define-f3-inst sdivx #b10 #b101101)  ; v9
1062   (define-f3-inst udivx #b10 #b001101)  ; v9
1063
1064   (define-f3-inst popc #b10 #b101110)   ; v9: count one bits
1065
1066 ) ; MACROLET
1067
1068 \f
1069 ;;;; Random instructions.
1070
1071 ;; ldfsr is deprecated on the Sparc V9.  Use ldxfsr instead
1072 (define-instruction ldfsr (segment src1 src2)
1073   (:declare (type tn src1) (type (signed-byte 13) src2))
1074   (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 0)))
1075   :pinned
1076   (:delay 0)
1077   (:emitter (emit-format-3-immed segment #b11 0 #b100001
1078                                  (reg-tn-encoding src1) 1 src2)))
1079
1080 #!+sparc-64
1081 (define-instruction ldxfsr (segment src1 src2)
1082   (:declare (type tn src1) (type (signed-byte 13) src2))
1083   (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1))
1084             '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
1085             :print-name 'ldx)
1086   :pinned
1087   (:delay 0)
1088   (:emitter (emit-format-3-immed segment #b11 1 #b100001
1089                                  (reg-tn-encoding src1) 1 src2)))
1090
1091 ;; stfsr is deprecated on the Sparc V9.  Use stxfsr instead.
1092 (define-instruction stfsr (segment src1 src2)
1093   (:declare (type tn src1) (type (signed-byte 13) src2))
1094   (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0)))
1095   :pinned
1096   (:delay 0)
1097   (:emitter (emit-format-3-immed segment #b11 0 #b100101
1098                                  (reg-tn-encoding src1) 1 src2)))
1099
1100 #!+sparc-64
1101 (define-instruction stxfsr (segment src1 src2)
1102   (:declare (type tn src1) (type (signed-byte 13) src2))
1103   (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1))
1104             '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
1105             :print-name 'stx)
1106   :pinned
1107   (:delay 0)
1108   (:emitter (emit-format-3-immed segment #b11 1 #b100101
1109                                  (reg-tn-encoding src1) 1 src2)))
1110
1111 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
1112   (defun sethi-arg-printer (value stream dstate)
1113     (format stream "%hi(#x~8,'0x)" (ash value 10))
1114     ;; Save the immediate value and the destination register from this
1115     ;; sethi instruction.  This is used later to print some possible
1116     ;; notes about the value loaded by sethi.
1117     (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
1118                                            (sb!disassem::dstate-cur-offs dstate)
1119                                            n-word-bytes
1120                                            (sb!disassem::dstate-byte-order dstate)))
1121            (imm22 (ldb (byte 22 0) word))
1122            (rd (ldb (byte 5 25) word)))
1123       (push (cons rd imm22) *note-sethi-inst*)))
1124 ) ; EVAL-WHEN
1125
1126
1127 (define-instruction sethi (segment dst src1)
1128   (:declare (type tn dst)
1129             (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
1130   (:printer format-2-immed
1131             ((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
1132   (:dependencies (writes dst))
1133   (:delay 0)
1134   (:emitter
1135    (etypecase src1
1136      (integer
1137       (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
1138                                  src1))
1139      (fixup
1140       (note-fixup segment :sethi src1)
1141       (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
1142
1143 ;; rdy is deprecated on the Sparc V9.  It's not needed with 64-bit
1144 ;; registers.
1145 (define-instruction rdy (segment dst)
1146   (:declare (type tn dst))
1147   (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
1148             '('RD :tab '%Y ", " rd))
1149   (:dependencies (reads :y) (writes dst))
1150   (:delay 0)
1151   (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b101000
1152                                0 0 0 0)))
1153
1154 (defconstant-eqx wry-printer
1155   '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
1156   #'equalp)
1157
1158 ;; wry is deprecated on the Sparc V9.  It's not needed with 64-bit
1159 ;; registers.
1160 (define-instruction wry (segment src1 &optional src2)
1161   (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
1162   (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
1163   (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
1164   (:dependencies (reads src1) (if src2 (reads src2)) (writes :y))
1165   (:delay 3)
1166   (:emitter
1167    (etypecase src2
1168      (null
1169       (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
1170      (tn
1171       (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
1172                          (reg-tn-encoding src2)))
1173      (integer
1174       (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
1175                            src2)))))
1176
1177 (defun snarf-error-junk (sap offset &optional length-only)
1178   (let* ((length (sb!sys:sap-ref-8 sap offset))
1179          (vector (make-array length :element-type '(unsigned-byte 8))))
1180     (declare (type sb!sys:system-area-pointer sap)
1181              (type (unsigned-byte 8) length)
1182              (type (simple-array (unsigned-byte 8) (*)) vector))
1183     (cond (length-only
1184            (values 0 (1+ length) nil nil))
1185           (t
1186            (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
1187                                                 vector 0 length)
1188            (collect ((sc-offsets)
1189                      (lengths))
1190              (lengths 1)                ; the length byte
1191              (let* ((index 0)
1192                     (error-number (sb!c:read-var-integer vector index)))
1193                (lengths index)
1194                (loop
1195                  (when (>= index length)
1196                    (return))
1197                  (let ((old-index index))
1198                    (sc-offsets (sb!c:read-var-integer vector index))
1199                    (lengths (- index old-index))))
1200                (values error-number
1201                        (1+ length)
1202                        (sc-offsets)
1203                        (lengths))))))))
1204
1205 (defun unimp-control (chunk inst stream dstate)
1206   (declare (ignore inst))
1207   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
1208     (case (format-2-unimp-data chunk dstate)
1209       (#.error-trap
1210        (nt "Error trap")
1211        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1212       (#.cerror-trap
1213        (nt "Cerror trap")
1214        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
1215       (#.object-not-list-trap
1216        (nt "Object not list trap"))
1217       (#.breakpoint-trap
1218        (nt "Breakpoint trap"))
1219       (#.pending-interrupt-trap
1220        (nt "Pending interrupt trap"))
1221       (#.halt-trap
1222        (nt "Halt trap"))
1223       (#.fun-end-breakpoint-trap
1224        (nt "Function end breakpoint trap"))
1225       (#.object-not-instance-trap
1226        (nt "Object not instance trap"))
1227     )))
1228
1229 (define-instruction unimp (segment data)
1230   (:declare (type (unsigned-byte 22) data))
1231   (:printer format-2-unimp () :default :control #'unimp-control
1232             :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
1233   (:delay 0)
1234   (:emitter (emit-format-2-unimp segment 0 0 0 data)))
1235
1236
1237 \f
1238 ;;;; Branch instructions.
1239
1240 ;; The branch instruction is deprecated on the Sparc V9.  Use the
1241 ;; branch with prediction instructions instead.
1242 (defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
1243   (emit-back-patch segment 4
1244     (lambda (segment posn)
1245         (unless target
1246           (setf target cond-or-target)
1247           (setf cond-or-target :t))
1248         (emit-format-2-branch
1249           segment #b00 a
1250           (if fp
1251               (fp-branch-condition cond-or-target)
1252               (branch-condition cond-or-target))
1253           op2
1254           (let ((offset (ash (- (label-position target) posn) -2)))
1255             (when (and (= a 1) (> 0 offset))
1256               (error "Offset of BA must be positive"))
1257             offset)))))
1258
1259 (defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
1260   (declare (type integer-condition-register cc))
1261   (aver (member :sparc-v9 *backend-subfeatures*))
1262   (emit-back-patch segment 4
1263     (lambda (segment posn)
1264         (unless target
1265           (setf target cond-or-target)
1266           (setf cond-or-target :t))
1267         (emit-format-2-branch-pred
1268           segment #b00 a
1269           (branch-condition cond-or-target)
1270           op2
1271           (integer-condition cc)
1272           (branch-prediction pred)
1273           (let ((offset (ash (- (label-position target) posn) -2)))
1274             (when (and (= a 1) (> 0 offset))
1275               (error "Offset of BA must be positive"))
1276             offset)))))
1277
1278 (defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
1279   (aver (member :sparc-v9 *backend-subfeatures*))
1280   (emit-back-patch segment 4
1281     (lambda (segment posn)
1282         (unless target
1283           (setf target cond-or-target)
1284           (setf cond-or-target :t))
1285         (emit-format-2-branch-pred
1286           segment #b00 a
1287           (fp-branch-condition cond-or-target)
1288           op2
1289           (fp-condition cc)
1290           (branch-prediction pred)
1291           (let ((offset (ash (- (label-position target) posn) -2)))
1292             (when (and (= a 1) (> 0 offset))
1293               (error "Offset of BA must be positive"))
1294             offset)))))
1295
1296 ;; So that I don't have to go change the syntax of every single use of
1297 ;; branches, I'm keeping the Lisp instruction names the same.  They
1298 ;; just get translated to the branch with prediction
1299 ;; instructions. However, the disassembler uses the correct V9
1300 ;; mnemonic.
1301 (define-instruction b (segment cond-or-target &rest args)
1302   (:declare (type (or label branch-condition) cond-or-target))
1303   (:printer format-2-branch ((op #b00) (op2 #b010)))
1304   (:attributes branch)
1305   (:dependencies (reads :psr))
1306   (:delay 1)
1307   (:emitter
1308    (cond
1309      ((member :sparc-v9 *backend-subfeatures*)
1310       (destructuring-bind (&optional target pred cc) args
1311         (declare (type (or label null) target))
1312         (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1313      (t
1314       (destructuring-bind (&optional target) args
1315         (declare (type (or label null) target))
1316         (emit-relative-branch segment 0 #b010 cond-or-target target))))))
1317
1318 (define-instruction bp (segment cond-or-target &optional target pred cc)
1319   (:declare (type (or label branch-condition) cond-or-target)
1320             (type (or label null) target))
1321   (:printer format-2-branch-pred ((op #b00) (op2 #b001))
1322             branch-pred-printer
1323             :print-name 'bp)
1324   (:attributes branch)
1325   (:dependencies (reads :psr))
1326   (:delay 1)
1327   (:emitter
1328    (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1329
1330 (define-instruction ba (segment cond-or-target &rest args)
1331   (:declare (type (or label branch-condition) cond-or-target))
1332   (:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
1333             nil
1334             :print-name 'b)
1335   (:attributes branch)
1336   (:dependencies (reads :psr))
1337   (:delay 0)
1338   (:emitter
1339    (cond
1340      ((member :sparc-v9 *backend-subfeatures*)
1341       (destructuring-bind (&optional target pred cc) args
1342         (declare (type (or label null) target))
1343         (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1344      (t
1345       (destructuring-bind (&optional target) args
1346         (declare (type (or label null) target))
1347         (emit-relative-branch segment 1 #b010 cond-or-target target))))))
1348
1349 (define-instruction bpa (segment cond-or-target &optional target pred cc)
1350   (:declare (type (or label branch-condition) cond-or-target)
1351             (type (or label null) target))
1352   (:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
1353             nil
1354             :print-name 'bp)
1355   (:attributes branch)
1356   (:dependencies (reads :psr))
1357   (:delay 0)
1358   (:emitter
1359    (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
1360
1361 ;; This doesn't cover all of the possible formats for the trap
1362 ;; instruction.  We really only want a trap with a immediate trap
1363 ;; value and with RS1 = register 0.  Also, the Sparc Compliance
1364 ;; Definition 2.4.1 says only trap numbers 16-31 are allowed for user
1365 ;; code.  All other trap numbers have other uses.  The restriction on
1366 ;; target will prevent us from using bad trap numbers by mistake.
1367
1368 (define-instruction t (segment condition target &optional cc)
1369   (:declare (type branch-condition condition)
1370             ;; KLUDGE: see comments in vm.lisp regarding
1371             ;; pseudo-atomic-trap.
1372             #!-linux
1373             (type (integer 16 31) target))
1374   (:printer format-3-immed ((op #b10)
1375                             (rd nil :type 'branch-condition)
1376                             (op3 #b111010)
1377                             (rs1 0))
1378             '(:name rd :tab immed))
1379   (:attributes branch)
1380   (:dependencies (reads :psr))
1381   (:delay 0)
1382   (:emitter
1383    (cond
1384      ((member :sparc-v9 *backend-subfeatures*)
1385       (unless cc
1386         (setf cc :icc))
1387       (emit-format-4-trap segment
1388                           #b10
1389                           (branch-condition condition)
1390                           #b111010 0 1
1391                           (integer-condition cc)
1392                           target))
1393      (t
1394       (aver (null cc))
1395       (emit-format-3-immed segment #b10 (branch-condition condition)
1396                            #b111010 0 1 target)))))
1397
1398 ;;; KLUDGE: we leave this commented out, as these two (T and TCC)
1399 ;;; operations are actually indistinguishable from their bitfields,
1400 ;;; breaking the disassembler if these are left in. The printer isn't
1401 ;;; terribly smart, but the emitted code is right. - CSR, 2002-08-04
1402 #+nil
1403 (define-instruction tcc (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
1404   (:declare (type branch-condition condition)
1405             ;; KLUDGE: see above.
1406             #!-linux
1407             (type (integer 16 31) target)
1408             (type integer-condition-register cc))
1409   (:printer format-4-trap ((op #b10)
1410                             (rd nil :type 'branch-condition)
1411                             (op3 #b111010)
1412                             (rs1 0))
1413             trap-printer)
1414   (:attributes branch)
1415   (:dependencies (reads :psr))
1416   (:delay 0)
1417   (:emitter (emit-format-4-trap segment
1418                                 #b10
1419                                 (branch-condition condition)
1420                                 #b111010 0 1
1421                                 (integer-condition cc)
1422                                 target)))
1423
1424 ;; Same as for the branch instructions.  On the Sparc V9, we will use
1425 ;; the FP branch with prediction instructions instead.
1426
1427 (define-instruction fb (segment condition target &rest args)
1428   (:declare (type fp-branch-condition condition) (type label target))
1429   (:printer format-2-branch ((op #B00)
1430                              (cond nil :type 'branch-fp-condition)
1431                              (op2 #b110)))
1432   (:attributes branch)
1433   (:dependencies (reads :fsr))
1434   (:delay 1)
1435   (:emitter
1436    (cond
1437      ((member :sparc-v9 *backend-subfeatures*)
1438       (destructuring-bind (&optional fcc pred) args
1439         (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
1440      (t
1441       (aver (null args))
1442       (emit-relative-branch segment 0 #b110 condition target t)))))
1443
1444 (define-instruction fbp (segment condition target &optional fcc pred)
1445   (:declare (type fp-branch-condition condition) (type label target))
1446   (:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
1447             fp-branch-pred-printer
1448             :print-name 'fbp)
1449   (:attributes branch)
1450   (:dependencies (reads :fsr))
1451   (:delay 1)
1452   (:emitter
1453    (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
1454
1455 (defconstant-eqx jal-printer
1456   '(:name :tab
1457           (:choose (rs1 (:unless (:constant 0) (:plus-integer immed)))
1458                    (:cond ((rs2 :constant 0) rs1)
1459                           ((rs1 :constant 0) rs2)
1460                           (t rs1 "+" rs2)))
1461           (:unless (:constant 0) ", " rd))
1462   #'equalp)
1463
1464 (define-instruction jal (segment dst src1 &optional src2)
1465   (:declare (type tn dst)
1466             (type (or tn integer) src1)
1467             (type (or null fixup tn (signed-byte 13)) src2))
1468   (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer)
1469   (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
1470   (:attributes branch)
1471   (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
1472   (:delay 1)
1473   (:emitter
1474    (unless src2
1475      (setf src2 src1)
1476      (setf src1 0))
1477    (etypecase src2
1478      (tn
1479       (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
1480                          (if (integerp src1)
1481                              src1
1482                              (reg-tn-encoding src1))
1483                          0 0 (reg-tn-encoding src2)))
1484      (integer
1485       (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
1486                            (reg-tn-encoding src1) 1 src2))
1487      (fixup
1488       (note-fixup segment :add src2)
1489       (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
1490                            #b111000 (reg-tn-encoding src1) 1 0)))))
1491
1492 (define-instruction j (segment src1 &optional src2)
1493   (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
1494   (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
1495   (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
1496   (:attributes branch)
1497   (:dependencies (reads src1) (if src2 (reads src2)))
1498   (:delay 1)
1499   (:emitter
1500    (etypecase src2
1501      (null
1502       (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
1503      (tn
1504       (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
1505                          (reg-tn-encoding src2)))
1506      (integer
1507       (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
1508                            src2))
1509      (fixup
1510       (note-fixup segment :add src2)
1511       (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
1512                            0)))))
1513
1514
1515 \f
1516 ;;;; Unary and binary fp insts.
1517
1518 (macrolet ((define-unary-fp-inst (name opf &key reads extended)
1519   `(define-instruction ,name (segment dst src)
1520      (:declare (type tn dst src))
1521      (:printer format-unary-fpop
1522        ((op #b10) (op3 #b110100) (opf ,opf)
1523         (rs1 0)
1524         (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1525         (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
1526      (:dependencies
1527       ,@(when reads
1528           `((reads ,reads)))
1529       (reads dst)
1530       (reads src)
1531       (writes dst))
1532      (:delay 0)
1533      (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
1534                 #b110100 0 ,opf (fp-reg-tn-encoding src)))))
1535
1536            (define-binary-fp-inst (name opf &key (op3 #b110100)
1537                                       reads writes delay extended)
1538   `(define-instruction ,name (segment dst src1 src2)
1539      (:declare (type tn dst src1 src2))
1540      (:printer format-binary-fpop
1541       ((op #b10) (op3 ,op3) (opf ,opf)
1542        (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1543        (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1544        (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1545        ))
1546      (:dependencies
1547       ,@(when reads
1548           `((reads ,reads)))
1549       (reads src1)
1550       (reads src2)
1551       ,@(when writes
1552           `((writes ,writes)))
1553       (writes dst))
1554      ,@(if delay
1555            `((:delay ,delay))
1556            '((:delay 0)))
1557      (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
1558                 ,op3 (fp-reg-tn-encoding src1) ,opf
1559                 (fp-reg-tn-encoding src2)))))
1560
1561            (define-cmp-fp-inst (name opf &key extended)
1562                (let ((opf0 #b0)
1563                      (opf1 #b010)
1564                      (opf2 #b1))
1565                  `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
1566                    (:declare (type tn src1 src2)
1567                     (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
1568        (:printer format-fpop2
1569                  ((op #b10)
1570                   (op3 #b110101)
1571                   (opf0 ,opf0)
1572                   (opf1 ,opf1)
1573                   (opf2 ,opf2)
1574                   (opf3 ,opf)
1575                   (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1576                   (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
1577                   #!-sparc-v9
1578                   (rd 0)
1579                   #!+sparc-v9
1580                   (rd nil :type 'fp-condition-register))
1581         )
1582      (:dependencies
1583       (reads src1)
1584       (reads src2)
1585       (writes :fsr))
1586      ;; The Sparc V9 doesn't need a delay after a FP compare.
1587      ;;
1588      ;; KLUDGE FIXME YAARGH -- how to express that? I guess for now we
1589      ;; do the worst case, and hope to fix it.
1590      ;; (:delay #-sparc-v9 1 #+sparc-v9 0)
1591      (:delay 1)
1592        (:emitter
1593         (emit-format-3-fpop2 segment #b10
1594                              (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
1595                                  0)
1596                              #b110101
1597                              (fp-reg-tn-encoding src1)
1598                              ,opf0 ,opf1 ,opf2 ,opf
1599                              (fp-reg-tn-encoding src2)))))))
1600
1601   (define-unary-fp-inst fitos #b011000100 :reads :fsr)
1602   (define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t)
1603   (define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t)      ; v8
1604
1605   (define-unary-fp-inst fxtos #b010000100 :reads :fsr)                    ; v9
1606   (define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t)        ; v9
1607   (define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t)      ; v9
1608
1609
1610   ;; I (Raymond Toy) don't think these f{sd}toir instructions exist on
1611   ;; any Ultrasparc, but I only have a V9 manual. The code in
1612   ;; float.lisp seems to indicate that they only existed on non-sun4
1613   ;; machines (sun3 68K machines?).
1614   (define-unary-fp-inst fstoir #b011000001 :reads :fsr)
1615   (define-unary-fp-inst fdtoir #b011000010 :reads :fsr)
1616
1617   (define-unary-fp-inst fstoi #b011010001)
1618   (define-unary-fp-inst fdtoi #b011010010 :extended t)
1619   (define-unary-fp-inst fqtoi #b011010011 :extended t)  ; v8
1620
1621   (define-unary-fp-inst fstox #b010000001)                ; v9
1622   (define-unary-fp-inst fdtox #b010000010 :extended t)    ; v9
1623   (define-unary-fp-inst fqtox #b010000011 :extended t)  ; v9
1624
1625   (define-unary-fp-inst fstod #b011001001 :reads :fsr)
1626   (define-unary-fp-inst fstoq #b011001101 :reads :fsr)  ; v8
1627   (define-unary-fp-inst fdtos #b011000110 :reads :fsr)
1628   (define-unary-fp-inst fdtoq #b011001110 :reads :fsr)  ; v8
1629   (define-unary-fp-inst fqtos #b011000111 :reads :fsr)  ; v8
1630   (define-unary-fp-inst fqtod #b011001011 :reads :fsr)  ; v8
1631
1632   (define-unary-fp-inst fmovs #b000000001)
1633   (define-unary-fp-inst fmovd #b000000010 :extended t)  ; v9
1634   (define-unary-fp-inst fmovq #b000000011 :extended t)  ; v9
1635
1636   (define-unary-fp-inst fnegs #b000000101)
1637   (define-unary-fp-inst fnegd #b000000110 :extended t)  ; v9
1638   (define-unary-fp-inst fnegq #b000000111 :extended t)  ; v9
1639
1640   (define-unary-fp-inst fabss #b000001001)
1641   (define-unary-fp-inst fabsd #b000001010 :extended t)  ; v9
1642   (define-unary-fp-inst fabsq #b000001011 :extended t)  ; v9
1643
1644   (define-unary-fp-inst fsqrts #b000101001 :reads :fsr)         ; V7
1645   (define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t)     ; V7
1646   (define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t)     ; v8
1647
1648   (define-binary-fp-inst fadds #b001000001)
1649   (define-binary-fp-inst faddd #b001000010 :extended t)
1650   (define-binary-fp-inst faddq #b001000011 :extended t) ; v8
1651   (define-binary-fp-inst fsubs #b001000101)
1652   (define-binary-fp-inst fsubd #b001000110 :extended t)
1653   (define-binary-fp-inst fsubq #b001000111 :extended t) ; v8
1654
1655   (define-binary-fp-inst fmuls #b001001001)
1656   (define-binary-fp-inst fmuld #b001001010 :extended t)
1657   (define-binary-fp-inst fmulq #b001001011 :extended t) ; v8
1658   (define-binary-fp-inst fdivs #b001001101)
1659   (define-binary-fp-inst fdivd #b001001110 :extended t)
1660   (define-binary-fp-inst fdivq #b001001111 :extended t) ; v8
1661
1662 ;;; Float comparison instructions.
1663 ;;;
1664   (define-cmp-fp-inst fcmps #b0001)
1665   (define-cmp-fp-inst fcmpd #b0010 :extended t)
1666   (define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8
1667   (define-cmp-fp-inst fcmpes #b0101)
1668   (define-cmp-fp-inst fcmped #b0110 :extended t)
1669   (define-cmp-fp-inst fcmpeq #b0111 :extended t)        ; v8
1670
1671 ) ; MACROLET
1672 \f
1673 ;;;; li, jali, ji, nop, cmp, not, neg, move, and more
1674
1675 (defun %li (reg value)
1676   (etypecase value
1677     ((signed-byte 13)
1678      (inst add reg zero-tn value))
1679     ((or (signed-byte 32) (unsigned-byte 32))
1680      (let ((hi (ldb (byte 22 10) value))
1681            (lo (ldb (byte 10 0) value)))
1682        (inst sethi reg hi)
1683        (unless (zerop lo)
1684          (inst add reg lo))))
1685     (fixup
1686      (inst sethi reg value)
1687      (inst add reg value))))
1688
1689 (define-instruction-macro li (reg value)
1690   `(%li ,reg ,value))
1691
1692 ;;; Jal to a full 32-bit address.  Tmpreg is trashed.
1693 (define-instruction jali (segment link tmpreg value)
1694   (:declare (type tn link tmpreg)
1695             (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
1696                       fixup) value))
1697   (:attributes variable-length)
1698   (:vop-var vop)
1699   (:attributes branch)
1700   (:dependencies (writes link) (writes tmpreg))
1701   (:delay 1)
1702   (:emitter
1703    (assemble (segment vop)
1704      (etypecase value
1705        ((signed-byte 13)
1706         (inst jal link zero-tn value))
1707        ((or (signed-byte 32) (unsigned-byte 32))
1708         (let ((hi (ldb (byte 22 10) value))
1709               (lo (ldb (byte 10 0) value)))
1710           (inst sethi tmpreg hi)
1711           (inst jal link tmpreg lo)))
1712        (fixup
1713         (inst sethi tmpreg value)
1714         (inst jal link tmpreg value))))))
1715
1716 ;;; Jump to a full 32-bit address.  Tmpreg is trashed.
1717 (define-instruction ji (segment tmpreg value)
1718   (:declare (type tn tmpreg)
1719             (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
1720                       fixup) value))
1721   (:attributes variable-length)
1722   (:vop-var vop)
1723   (:attributes branch)
1724   (:dependencies (writes tmpreg))
1725   (:delay 1)
1726   (:emitter
1727    (assemble (segment vop)
1728              (inst jali zero-tn tmpreg value))))
1729
1730 (define-instruction nop (segment)
1731   (:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name))
1732   (:attributes flushable)
1733   (:delay 0)
1734   (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
1735
1736 (defun emit-nop (segment)
1737   (emit-format-2-immed segment 0 0 #b100 0))
1738
1739 (define-instruction cmp (segment src1 &optional src2)
1740   (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
1741   (:printer format-3-reg ((op #b10) (op3 #b010100) (rd 0))
1742             '(:name :tab rs1 ", " rs2))
1743   (:printer format-3-immed ((op #b10) (op3 #b010100) (rd 0))
1744             '(:name :tab rs1 ", " immed))
1745   (:dependencies (reads src1) (if src2 (reads src2)) (writes :psr))
1746   (:delay 0)
1747   (:emitter
1748    (etypecase src2
1749      (null
1750       (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
1751      (tn
1752       (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
1753                          (reg-tn-encoding src2)))
1754      (integer
1755       (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
1756                            src2)))))
1757
1758 (define-instruction not (segment dst &optional src1)
1759   (:declare (type tn dst) (type (or tn null) src1))
1760   (:printer format-3-reg ((op #b10) (op3 #b000111) (rs2 0))
1761             '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd))
1762   (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
1763   (:delay 0)
1764   (:emitter
1765    (unless src1
1766      (setf src1 dst))
1767    (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
1768                       (reg-tn-encoding src1) 0 0 0)))
1769
1770 (define-instruction neg (segment dst &optional src1)
1771   (:declare (type tn dst) (type (or tn null) src1))
1772   (:printer format-3-reg ((op #b10) (op3 #b000100) (rs1 0))
1773             '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd))
1774   (:dependencies (if src1 (reads src1) (reads dst)) (writes dst))
1775   (:delay 0)
1776   (:emitter
1777    (unless src1
1778      (setf src1 dst))
1779    (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
1780                       0 0 0 (reg-tn-encoding src1))))
1781
1782 (define-instruction move (segment dst src1)
1783   (:declare (type tn dst src1))
1784   (:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0))
1785             '(:name :tab rs2 ", " rd)
1786             :print-name 'mov)
1787   (:attributes flushable)
1788   (:dependencies (reads src1) (writes dst))
1789   (:delay 0)
1790   (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
1791                                0 0 0 (reg-tn-encoding src1))))
1792
1793
1794 \f
1795 ;;;; Instructions for dumping data and header objects.
1796
1797 (define-instruction word (segment word)
1798   (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
1799   :pinned
1800   (:delay 0)
1801   (:emitter
1802    (emit-word segment word)))
1803
1804 (define-instruction short (segment short)
1805   (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
1806   :pinned
1807   (:delay 0)
1808   (:emitter
1809    (emit-short segment short)))
1810
1811 (define-instruction byte (segment byte)
1812   (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
1813   :pinned
1814   (:delay 0)
1815   (:emitter
1816    (emit-byte segment byte)))
1817
1818 (define-bitfield-emitter emit-header-object 32
1819   (byte 24 8) (byte 8 0))
1820
1821 (defun emit-header-data (segment type)
1822   (emit-back-patch
1823    segment 4
1824    (lambda (segment posn)
1825        (emit-word segment
1826                   (logior type
1827                           (ash (+ posn (component-header-length))
1828                                (- n-widetag-bits word-shift)))))))
1829
1830 (define-instruction simple-fun-header-word (segment)
1831   :pinned
1832   (:delay 0)
1833   (:emitter
1834    (emit-header-data segment simple-fun-header-widetag)))
1835
1836 (define-instruction lra-header-word (segment)
1837   :pinned
1838   (:delay 0)
1839   (:emitter
1840    (emit-header-data segment return-pc-header-widetag)))
1841
1842 \f
1843 ;;;; Instructions for converting between code objects, functions, and lras.
1844
1845 (defun emit-compute-inst (segment vop dst src label temp calc)
1846   (emit-chooser
1847    ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
1848    segment 12 3
1849    (lambda (segment posn delta-if-after)
1850        (let ((delta (funcall calc label posn delta-if-after)))
1851          (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
1852            (emit-back-patch segment 4
1853                             (lambda (segment posn)
1854                                 (assemble (segment vop)
1855                                           (inst add dst src
1856                                                 (funcall calc label posn 0)))))
1857            t)))
1858    (lambda (segment posn)
1859        (let ((delta (funcall calc label posn 0)))
1860          (assemble (segment vop)
1861                    (inst sethi temp (ldb (byte 22 10) delta))
1862                    (inst or temp (ldb (byte 10 0) delta))
1863                    (inst add dst src temp))))))
1864
1865 ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
1866 (define-instruction compute-code-from-fn (segment dst src label temp)
1867   (:declare (type tn dst src temp) (type label label))
1868   (:attributes variable-length)
1869   (:dependencies (reads src) (writes dst) (writes temp))
1870   (:delay 0)
1871   (:vop-var vop)
1872   (:emitter
1873    (emit-compute-inst segment vop dst src label temp
1874                       (lambda (label posn delta-if-after)
1875                           (- other-pointer-lowtag
1876                              fun-pointer-lowtag
1877                              (label-position label posn delta-if-after)
1878                              (component-header-length))))))
1879
1880 ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
1881 ;;      = lra - (header + label-offset)
1882 (define-instruction compute-code-from-lra (segment dst src label temp)
1883   (:declare (type tn dst src temp) (type label label))
1884   (:attributes variable-length)
1885   (:dependencies (reads src) (writes dst) (writes temp))
1886   (:delay 0)
1887   (:vop-var vop)
1888   (:emitter
1889    (emit-compute-inst segment vop dst src label temp
1890                       (lambda (label posn delta-if-after)
1891                           (- (+ (label-position label posn delta-if-after)
1892                                 (component-header-length)))))))
1893
1894 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
1895 ;;     = code + header + label-offset
1896 (define-instruction compute-lra-from-code (segment dst src label temp)
1897   (:declare (type tn dst src temp) (type label label))
1898   (:attributes variable-length)
1899   (:dependencies (reads src) (writes dst) (writes temp))
1900   (:delay 0)
1901   (:vop-var vop)
1902   (:emitter
1903    (emit-compute-inst segment vop dst src label temp
1904                       (lambda (label posn delta-if-after)
1905                           (+ (label-position label posn delta-if-after)
1906                              (component-header-length))))))
1907 \f
1908 ;;; Sparc V9 additions
1909
1910
1911
1912 ;; Conditional move integer on condition code
1913 (define-instruction cmove (segment condition dst src &optional (ccreg :icc))
1914   (:declare (type (or branch-condition fp-branch-condition) condition)
1915             (type cond-move-condition-register ccreg)
1916             (type tn dst)
1917             (type (or (signed-byte 13) tn) src))
1918   (:printer format-4-cond-move
1919             ((op #b10)
1920              (op3 #b101100)
1921              (cc2 #b1)
1922              (i 0)
1923              (cc nil :type 'integer-condition-register))
1924              cond-move-printer
1925              :print-name 'mov)
1926   (:printer format-4-cond-move-immed
1927             ((op #b10)
1928              (op3 #b101100)
1929              (cc2 #b1)
1930              (i 1)
1931              (cc nil :type 'integer-condition-register))
1932              cond-move-printer
1933              :print-name 'mov)
1934   (:printer format-4-cond-move
1935             ((op #b10)
1936              (op3 #b101100)
1937              (cc2 #b0)
1938              (cond nil :type 'branch-fp-condition)
1939              (i 0)
1940              (cc nil :type 'fp-condition-register))
1941              cond-move-printer
1942              :print-name 'mov)
1943   (:printer format-4-cond-move-immed
1944             ((op #b10)
1945              (op3 #b101100)
1946              (cc2 #b0)
1947              (cond nil :type 'branch-fp-condition)
1948              (i 1)
1949              (cc nil :type 'fp-condition-register))
1950              cond-move-printer
1951              :print-name 'mov)
1952   (:delay 0)
1953   (:dependencies
1954    (if (member ccreg '(:icc :xcc))
1955        (reads :psr)
1956        (reads :fsr))
1957    (reads src)
1958    (reads dst)
1959    (writes dst))
1960   (:emitter
1961    (let ((op #b10)
1962          (op3 #b101100))
1963      (multiple-value-bind (cc2 cc01)
1964          (cond-move-condition-parts ccreg)
1965        (etypecase src
1966          (tn
1967           (emit-format-4-cond-move segment
1968                                    op
1969                                    (reg-tn-encoding dst)
1970                                    op3
1971                                    cc2
1972                                    (if (member ccreg '(:icc :xcc))
1973                                        (branch-condition condition)
1974                                        (fp-branch-condition condition))
1975                                    0
1976                                    cc01
1977                                    (reg-tn-encoding src)))
1978          (integer
1979           (emit-format-4-cond-move segment
1980                                    op
1981                                    (reg-tn-encoding dst)
1982                                    op3
1983                                    cc2
1984                                    (if (member ccreg '(:icc :xcc))
1985                                        (branch-condition condition)
1986                                        (fp-branch-condition condition))
1987                                    1
1988                                    cc01
1989                                    src)))))))
1990
1991 ;; Conditional move floating-point on condition codes
1992 (macrolet ((define-cond-fp-move (name print-name op op3 opf_low &key extended)
1993   `(define-instruction ,name (segment condition dst src &optional (ccreg :fcc0))
1994      (:declare (type (or branch-condition fp-branch-condition) condition)
1995                (type cond-move-condition-register ccreg)
1996                (type tn dst src))
1997      (:printer format-fpop2
1998                ((op ,op)
1999                 (op3 ,op3)
2000                 (opf0 0)
2001                 (opf1 nil :type 'fp-condition-register-shifted)
2002                 (opf2 0)
2003                 (opf3 ,opf_low)
2004                 (rs1 nil :type 'branch-fp-condition)
2005                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2006                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
2007                 cond-fp-move-printer
2008                 :print-name ',print-name)
2009      (:printer format-fpop2
2010                ((op ,op)
2011                 (op3 ,op3)
2012                 (opf0 1)
2013                 (opf1 nil :type 'integer-condition-register)
2014                 (opf2 0)
2015                 (rs1 nil :type 'branch-condition)
2016                 (opf3 ,opf_low)
2017                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2018                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
2019                cond-fp-move-printer
2020                :print-name ',print-name)
2021      (:delay 0)
2022      (:dependencies
2023       (if (member ccreg '(:icc :xcc))
2024           (reads :psr)
2025           (reads :fsr))
2026       (reads src)
2027       (reads dst)
2028       (writes dst))
2029      (:emitter
2030       (multiple-value-bind (opf_cc2 opf_cc01)
2031           (cond-move-condition-parts ccreg)
2032         (emit-format-3-fpop2 segment
2033                              ,op
2034                              (fp-reg-tn-encoding dst)
2035                              ,op3
2036                              (if (member ccreg '(:icc :xcc))
2037                                  (branch-condition condition)
2038                                  (fp-branch-condition condition))
2039                              opf_cc2
2040                              (ash opf_cc01 1)
2041                              0
2042                              ,opf_low
2043                              (fp-reg-tn-encoding src)))))))
2044   (define-cond-fp-move cfmovs fmovs #b10 #b110101 #b0001)
2045   (define-cond-fp-move cfmovd fmovd #b10 #b110101 #b0010 :extended t)
2046   (define-cond-fp-move cfmovq fmovq #b10 #b110101 #b0011 :extended t))
2047
2048
2049 ;; Move on integer register condition
2050 ;;
2051 ;; movr dst src reg reg-cond
2052 ;;
2053 ;; This means if reg satisfies reg-cond, src is copied to dst.  If the
2054 ;; condition is not satisfied, nothing is done.
2055 ;;
2056 (define-instruction movr (segment dst src2 src1 reg-condition)
2057   (:declare (type cond-move-integer-condition reg-condition)
2058             (type tn dst src1)
2059             (type (or (signed-byte 10) tn) src2))
2060   (:printer format-4-cond-move-integer
2061             ((op #b10)
2062              (op3 #b101111)
2063              (i 0)))
2064   (:printer format-4-cond-move-integer-immed
2065             ((op #b10)
2066              (op3 #b101111)
2067              (i 1)))
2068   (:delay 0)
2069   (:dependencies
2070    (reads :psr)
2071    (reads src2)
2072    (reads src1)
2073    (reads dst)
2074    (writes dst))
2075   (:emitter
2076    (etypecase src2
2077      (tn
2078       (emit-format-4-cond-move-integer
2079        segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
2080        0 (register-condition reg-condition)
2081        0 (reg-tn-encoding src2)))
2082      (integer
2083       (emit-format-4-cond-move-integer-immed
2084        segment #b10 (reg-tn-encoding dst) #b101111 (reg-tn-encoding src1)
2085        1 (register-condition reg-condition) src2)))))
2086
2087
2088 ;; Same as MOVR, except we move FP registers depending on the value of
2089 ;; an integer register.
2090 ;;
2091 ;; fmovr dst src reg cond
2092 ;;
2093 ;; This means if REG satifies COND, SRC is COPIED to DST.  Nothing
2094 ;; happens if the condition is not satisfied.
2095 (macrolet ((define-cond-fp-move-integer (name opf_low &key extended)
2096   `(define-instruction ,name (segment dst src2 src1 reg-condition)
2097      (:declare (type cond-move-integer-condition reg-condition)
2098                (type tn dst src1 src2))
2099      (:printer format-fpop2
2100                ((op #b10)
2101                 (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2102                 (op3 #b110101)
2103                 (rs1 nil :type 'reg)
2104                 (opf0 0)
2105                 (opf1 nil :type 'register-condition)
2106                 (opf2 0)
2107                 (opf3 ,opf_low)
2108                 (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
2109                 )
2110                cond-fp-move-integer-printer)
2111      (:delay 0)
2112      (:dependencies
2113       (reads src2)
2114       (reads src1)
2115       (reads dst)
2116       (writes dst))
2117      (:emitter
2118       (emit-format-3-fpop2
2119        segment
2120        #b10
2121        (fp-reg-tn-encoding dst)
2122        #b110101
2123        (reg-tn-encoding src1)
2124        0
2125        (register-condition reg-condition)
2126        0
2127        ,opf_low
2128        (fp-reg-tn-encoding src2))))))
2129   (define-cond-fp-move-integer fmovrs #b0101)
2130   (define-cond-fp-move-integer fmovrd #b0110 :extended t)
2131   (define-cond-fp-move-integer fmovrq #b0111 :extended t))