float.lisp

开源跨平台Lisp编译器

               `(define-vop (,name)
                  (:args (x :scs (,from-sc)))
                  (:results (y :scs (,to-sc)))
                  (:arg-types ,from-type)
                  (:result-types ,to-type)
                  (:policy :fast-safe)
                  (:note "inline float coercion")
                  (:translate ,translate)
                  (:vop-var vop)
                  (:save-p :compute-only)
                  (:generator ,(if word-p 3 2)
                    ,@(if word-p
                          `((inst mtc1 y x)
                            (inst nop)
                            (note-this-location vop :internal-error)
                            (inst fcvt ,to-format :word y y))
                          `((note-this-location vop :internal-error)
                            (inst fcvt ,to-format ,from-format y x))))))))
  (frob %single-float/signed %single-float
    signed-reg signed-num :word
    single-reg single-float :single)
  (frob %double-float/signed %double-float
    signed-reg signed-num :word
    double-reg double-float :double)
  (frob %single-float/double-float %single-float
    double-reg double-float :double
    single-reg single-float :single)
  (frob %double-float/single-float %double-float
    single-reg single-float :single
    double-reg double-float :double))


(macrolet ((frob (name from-sc from-type from-format)
             `(define-vop (,name)
                (:args (x :scs (,from-sc)))
                (:results (y :scs (signed-reg)))
                (:temporary (:from (:argument 0) :sc ,from-sc) temp)
                (:arg-types ,from-type)
                (:result-types signed-num)
                (:translate %unary-round)
                (:policy :fast-safe)
                (:note "inline float round")
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 3
                  (note-this-location vop :internal-error)
                  (inst fcvt :word ,from-format temp x)
                  (inst mfc1 y temp)
                  (inst nop)))))
  (frob %unary-round/single-float single-reg single-float :single)
  (frob %unary-round/double-float double-reg double-float :double))


;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
;;; the desired round-to-zero behavior.
;;;
(macrolet ((frob (name from-sc from-type from-format)
             `(define-vop (,name)
                (:args (x :scs (,from-sc)))
                (:results (y :scs (signed-reg)))
                (:temporary (:from (:argument 0) :sc ,from-sc) temp)
                (:temporary (:sc non-descriptor-reg) status-save new-status)
                (:temporary (:sc non-descriptor-reg :offset nl4-offset)
                            pa-flag)
                (:arg-types ,from-type)
                (:result-types signed-num)
                (:translate %unary-truncate)
                (:policy :fast-safe)
                (:note "inline float truncate")
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 16
                  (pseudo-atomic (pa-flag)
                    (inst cfc1 status-save 31)
                    (inst li new-status (lognot 3))
                    (inst and new-status status-save)
                    (inst or new-status float-round-to-zero)
                    (inst ctc1 new-status 31)

                    ;; These instructions seem to be necessary to ensure that
                    ;; the new modes affect the fcvt instruction.
                    (inst nop)
                    (inst cfc1 new-status 31)

                    (note-this-location vop :internal-error)
                    (inst fcvt :word ,from-format temp x)
                    (inst mfc1 y temp)
                    (inst nop)
                    (inst ctc1 status-save 31))))))
  (frob %unary-truncate/single-float single-reg single-float :single)
  (frob %unary-truncate/double-float double-reg double-float :double))


(define-vop (make-single-float)
  (:args (bits :scs (signed-reg)))
  (:results (res :scs (single-reg)))
  (:arg-types signed-num)
  (:result-types single-float)
  (:translate make-single-float)
  (:policy :fast-safe)
  (:generator 2
    (inst mtc1 res bits)
    (inst nop)))

(define-vop (make-double-float)
  (:args (hi-bits :scs (signed-reg))
         (lo-bits :scs (unsigned-reg)))
  (:results (res :scs (double-reg)))
  (:arg-types signed-num unsigned-num)
  (:result-types double-float)
  (:translate make-double-float)
  (:policy :fast-safe)
  (:generator 2
    (inst mtc1 res lo-bits)
    (inst mtc1-odd res hi-bits)
    (inst nop)))

(define-vop (single-float-bits)
  (:args (float :scs (single-reg)))
  (:results (bits :scs (signed-reg)))
  (:arg-types single-float)
  (:result-types signed-num)
  (:translate single-float-bits)
  (:policy :fast-safe)
  (:generator 2
    (inst mfc1 bits float)
    (inst nop)))

(define-vop (double-float-high-bits)
  (:args (float :scs (double-reg)))
  (:results (hi-bits :scs (signed-reg)))
  (:arg-types double-float)
  (:result-types signed-num)
  (:translate double-float-high-bits)
  (:policy :fast-safe)
  (:generator 2
    (inst mfc1-odd hi-bits float)
    (inst nop)))

(define-vop (double-float-low-bits)
  (:args (float :scs (double-reg)))
  (:results (lo-bits :scs (unsigned-reg)))
  (:arg-types double-float)
  (:result-types unsigned-num)
  (:translate double-float-low-bits)
  (:policy :fast-safe)
  (:generator 2
    (inst mfc1 lo-bits float)
    (inst nop)))


;;;; 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 fmove :single r-real real)))
       (let ((r-imag (complex-single-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmove :single r-imag imag))))
      (complex-single-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (inst swc1 real nfp offset)
         (inst swc1 imag nfp (+ offset n-word-bytes)))))))

(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 fmove :double r-real real)))
       (let ((r-imag (complex-double-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmove :double r-imag imag))))
      (complex-double-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (str-double real nfp offset)
         (str-double imag nfp (+ offset (* 2 n-word-bytes))))))))


(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 fmove :single r value-tn))))
      (complex-single-stack
       (inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
                                               (tn-offset x))
                                            n-word-bytes))
       (inst nop)))))

(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 fmove :double r value-tn))))
      (complex-double-stack
       (ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
                                               (tn-offset x))
                                            n-word-bytes))
       (inst nop)))))

(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))