insts.lisp

开源跨平台Lisp编译器

                            (rs1 0))
            '(:name rd :tab immed))
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 0)
  (:emitter
   (cond
     ((member :sparc-v9 *backend-subfeatures*)
      (unless cc
        (setf cc :icc))
      (emit-format-4-trap segment
                          #b10
                          (branch-condition condition)
                          #b111010 0 1
                          (integer-condition cc)
                          target))
     (t
      (aver (null cc))
      (emit-format-3-immed segment #b10 (branch-condition condition)
                           #b111010 0 1 target)))))

;;; KLUDGE: we leave this commented out, as these two (T and TCC)
;;; operations are actually indistinguishable from their bitfields,
;;; breaking the disassembler if these are left in. The printer isn't
;;; terribly smart, but the emitted code is right. - CSR, 2002-08-04
#+nil
(define-instruction tcc (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
  (:declare (type branch-condition condition)
            ;; KLUDGE: see above.
            #!-linux
            (type (integer 16 31) target)
            (type integer-condition-register cc))
  (:printer format-4-trap ((op #b10)
                            (rd nil :type 'branch-condition)
                            (op3 #b111010)
                            (rs1 0))
            trap-printer)
  (:attributes branch)
  (:dependencies (reads :psr))
  (:delay 0)
  (:emitter (emit-format-4-trap segment
                                #b10
                                (branch-condition condition)
                                #b111010 0 1
                                (integer-condition cc)
                                target)))

;; Same as for the branch instructions.  On the Sparc V9, we will use
;; the FP branch with prediction instructions instead.

(define-instruction fb (segment condition target &rest args)
  (:declare (type fp-branch-condition condition) (type label target))
  (:printer format-2-branch ((op #B00)
                             (cond nil :type 'branch-fp-condition)
                             (op2 #b110)))
  (:attributes branch)
  (:dependencies (reads :fsr))
  (:delay 1)
  (:emitter
   (cond
     ((member :sparc-v9 *backend-subfeatures*)
      (destructuring-bind (&optional fcc pred) args
        (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
     (t
      (aver (null args))
      (emit-relative-branch segment 0 #b110 condition target t)))))

(define-instruction fbp (segment condition target &optional fcc pred)
  (:declare (type fp-branch-condition condition) (type label target))
  (:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
            fp-branch-pred-printer
            :print-name 'fbp)
  (:attributes branch)
  (:dependencies (reads :fsr))
  (:delay 1)
  (:emitter
   (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))

(defconstant-eqx jal-printer
  '(:name :tab
          (:choose (rs1 (:unless (:constant 0) (:plus-integer immed)))
                   (:cond ((rs2 :constant 0) rs1)
                          ((rs1 :constant 0) rs2)
                          (t rs1 "+" rs2)))
          (:unless (:constant 0) ", " rd))
  #'equalp)

(define-instruction jal (segment dst src1 &optional src2)
  (:declare (type tn dst)
            (type (or tn integer) src1)
            (type (or null fixup tn (signed-byte 13)) src2))
  (:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer)
  (:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
  (:attributes branch)
  (:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
  (:delay 1)
  (:emitter
   (unless src2
     (setf src2 src1)
     (setf src1 0))
   (etypecase src2
     (tn
      (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
                         (if (integerp src1)
                             src1
                             (reg-tn-encoding src1))
                         0 0 (reg-tn-encoding src2)))
     (integer
      (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
                           (reg-tn-encoding src1) 1 src2))
     (fixup
      (note-fixup segment :add src2)
      (emit-format-3-immed segment #b10 (reg-tn-encoding dst)
                           #b111000 (reg-tn-encoding src1) 1 0)))))

(define-instruction j (segment src1 &optional src2)
  (:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
  (:printer format-3-reg ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
  (:printer format-3-immed ((op #b10) (op3 #b111000) (rd 0)) jal-printer)
  (:attributes branch)
  (:dependencies (reads src1) (if src2 (reads src2)))
  (:delay 1)
  (:emitter
   (etypecase src2
     (null
      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
     (tn
      (emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
                         (reg-tn-encoding src2)))
     (integer
      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
                           src2))
     (fixup
      (note-fixup segment :add src2)
      (emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
                           0)))))



;;;; Unary and binary fp insts.

(macrolet ((define-unary-fp-inst (name opf &key reads extended)
  `(define-instruction ,name (segment dst src)
     (:declare (type tn dst src))
     (:printer format-unary-fpop
       ((op #b10) (op3 #b110100) (opf ,opf)
        (rs1 0)
        (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
        (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
     (:dependencies
      ,@(when reads
          `((reads ,reads)))
      (reads dst)
      (reads src)
      (writes dst))
     (:delay 0)
     (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
                #b110100 0 ,opf (fp-reg-tn-encoding src)))))

           (define-binary-fp-inst (name opf &key (op3 #b110100)
                                      reads writes delay extended)
  `(define-instruction ,name (segment dst src1 src2)
     (:declare (type tn dst src1 src2))
     (:printer format-binary-fpop
      ((op #b10) (op3 ,op3) (opf ,opf)
       (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
       (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
       (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
       ))
     (:dependencies
      ,@(when reads
          `((reads ,reads)))
      (reads src1)
      (reads src2)
      ,@(when writes
          `((writes ,writes)))
      (writes dst))
     ,@(if delay
           `((:delay ,delay))
           '((:delay 0)))
     (:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
                ,op3 (fp-reg-tn-encoding src1) ,opf
                (fp-reg-tn-encoding src2)))))

           (define-cmp-fp-inst (name opf &key extended)
               (let ((opf0 #b0)
                     (opf1 #b010)
                     (opf2 #b1))
                 `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
                   (:declare (type tn src1 src2)
                    (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
       (:printer format-fpop2
                 ((op #b10)
                  (op3 #b110101)
                  (opf0 ,opf0)
                  (opf1 ,opf1)
                  (opf2 ,opf2)
                  (opf3 ,opf)
                  (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
                  (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
                  #!-sparc-v9
                  (rd 0)
                  #!+sparc-v9
                  (rd nil :type 'fp-condition-register))
        )
     (:dependencies
      (reads src1)
      (reads src2)
      (writes :fsr))
     ;; The Sparc V9 doesn't need a delay after a FP compare.
     ;;
     ;; KLUDGE FIXME YAARGH -- how to express that? I guess for now we
     ;; do the worst case, and hope to fix it.
     ;; (:delay #-sparc-v9 1 #+sparc-v9 0)
     (:delay 1)
       (:emitter
        (emit-format-3-fpop2 segment #b10
                             (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
                                 0)
                             #b110101
                             (fp-reg-tn-encoding src1)
                             ,opf0 ,opf1 ,opf2 ,opf
                             (fp-reg-tn-encoding src2)))))))

  (define-unary-fp-inst fitos #b011000100 :reads :fsr)
  (define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t)
  (define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t)      ; v8

  (define-unary-fp-inst fxtos #b010000100 :reads :fsr)                    ; v9
  (define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t)        ; v9
  (define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t)      ; v9


  ;; I (Raymond Toy) don't think these f{sd}toir instructions exist on
  ;; any Ultrasparc, but I only have a V9 manual. The code in
  ;; float.lisp seems to indicate that they only existed on non-sun4
  ;; machines (sun3 68K machines?).
  (define-unary-fp-inst fstoir #b011000001 :reads :fsr)
  (define-unary-fp-inst fdtoir #b011000010 :reads :fsr)

  (define-unary-fp-inst fstoi #b011010001)
  (define-unary-fp-inst fdtoi #b011010010 :extended t)
  (define-unary-fp-inst fqtoi #b011010011 :extended t)  ; v8

  (define-unary-fp-inst fstox #b010000001)                ; v9
  (define-unary-fp-inst fdtox #b010000010 :extended t)    ; v9
  (define-unary-fp-inst fqtox #b010000011 :extended t)  ; v9

  (define-unary-fp-inst fstod #b011001001 :reads :fsr)
  (define-unary-fp-inst fstoq #b011001101 :reads :fsr)  ; v8
  (define-unary-fp-inst fdtos #b011000110 :reads :fsr)
  (define-unary-fp-inst fdtoq #b011001110 :reads :fsr)  ; v8
  (define-unary-fp-inst fqtos #b011000111 :reads :fsr)  ; v8
  (define-unary-fp-inst fqtod #b011001011 :reads :fsr)  ; v8

  (define-unary-fp-inst fmovs #b000000001)
  (define-unary-fp-inst fmovd #b000000010 :extended t)  ; v9
  (define-unary-fp-inst fmovq #b000000011 :extended t)  ; v9

  (define-unary-fp-inst fnegs #b000000101)
  (define-unary-fp-inst fnegd #b000000110 :extended t)  ; v9
  (define-unary-fp-inst fnegq #b000000111 :extended t)  ; v9

  (define-unary-fp-inst fabss #b000001001)
  (define-unary-fp-inst fabsd #b000001010 :extended t)  ; v9
  (define-unary-fp-inst fabsq #b000001011 :extended t)  ; v9

  (define-unary-fp-inst fsqrts #b000101001 :reads :fsr)         ; V7
  (define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t)     ; V7
  (define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t)     ; v8

  (define-binary-fp-inst fadds #b001000001)
  (define-binary-fp-inst faddd #b001000010 :extended t)
  (define-binary-fp-inst faddq #b001000011 :extended t) ; v8
  (define-binary-fp-inst fsubs #b001000101)
  (define-binary-fp-inst fsubd #b001000110 :extended t)
  (define-binary-fp-inst fsubq #b001000111 :extended t) ; v8

  (define-binary-fp-inst fmuls #b001001001)
  (define-binary-fp-inst fmuld #b001001010 :extended t)
  (define-binary-fp-inst fmulq #b001001011 :extended t) ; v8
  (define-binary-fp-inst fdivs #b001001101)
  (define-binary-fp-inst fdivd #b001001110 :extended t)
  (define-binary-fp-inst fdivq #b001001111 :extended t) ; v8

;;; Float comparison instructions.
;;;
  (define-cmp-fp-inst fcmps #b0001)
  (define-cmp-fp-inst fcmpd #b0010 :extended t)
  (define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8
  (define-cmp-fp-inst fcmpes #b0101)
  (define-cmp-fp-inst fcmped #b0110 :extended t)
  (define-cmp-fp-inst fcmpeq #b0111 :extended t)        ; v8

) ; MACROLET

;;;; li, jali, ji, nop, cmp, not, neg, move, and more

(defun %li (reg value)
  (etypecase value
    ((signed-byte 13)
     (inst add reg zero-tn value))
    ((or (signed-byte 32) (unsigned-byte 32))
     (let ((hi (ldb (byte 22 10) value))
           (lo (ldb (byte 10 0) value)))
       (inst sethi reg hi)
       (unless (zerop lo)
         (inst add reg lo))))
    (fixup
     (inst sethi reg value)
     (inst add reg value))))

(define-instruction-macro li (reg value)
  `(%li ,reg ,value))

;;; Jal to a full 32-bit address.  Tmpreg is trashed.
(define-instruction jali (segment link tmpreg value)
  (:declare (type tn link tmpreg)
            (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
                      fixup) value))
  (:attributes variable-length)
  (:vop-var vop)
  (:attributes branch)
  (:dependencies (writes link) (writes tmpreg))
  (:delay 1)
  (:emitter
   (assemble (segment vop)
     (etypecase value
       ((signed-byte 13)
        (inst jal link zero-tn value))
       ((or (signed-byte 32) (unsigned-byte 32))
        (let ((hi (ldb (byte 22 10) value))
              (lo (ldb (byte 10 0) value)))
          (inst sethi tmpreg hi)
          (inst jal link tmpreg lo)))
       (fixup
        (inst sethi tmpreg value)
        (inst jal link tmpreg value))))))

;;; Jump to a full 32-bit address.  Tmpreg is trashed.
(define-instruction ji (segment tmpreg value)
  (:declare (type tn tmpreg)
            (type (or (signed-byte 13) (signed-byte 32) (