float.lisp

开源跨平台Lisp编译器

                                  :offset (+ 1 (tn-offset src)))))
       (inst fmovs dst-2 src-2)))))

(define-vop (abs/double-float)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate abs)
  (:policy :fast-safe)
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (abs-double-reg y x)))

(define-vop (%negate/double-float)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate %negate)
  (:policy :fast-safe)
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (negate-double-reg y x)))

#!+long-float
(define-vop (abs/long-float)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate abs)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (cond
      ((member :sparc-v9 *backend-subfeatures*)
       (inst fabsq y x))
      (t
       (inst fabss y x)
       (dotimes (i 3)
         (let ((y-odd (make-random-tn
                       :kind :normal
                       :sc (sc-or-lose 'single-reg)
                       :offset (+ i 1 (tn-offset y))))
               (x-odd (make-random-tn
                       :kind :normal
                       :sc (sc-or-lose 'single-reg)
                       :offset (+ i 1 (tn-offset x)))))
           (inst fmovs y-odd x-odd)))))))

#!+long-float
(define-vop (%negate/long-float)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate %negate)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (cond
      ((member :sparc-v9 *backend-subfeatures*)
       (inst fnegq y x))
      (t
       (inst fnegs y x)
       (dotimes (i 3)
         (let ((y-odd (make-random-tn
                       :kind :normal
                       :sc (sc-or-lose 'single-reg)
                       :offset (+ i 1 (tn-offset y))))
               (x-odd (make-random-tn
                       :kind :normal
                       :sc (sc-or-lose 'single-reg)
                       :offset (+ i 1 (tn-offset x)))))
           (inst fmovs y-odd x-odd)))))))


;;;; Comparison:

(define-vop (float-compare)
  (:args (x) (y))
  (:conditional)
  (:info target not-p)
  (:variant-vars format yep nope)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (note-this-location vop :internal-error)
    (ecase format
      (:single (inst fcmps x y))
      (:double (inst fcmpd x y))
      (:long (inst fcmpq x y)))
    ;; The SPARC V9 doesn't need an instruction between a
    ;; floating-point compare and a floating-point branch.
    (unless (member :sparc-v9 *backend-subfeatures*)
      (inst nop))
    (inst fb (if not-p nope yep) target)
    (inst nop)))

(macrolet ((frob (name sc ptype)
             `(define-vop (,name float-compare)
                (:args (x :scs (,sc))
                       (y :scs (,sc)))
                (:arg-types ,ptype ,ptype))))
  (frob single-float-compare single-reg single-float)
  (frob double-float-compare double-reg double-float)
  #!+long-float
  (frob long-float-compare long-reg long-float))

(macrolet ((frob (translate yep nope sname dname #!+long-float lname)
             `(progn
                (define-vop (,sname single-float-compare)
                  (:translate ,translate)
                  (:variant :single ,yep ,nope))
                (define-vop (,dname double-float-compare)
                  (:translate ,translate)
                  (:variant :double ,yep ,nope))
                #!+long-float
                (define-vop (,lname long-float-compare)
                  (:translate ,translate)
                  (:variant :long ,yep ,nope)))))
  (frob < :l :ge </single-float </double-float #!+long-float </long-float)
  (frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
  (frob = :eq :ne eql/single-float eql/double-float #!+long-float eql/long-float))

#!+long-float
(deftransform eql ((x y) (long-float long-float))
  '(and (= (long-float-low-bits x) (long-float-low-bits y))
        (= (long-float-mid-bits x) (long-float-mid-bits y))
        (= (long-float-high-bits x) (long-float-high-bits y))
        (= (long-float-exp-bits x) (long-float-exp-bits y))))


;;;; Conversion:

(macrolet ((frob (name translate inst to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (signed-reg) :target stack-temp
                          :load-if (not (sc-is x signed-stack))))
                (:temporary (:scs (single-stack) :from :argument) stack-temp)
                (:temporary (:scs (single-reg) :to :result :target y) temp)
                (:results (y :scs (,to-sc)))
                (:arg-types signed-num)
                (:result-types ,to-type)
                (:policy :fast-safe)
                (:note "inline float coercion")
                (:translate ,translate)
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 5
                  (let ((stack-tn
                         (sc-case x
                           (signed-reg
                            (inst st x
                                  (current-nfp-tn vop)
                                  (* (tn-offset temp) n-word-bytes))
                            stack-temp)
                           (signed-stack
                            x))))
                    (inst ldf temp
                          (current-nfp-tn vop)
                          (* (tn-offset stack-tn) n-word-bytes))
                    (note-this-location vop :internal-error)
                    (inst ,inst y temp))))))
  (frob %single-float/signed %single-float fitos single-reg single-float)
  (frob %double-float/signed %double-float fitod double-reg double-float)
  #!+long-float
  (frob %long-float/signed %long-float fitoq long-reg long-float))

(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
             `(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 2
                  (note-this-location vop :internal-error)
                  (inst ,inst y x)))))
  (frob %single-float/double-float %single-float fdtos
    double-reg double-float single-reg single-float)
  #!+long-float
  (frob %single-float/long-float %single-float fqtos
    long-reg long-float single-reg single-float)
  (frob %double-float/single-float %double-float fstod
    single-reg single-float double-reg double-float)
  #!+long-float
  (frob %double-float/long-float %double-float fqtod
    long-reg long-float double-reg double-float)
  #!+long-float
  (frob %long-float/single-float %long-float fstoq
    single-reg single-float long-reg long-float)
  #!+long-float
  (frob %long-float/double-float %long-float fdtoq
    double-reg double-float long-reg long-float))

(macrolet ((frob (trans from-sc from-type inst)
             `(define-vop (,(symbolicate trans "/" from-type))
                (:args (x :scs (,from-sc) :target temp))
                (:temporary (:from (:argument 0) :sc single-reg) temp)
                (:temporary (:scs (signed-stack)) stack-temp)
                (:results (y :scs (signed-reg)
                             :load-if (not (sc-is y signed-stack))))
                (:arg-types ,from-type)
                (:result-types signed-num)
                (:translate ,trans)
                (:policy :fast-safe)
                (:note "inline float truncate")
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 5
                  (note-this-location vop :internal-error)
                  (inst ,inst temp x)
                  (sc-case y
                    (signed-stack
                     (inst stf temp (current-nfp-tn vop)
                           (* (tn-offset y) n-word-bytes)))
                    (signed-reg
                     (inst stf temp (current-nfp-tn vop)
                           (* (tn-offset stack-temp) n-word-bytes))
                     (inst ld y (current-nfp-tn vop)
                           (* (tn-offset stack-temp) n-word-bytes))))))))
  (frob %unary-truncate single-reg single-float fstoi)
  (frob %unary-truncate double-reg double-float fdtoi)
  #!+long-float
  (frob %unary-truncate long-reg long-float fqtoi)
  ;; KLUDGE -- these two forms were protected by #-sun4.
  ;; (frob %unary-round single-reg single-float fstoir)
  ;; (frob %unary-round double-reg double-float fdtoir)
)

(deftransform %unary-round ((x) (float) (signed-byte 32))
  '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
          (extra (- x trunc))
          (absx (abs extra))
          (one-half (float 1/2 x)))
     (if (if (oddp trunc)
             (>= absx one-half)
             (> absx one-half))
         (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
         trunc)))

(define-vop (make-single-float)
  (:args (bits :scs (signed-reg) :target res
               :load-if (not (sc-is bits signed-stack))))
  (:results (res :scs (single-reg)
                 :load-if (not (sc-is res single-stack))))
  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (signed-stack)) stack-temp)
  (:arg-types signed-num)
  (:result-types single-float)
  (:translate make-single-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case bits
      (signed-reg
       (sc-case res
         (single-reg
          (inst st bits (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes))
          (inst ldf res (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes)))
         (single-stack
          (inst st bits (current-nfp-tn vop)
                (* (tn-offset res) n-word-bytes)))))
      (signed-stack
       (sc-case res
         (single-reg
          (inst ldf res (current-nfp-tn vop)
                (* (tn-offset bits) n-word-bytes)))
         (single-stack
          (unless (location= bits res)
            (inst ld temp (current-nfp-tn vop)
                  (* (tn-offset bits) n-word-bytes))
            (inst st temp (current-nfp-tn vop)
                  (* (tn-offset res) n-word-bytes)))))))))

(define-vop (make-double-float)
  (:args (hi-bits :scs (signed-reg))
         (lo-bits :scs (unsigned-reg)))
  (:results (res :scs (double-reg)
                 :load-if (not (sc-is res double-stack))))
  (:temporary (:scs (double-stack)) temp)
  (:arg-types signed-num unsigned-num)
  (:result-types double-float)
  (:translate make-double-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let ((stack-tn (sc-case res
                      (double-stack res)
                      (double-reg temp))))
      (inst st hi-bits (current-nfp-tn vop)
            (* (tn-offset stack-tn) n-word-bytes))
      (inst st lo-bits (current-nfp-tn vop)
            (* (1+ (tn-offset stack-tn)) n-word-bytes)))
    (when (sc-is res double-reg)
      (inst lddf res (current-nfp-tn vop)
            (* (tn-offset temp) n-word-bytes)))))

#!+long-float
(define-vop (make-long-float)
    (:args (hi-bits :scs (signed-reg))
           (lo1-bits :scs (unsigned-reg))
           (lo2-bits :scs (unsigned-reg))
           (lo3-bits :scs (unsigned-reg)))
  (:results (res :scs (long-reg)
                 :load-if (not (sc-is res long-stack))))
  (:temporary (:scs (long-stack)) temp)
  (:arg-types signed-num unsigned-num unsigned-num unsigned-num)
  (:result-types long-float)
  (:translate make-long-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let ((stack-tn (sc-case res
                      (long-stack res)
                      (long-reg temp))))
      (inst st hi-bits (current-nfp-tn vop)
            (* (tn-offset stack-tn) n-word-bytes))
      (inst st lo1-bits (current-nfp-tn vop)
            (* (1+ (tn-offset stack-tn)) n-word-bytes))
      (inst st lo2-bits (current-nfp-tn vop)
            (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
      (inst st lo3-bits (current-nfp-tn vop)
            (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
    (when (sc-is res long-reg)
      (load-long-reg res (current-nfp-tn vop)