insts.lisp

开源跨平台Lisp编译器

  (define-f3-inst orncc #b10 #b010110 :writes :psr)
  (define-f3-inst xor #b10 #b000011)
  (define-f3-inst xorcc #b10 #b010011 :writes :psr)
  (define-f3-inst xnor #b10 #b000111)
  (define-f3-inst xnorcc #b10 #b010111 :writes :psr)

  (define-f3-shift-inst sll #b10 #b100101)
  (define-f3-shift-inst srl #b10 #b100110)
  (define-f3-shift-inst sra #b10 #b100111)
  (define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9
  (define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9
  (define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9

  (define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
  (define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)

  ;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are
  ;; deprecated on the Sparc V9.  Use mulx, sdivx, and udivx instead.
  (define-f3-inst smul #b10 #b001011 :writes :y)                        ; v8
  (define-f3-inst smulcc #b10 #b011011 :writes (:psr :y))               ; v8
  (define-f3-inst umul #b10 #b001010 :writes :y)                        ; v8
  (define-f3-inst umulcc #b10 #b011010 :writes (:psr :y))               ; v8
  (define-f3-inst sdiv #b10 #b001111 :reads :y)                 ; v8
  (define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr)  ; v8
  (define-f3-inst udiv #b10 #b001110 :reads :y)                 ; v8
  (define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr)  ; v8

  (define-f3-inst mulx #b10 #b001001)   ; v9 for both signed and unsigned
  (define-f3-inst sdivx #b10 #b101101)  ; v9
  (define-f3-inst udivx #b10 #b001101)  ; v9

  (define-f3-inst popc #b10 #b101110)   ; v9: count one bits

) ; MACROLET


;;;; Random instructions.

;; ldfsr is deprecated on the Sparc V9.  Use ldxfsr instead
(define-instruction ldfsr (segment src1 src2)
  (:declare (type tn src1) (type (signed-byte 13) src2))
  (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 0)))
  :pinned
  (:delay 0)
  (:emitter (emit-format-3-immed segment #b11 0 #b100001
                                 (reg-tn-encoding src1) 1 src2)))

#!+sparc-64
(define-instruction ldxfsr (segment src1 src2)
  (:declare (type tn src1) (type (signed-byte 13) src2))
  (:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1))
            '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
            :print-name 'ldx)
  :pinned
  (:delay 0)
  (:emitter (emit-format-3-immed segment #b11 1 #b100001
                                 (reg-tn-encoding src1) 1 src2)))

;; stfsr is deprecated on the Sparc V9.  Use stxfsr instead.
(define-instruction stfsr (segment src1 src2)
  (:declare (type tn src1) (type (signed-byte 13) src2))
  (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0)))
  :pinned
  (:delay 0)
  (:emitter (emit-format-3-immed segment #b11 0 #b100101
                                 (reg-tn-encoding src1) 1 src2)))

#!+sparc-64
(define-instruction stxfsr (segment src1 src2)
  (:declare (type tn src1) (type (signed-byte 13) src2))
  (:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1))
            '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
            :print-name 'stx)
  :pinned
  (:delay 0)
  (:emitter (emit-format-3-immed segment #b11 1 #b100101
                                 (reg-tn-encoding src1) 1 src2)))

(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  (defun sethi-arg-printer (value stream dstate)
    (format stream "%hi(#x~8,'0x)" (ash value 10))
    ;; Save the immediate value and the destination register from this
    ;; sethi instruction.  This is used later to print some possible
    ;; notes about the value loaded by sethi.
    (let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
                                           (sb!disassem::dstate-cur-offs dstate)
                                           n-word-bytes
                                           (sb!disassem::dstate-byte-order dstate)))
           (imm22 (ldb (byte 22 0) word))
           (rd (ldb (byte 5 25) word)))
      (push (cons rd imm22) *note-sethi-inst*)))
) ; EVAL-WHEN


(define-instruction sethi (segment dst src1)
  (:declare (type tn dst)
            (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
  (:printer format-2-immed
            ((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
  (:dependencies (writes dst))
  (:delay 0)
  (:emitter
   (etypecase src1
     (integer
      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
                                 src1))
     (fixup
      (note-fixup segment :sethi src1)
      (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))

;; rdy is deprecated on the Sparc V9.  It's not needed with 64-bit
;; registers.
(define-instruction rdy (segment dst)
  (:declare (type tn dst))
  (:printer format-3-reg ((op #b10) (op3 #b101000) (rs1 0) (immed 0))
            '('RD :tab '%Y ", " rd))
  (:dependencies (reads :y) (writes dst))
  (:delay 0)
  (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b101000
                               0 0 0 0)))

(defconstant-eqx wry-printer
  '('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
  #'equalp)

;; wry is deprecated on the Sparc V9.  It's not needed with 64-bit
;; registers.
(define-instruction wry (segment src1 &optional src2)
  (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
  (:printer format-3-reg ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
  (:printer format-3-immed ((op #b10) (op3 #b110000) (rd 0)) wry-printer)
  (:dependencies (reads src1) (if src2 (reads src2)) (writes :y))
  (:delay 3)
  (:emitter
   (etypecase src2
     (null
      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
     (tn
      (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
                         (reg-tn-encoding src2)))
     (integer
      (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
                           src2)))))

(defun snarf-error-junk (sap offset &optional length-only)
  (let* ((length (sb!sys:sap-ref-8 sap offset))
         (vector (make-array length :element-type '(unsigned-byte 8))))
    (declare (type sb!sys:system-area-pointer sap)
             (type (unsigned-byte 8) length)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (cond (length-only
           (values 0 (1+ length) nil nil))
          (t
           (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
                                                vector 0 length)
           (collect ((sc-offsets)
                     (lengths))
             (lengths 1)                ; the length byte
             (let* ((index 0)
                    (error-number (sb!c:read-var-integer vector index)))
               (lengths index)
               (loop
                 (when (>= index length)
                   (return))
                 (let ((old-index index))
                   (sc-offsets (sb!c:read-var-integer vector index))
                   (lengths (- index old-index))))
               (values error-number
                       (1+ length)
                       (sc-offsets)
                       (lengths))))))))

(defun unimp-control (chunk inst stream dstate)
  (declare (ignore inst))
  (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
    (case (format-2-unimp-data chunk dstate)
      (#.error-trap
       (nt "Error trap")
       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
      (#.cerror-trap
       (nt "Cerror trap")
       (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
      (#.object-not-list-trap
       (nt "Object not list trap"))
      (#.breakpoint-trap
       (nt "Breakpoint trap"))
      (#.pending-interrupt-trap
       (nt "Pending interrupt trap"))
      (#.halt-trap
       (nt "Halt trap"))
      (#.fun-end-breakpoint-trap
       (nt "Function end breakpoint trap"))
      (#.object-not-instance-trap
       (nt "Object not instance trap"))
    )))

(define-instruction unimp (segment data)
  (:declare (type (unsigned-byte 22) data))
  (:printer format-2-unimp () :default :control #'unimp-control
            :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
  (:delay 0)
  (:emitter (emit-format-2-unimp segment 0 0 0 data)))



;;;; Branch instructions.

;; The branch instruction is deprecated on the Sparc V9.  Use the
;; branch with prediction instructions instead.
(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
  (emit-back-patch segment 4
    (lambda (segment posn)
        (unless target
          (setf target cond-or-target)
          (setf cond-or-target :t))
        (emit-format-2-branch
          segment #b00 a
          (if fp
              (fp-branch-condition cond-or-target)
              (branch-condition cond-or-target))
          op2
          (let ((offset (ash (- (label-position target) posn) -2)))
            (when (and (= a 1) (> 0 offset))
              (error "Offset of BA must be positive"))
            offset)))))

(defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
  (declare (type integer-condition-register cc))
  (aver (member :sparc-v9 *backend-subfeatures*))
  (emit-back-patch segment 4
    (lambda (segment posn)
        (unless target
          (setf target cond-or-target)
          (setf cond-or-target :t))
        (emit-format-2-branch-pred
          segment #b00 a
          (branch-condition cond-or-target)
          op2
          (integer-condition cc)
          (branch-prediction pred)
          (let ((offset (ash (- (label-position target) posn) -2)))
            (when (and (= a 1) (> 0 offset))
              (error "Offset of BA must be positive"))
            offset)))))

(defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
  (aver (member :sparc-v9 *backend-subfeatures*))
  (emit-back-patch segment 4
    (lambda (segment posn)
        (unless target
          (setf target cond-or-target)
          (setf cond-or-target :t))
        (emit-format-2-branch-pred
          segment #b00 a
          (fp-branch-condition cond-or-target)
          op2
          (fp-condition cc)
          (branch-prediction pred)
          (let ((offset (ash (- (label-position target) posn) -2)))
            (when (and (= a 1) (> 0 offset))
              (error "Offset of BA must be positive"))
            offset)))))

;; So that I don't have to go change the syntax of every single use of
;; branches, I'm keeping the Lisp instruction names the same.  They
;; just get translated to the branch with prediction
;; instructions. However, the disassembler uses the correct V9
;; mnemonic.
(define-instruction b (segment cond-or-target &rest args)
  (:declare (type (or label branch-condition) cond-or-target))
  (:printer format-2-branch ((op #b00) (op2 #b010)))
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 1)
  (:emitter
   (cond
     ((member :sparc-v9 *backend-subfeatures*)
      (destructuring-bind (&optional target pred cc) args
        (declare (type (or label null) target))
        (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
     (t
      (destructuring-bind (&optional target) args
        (declare (type (or label null) target))
        (emit-relative-branch segment 0 #b010 cond-or-target target))))))

(define-instruction bp (segment cond-or-target &optional target pred cc)
  (:declare (type (or label branch-condition) cond-or-target)
            (type (or label null) target))
  (:printer format-2-branch-pred ((op #b00) (op2 #b001))
            branch-pred-printer
            :print-name 'bp)
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 1)
  (:emitter
   (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))

(define-instruction ba (segment cond-or-target &rest args)
  (:declare (type (or label branch-condition) cond-or-target))
  (:printer format-2-branch ((op #b00) (op2 #b010) (a 1))
            nil
            :print-name 'b)
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 0)
  (:emitter
   (cond
     ((member :sparc-v9 *backend-subfeatures*)
      (destructuring-bind (&optional target pred cc) args
        (declare (type (or label null) target))
        (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
     (t
      (destructuring-bind (&optional target) args
        (declare (type (or label null) target))
        (emit-relative-branch segment 1 #b010 cond-or-target target))))))

(define-instruction bpa (segment cond-or-target &optional target pred cc)
  (:declare (type (or label branch-condition) cond-or-target)
            (type (or label null) target))
  (:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
            nil
            :print-name 'bp)
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 0)
  (:emitter
   (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))

;; This doesn't cover all of the possible formats for the trap
;; instruction.  We really only want a trap with a immediate trap
;; value and with RS1 = register 0.  Also, the Sparc Compliance
;; Definition 2.4.1 says only trap numbers 16-31 are allowed for user
;; code.  All other trap numbers have other uses.  The restriction on
;; target will prevent us from using bad trap numbers by mistake.

(define-instruction t (segment condition target &optional cc)
  (:declare (type branch-condition condition)
            ;; KLUDGE: see comments in vm.lisp regarding
            ;; pseudo-atomic-trap.
            #!-linux
            (type (integer 16 31) target))
  (:printer format-3-immed ((op #b10)
                            (rd nil :type 'branch-condition)
                            (op3 #b111010)