insts.lisp

开源跨平台Lisp编译器

                 (declare (stream stream) (fixnum value) (ignore dstate))
                 (let ((regname (aref cond-move-integer-condition-vec value)))
                   (princ regname stream))))

(defconstant-eqx cond-move-integer-printer
  `(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)
  #'equalp)

(defun register-condition (rcond)
  (or (position rcond cond-move-integer-conditions)
      (error "Unknown register condition:  ~S~%" rcond)))

(sb!disassem:define-instruction-format
    (format-4-cond-move-integer 32 :default-printer cond-move-integer-printer)
  (op    :field (byte 2 30))
  (rd    :field (byte 5 25) :type 'reg)
  (op3   :field (byte 6 19))
  (rs1   :field (byte 5 14) :type 'reg)
  (i     :field (byte 1 13) :value 0)
  (rcond :field (byte 3 10) :type 'register-condition)
  (opf   :field (byte 5 5))
  (rs2   :field (byte 5 0) :type 'reg))

(sb!disassem:define-instruction-format
    (format-4-cond-move-integer-immed 32 :default-printer cond-move-integer-printer)
  (op    :field (byte 2 30))
  (rd    :field (byte 5 25) :type 'reg)
  (op3   :field (byte 6 19))
  (rs1   :field (byte 5 14) :type 'reg)
  (i     :field (byte 1 13) :value 1)
  (rcond :field (byte 3 10) :type 'register-condition)
  (immed :field (byte 10 0) :sign-extend t))

(defconstant-eqx trap-printer
  `(:name rd :tab cc ", " immed)
  #'equalp)

(sb!disassem:define-instruction-format
    (format-4-trap 32 :default-printer trap-printer)
  (op    :field (byte 2 30))
  (rd    :field (byte 5 25) :type 'reg)
  (op3   :field (byte 6 19))
  (rs1   :field (byte 5 14) :type 'reg)
  (i     :field (byte 1 13) :value 1)
  (cc    :field (byte 2 11) :type 'integer-condition-register)
  (immed :field (byte 11 0) :sign-extend t))    ; usually sign extended


(defconstant-eqx cond-fp-move-integer-printer
  `(:name opf1 :tab rs1 ", " rs2 ", " rd)
  #'equalp)


;;;; Primitive emitters.

(define-bitfield-emitter emit-word 32
  (byte 32 0))

(define-bitfield-emitter emit-short 16
  (byte 16 0))

(define-bitfield-emitter emit-format-1 32
  (byte 2 30) (byte 30 0))

(define-bitfield-emitter emit-format-2-immed 32
  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))

(define-bitfield-emitter emit-format-2-branch 32
  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))

;; Integer and FP branches with prediction for V9
(define-bitfield-emitter emit-format-2-branch-pred 32
  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
(define-bitfield-emitter emit-format-2-fp-branch-pred 32
  (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))

(define-bitfield-emitter emit-format-2-unimp 32
  (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))

(define-bitfield-emitter emit-format-3-reg 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
  (byte 5 0))

(define-bitfield-emitter emit-format-3-immed 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))

(define-bitfield-emitter emit-format-3-fpop 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))

(define-bitfield-emitter emit-format-3-fpop2 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14)
  (byte 1 13) (byte 3 10) (byte 1 9) (byte 4 5)
  (byte 5 0))

;;; Shift instructions

(define-bitfield-emitter emit-format-3-shift-reg 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 7 5)
  (byte 5 0))

(define-bitfield-emitter emit-format-3-shift-immed 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 1 12) (byte 12 0))

;;; Conditional moves

;; Conditional move in condition code
(define-bitfield-emitter emit-format-4-cond-move 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 1 18) (byte 4 14) (byte 1 13) (byte 2 11)
  (byte 11 0))

;; Conditional move on integer condition
(define-bitfield-emitter emit-format-4-cond-move-integer 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10) (byte 5 5)
  (byte 5 0))

(define-bitfield-emitter emit-format-4-cond-move-integer-immed 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 3 10)
  (byte 10 0))

(define-bitfield-emitter emit-format-4-trap 32
  (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11)
  (byte 11 0))


;;;; Most of the format-3-instructions.

(defun emit-format-3-inst (segment op op3 dst src1 src2
                                   &key load-store fixup dest-kind)
  (unless src2
    (cond ((and (typep src1 'tn) load-store)
           (setf src2 0))
          (t
           (setf src2 src1)
           (setf src1 dst))))
  (etypecase src2
    (tn
     (emit-format-3-reg segment op
                        (if dest-kind
                            (fp-reg-tn-encoding dst)
                            (reg-tn-encoding dst))
                        op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
    (integer
     (emit-format-3-immed segment op
                          (if dest-kind
                              (fp-reg-tn-encoding dst)
                              (reg-tn-encoding dst))
                          op3 (reg-tn-encoding src1) 1 src2))
    (fixup
     (unless (or load-store fixup)
       (error "Fixups aren't allowed."))
     (note-fixup segment :add src2)
     (emit-format-3-immed segment op
                          (if dest-kind
                              (fp-reg-tn-encoding dst)
                              (reg-tn-encoding dst))
                          op3 (reg-tn-encoding src1) 1 0))))

;;; Shift instructions because an extra bit is used in Sparc V9's to
;;; indicate whether the shift is a 32-bit or 64-bit shift.
;;;
(defun emit-format-3-shift-inst (segment op op3 dst src1 src2 &key extended)
  (unless src2
    (setf src2 src1)
    (setf src1 dst))
  (etypecase src2
    (tn
     (emit-format-3-shift-reg segment op (reg-tn-encoding dst)
                              op3 (reg-tn-encoding src1) 0 (if extended 1 0)
                              0 (reg-tn-encoding src2)))
    (integer
     (emit-format-3-shift-immed segment op (reg-tn-encoding dst)
                                op3 (reg-tn-encoding src1) 1
                                (if extended 1 0) src2))))


(eval-when (:compile-toplevel :execute)

;;; have to do this because def!constant is evalutated in the null lex env.
(defmacro with-ref-format (printer)
  `(let* ((addend
           '(:choose (:plus-integer immed) ("+" rs2)))
          (ref-format
           `("[" rs1 (:unless (:constant 0) ,addend) "]"
             (:choose (:unless (:constant 0) asi) nil))))
     ,printer))

(defconstant-eqx load-printer
  (with-ref-format `(:NAME :TAB ,ref-format ", " rd))
  #'equalp)

(defconstant-eqx store-printer
  (with-ref-format `(:NAME :TAB rd ", " ,ref-format))
  #'equalp)

) ; EVAL-WHEN

(macrolet ((define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
                                 (printer :default) reads writes flushable print-name)
  (let ((printer
         (if (eq printer :default)
             (case load-store
               ((nil) :default)
               ((:load t) 'load-printer)
               (:store 'store-printer))
             printer)))
    (when (and (atom reads) (not (null reads)))
      (setf reads (list reads)))
    (when (and (atom writes) (not (null writes)))
       (setf writes (list writes)))
    `(define-instruction ,name (segment dst src1 &optional src2)
       (:declare (type tn dst)
                 ,(if (or fixup load-store)
                      '(type (or tn (signed-byte 13) null fixup) src1 src2)
                      '(type (or tn (signed-byte 13) null) src1 src2)))
       (:printer format-3-reg
                 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
                 ,printer
                 ,@(when print-name `(:print-name ,print-name)))
       (:printer format-3-immed
                 ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
                 ,printer
                 ,@(when print-name `(:print-name ,print-name)))
       ,@(when flushable
           '((:attributes flushable)))
       (:dependencies
        (reads src1)
        ,@(let ((reads-list nil))
            (dolist (read reads)
              (push (list 'reads read) reads-list))
            reads-list)
        ,@(cond ((eq load-store :store)
                 '((reads dst)
                   (if src2 (reads src2))))
                 ((eq load-store t)
                  '((reads :memory)
                    (reads dst)
                    (if src2 (reads src2))))
                ((eq load-store :load)
                 '((reads :memory)
                   (if src2 (reads src2) (reads dst))))
                (t
                 '((if src2 (reads src2) (reads dst)))))
        ,@(let ((writes-list nil))
            (dolist (write writes)
              (push (list 'writes write) writes-list))
            writes-list)
        ,@(cond ((eq load-store :store)
                 '((writes :memory :partially t)))
                ((eq load-store t)
                 '((writes :memory :partially t)
                   (writes dst)))
                ((eq load-store :load)
                 '((writes dst)))
                (t
                 '((writes dst)))))
       (:delay 0)
       (:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
                                     :load-store ,load-store
                                     :fixup ,fixup
                                     :dest-kind (not (eq ',dest-kind 'reg)))))))

           (define-f3-shift-inst (name op op3 &key extended)
               `(define-instruction ,name (segment dst src1 &optional src2)
                 (:declare (type tn dst)
                  (type (or tn (unsigned-byte 6) null) src1 src2))
                 (:printer format-3-shift-reg
                  ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
                 (:printer format-3-shift-immed
                  ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
                 (:dependencies
                  (reads src1)
                  (if src2 (reads src2) (reads dst))
                  (writes dst))
                 (:delay 0)
                 (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
                            :extended ,extended)))))

  (define-f3-inst ldsb #b11 #b001001 :load-store :load)
  (define-f3-inst ldsh #b11 #b001010 :load-store :load)
  (define-f3-inst ldub #b11 #b000001 :load-store :load)
  (define-f3-inst lduh #b11 #b000010 :load-store :load)

  ;; This instruction is called lduw for V9 , but looks exactly like ld
  ;; on previous architectures.
  (define-f3-inst ld #b11 #b000000 :load-store :load
                  #!+sparc-v9 :print-name #!+sparc-v9 'lduw)

  (define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9

  ;; ldd is deprecated on the Sparc V9.
  (define-f3-inst ldd #b11 #b000011 :load-store :load)

  (define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9

  (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
  (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
  (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-reg :load-store :load)       ; v9
  (define-f3-inst stb #b11 #b000101 :load-store :store)
  (define-f3-inst sth #b11 #b000110 :load-store :store)
  (define-f3-inst st #b11 #b000100 :load-store :store)

  ;; std is deprecated on the Sparc V9.
  (define-f3-inst std #b11 #b000111 :load-store :store)

  (define-f3-inst stx #b11 #b001110 :load-store :store) ; v9

  (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
  (define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
  (define-f3-inst stqf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9
  (define-f3-inst ldstub #b11 #b001101 :load-store t)

  ;; swap is deprecated on the Sparc V9
  (define-f3-inst swap #b11 #b001111 :load-store t)

  (define-f3-inst add #b10 #b000000 :fixup t)
  (define-f3-inst addcc #b10 #b010000 :writes :psr)
  (define-f3-inst addx #b10 #b001000 :reads :psr)
  (define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr)
  (define-f3-inst taddcc #b10 #b100000 :writes :psr)

  ;; taddcctv is deprecated on the Sparc V9.  Use taddcc and bpvs or
  ;; taddcc and trap to get a similar effect.  (Requires changing the C
  ;; code though!)
  ;;(define-f3-inst taddcctv #b10 #b100010 :writes :psr)

  (define-f3-inst sub #b10 #b000100)
  (define-f3-inst subcc #b10 #b010100 :writes :psr)
  (define-f3-inst subx #b10 #b001100 :reads :psr)
  (define-f3-inst subxcc #b10 #b011100 :reads :psr :writes :psr)
  (define-f3-inst tsubcc #b10 #b100001 :writes :psr)

  ;; tsubcctv is deprecated on the Sparc V9.  Use tsubcc and bpvs or
  ;; tsubcc and trap to get a similar effect.  (Requires changing the C
  ;; code though!)
  ;;(define-f3-inst tsubcctv #b10 #b100011 :writes :psr)

  (define-f3-inst mulscc #b10 #b100100 :reads :y :writes (:psr :y))
  (define-f3-inst and #b10 #b000001)
  (define-f3-inst andcc #b10 #b010001 :writes :psr)
  (define-f3-inst andn #b10 #b000101)
  (define-f3-inst andncc #b10 #b010101 :writes :psr)
  (define-f3-inst or #b10 #b000010)
  (define-f3-inst orcc #b10 #b010010 :writes :psr)
  (define-f3-inst orn #b10 #b000110)