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