float.lisp

开源跨平台Lisp编译器

      (inst stw hi-bits offset nfp)
      (inst stw lo-bits (+ offset n-word-bytes) nfp)
      (cond ((eq stack-tn res))
            ((< offset (ash 1 4))
             (inst flds offset nfp res))
            (t
             (inst ldo offset zero-tn index)
             (inst fldx index nfp res))))))


(define-vop (single-float-bits)
  (:args (float :scs (single-reg)
                :load-if (not (sc-is float single-stack))))
  (:results (bits :scs (signed-reg)
                  :load-if (or (not (sc-is bits signed-stack))
                               (sc-is float single-stack))))
  (:arg-types single-float)
  (:result-types signed-num)
  (:translate single-float-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:generator 2
    (let ((nfp (current-nfp-tn vop)))
      (sc-case float
        (single-reg
         (sc-case bits
           (signed-reg
            (let ((offset (* (tn-offset temp) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp)))
              (inst ldw offset nfp bits)))
           (signed-stack
            (let ((offset (* (tn-offset bits) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp)))))))
        (single-stack
         (sc-case bits
           (signed-reg
            (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))

(define-vop (double-float-high-bits)
  (:args (float :scs (double-reg)
                :load-if (not (sc-is float double-stack))))
  (:results (hi-bits :scs (signed-reg)
                     :load-if (or (not (sc-is hi-bits signed-stack))
                                  (sc-is float double-stack))))
  (:arg-types double-float)
  (:result-types signed-num)
  (:translate double-float-high-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:generator 2
    (let ((nfp (current-nfp-tn vop)))
      (sc-case float
        (double-reg
         (sc-case hi-bits
           (signed-reg
            (let ((offset (* (tn-offset temp) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp :side 0))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp :side 0)))
              (inst ldw offset nfp hi-bits)))
           (signed-stack
            (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp :side 0))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp :side 0)))))))
        (double-stack
         (sc-case hi-bits
           (signed-reg
            (let ((offset (* (tn-offset float) n-word-bytes)))
              (inst ldw offset nfp hi-bits)))))))))

(define-vop (double-float-low-bits)
  (:args (float :scs (double-reg)
                :load-if (not (sc-is float double-stack))))
  (:results (lo-bits :scs (unsigned-reg)
                     :load-if (or (not (sc-is lo-bits unsigned-stack))
                                  (sc-is float double-stack))))
  (:arg-types double-float)
  (:result-types unsigned-num)
  (:translate double-float-low-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:generator 2
    (let ((nfp (current-nfp-tn vop)))
      (sc-case float
        (double-reg
         (sc-case lo-bits
           (unsigned-reg
            (let ((offset (* (tn-offset temp) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp :side 1))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp :side 1)))
              (inst ldw offset nfp lo-bits)))
           (unsigned-stack
            (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst fsts float offset nfp :side 1))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fstx float index nfp :side 1)))))))
        (double-stack
         (sc-case lo-bits
           (unsigned-reg
            (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
              (inst ldw offset nfp lo-bits)))))))))



;;;; Float mode hackery:

(sb!xc:deftype float-modes () '(unsigned-byte 32))
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
  float-modes)

(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)
                 :load-if (not (sc-is res unsigned-stack))))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:temporary (:scs (unsigned-stack) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:vop-var vop)
  (:generator 3
    (let* ((nfp (current-nfp-tn vop))
           (stack-tn (sc-case res
                       (unsigned-stack res)
                       (unsigned-reg temp)))
           (offset (* (tn-offset stack-tn) n-word-bytes)))
      (cond ((< offset (ash 1 4))
             (inst fsts fp-single-zero-tn offset nfp))
            (t
             (inst ldo offset zero-tn index)
             (inst fstx fp-single-zero-tn index nfp)))
      (unless (eq stack-tn res)
        (inst ldw offset nfp res)))))

(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg)
              :load-if (not (sc-is new unsigned-stack))))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:scs (unsigned-stack) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:vop-var vop)
  (:generator 3
    (let* ((nfp (current-nfp-tn vop))
           (stack-tn (sc-case new
                       (unsigned-stack new)
                       (unsigned-reg temp)))
           (offset (* (tn-offset stack-tn) n-word-bytes)))
      (unless (eq new stack-tn)
        (inst stw new offset nfp))
      (cond ((< offset (ash 1 4))
             (inst flds offset nfp fp-single-zero-tn))
            (t
             (inst ldo offset zero-tn index)
             (inst fldx index nfp fp-single-zero-tn)))
      (inst ldw offset nfp res))))


;;;; Complex float VOPs

(define-vop (make-complex-single-float)
  (:translate complex)
  (:args (real :scs (single-reg) :target r)
         (imag :scs (single-reg) :to :save))
  (:arg-types single-float single-float)
  (:results (r :scs (complex-single-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-single-stack))))
  (:result-types complex-single-float)
  (:note "inline complex single-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-single-reg
       (let ((r-real (complex-single-reg-real-tn r)))
         (unless (location= real r-real)
           (inst funop :copy real r-real)))
       (let ((r-imag (complex-single-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst funop :copy imag r-imag))))
      (complex-single-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (str-float real offset nfp)
         (str-float imag (+ offset n-word-bytes) nfp))))))

(define-vop (make-complex-double-float)
  (:translate complex)
  (:args (real :scs (double-reg) :target r)
         (imag :scs (double-reg) :to :save))
  (:arg-types double-float double-float)
  (:results (r :scs (complex-double-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-double-stack))))
  (:result-types complex-double-float)
  (:note "inline complex double-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-double-reg
       (let ((r-real (complex-double-reg-real-tn r)))
         (unless (location= real r-real)
           (inst funop :copy real r-real)))
       (let ((r-imag (complex-double-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst funop :copy imag r-imag))))
      (complex-double-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (str-float real offset nfp)
         (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))


(define-vop (complex-single-float-value)
  (:args (x :scs (complex-single-reg) :target r
            :load-if (not (sc-is x complex-single-stack))))
  (:arg-types complex-single-float)
  (:results (r :scs (single-reg)))
  (:result-types single-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-single-reg
       (let ((value-tn (ecase slot
                         (:real (complex-single-reg-real-tn x))
                         (:imag (complex-single-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (inst funop :copy value-tn r))))
      (complex-single-stack
       (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
                    n-word-bytes)
                 (current-nfp-tn vop) r)))))

(define-vop (realpart/complex-single-float complex-single-float-value)
  (:translate realpart)
  (:note "complex single float realpart")
  (:variant :real))

(define-vop (imagpart/complex-single-float complex-single-float-value)
  (:translate imagpart)
  (:note "complex single float imagpart")
  (:variant :imag))

(define-vop (complex-double-float-value)
  (:args (x :scs (complex-double-reg) :target r
            :load-if (not (sc-is x complex-double-stack))))
  (:arg-types complex-double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-double-reg
       (let ((value-tn (ecase slot
                         (:real (complex-double-reg-real-tn x))
                         (:imag (complex-double-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (inst funop :copy value-tn r))))
      (complex-double-stack
       (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
                    n-word-bytes)
                 (current-nfp-tn vop) r)))))

(define-vop (realpart/complex-double-float complex-double-float-value)
  (:translate realpart)
  (:note "complex double float realpart")
  (:variant :real))

(define-vop (imagpart/complex-double-float complex-double-float-value)
  (:translate imagpart)
  (:note "complex double float imagpart")
  (:variant :imag))