float.lisp

开源跨平台Lisp编译器

  (:results (y))
  (:note "float argument move")
  (:generator 1
    (sc-case y
      (complex-double-reg
       (unless (location= x y)
         (let ((x-real (complex-double-reg-real-tn x))
               (y-real (complex-double-reg-real-tn y)))
           (inst funop :copy x-real y-real))
         (let ((x-imag (complex-double-reg-imag-tn x))
               (y-imag (complex-double-reg-imag-tn y)))
           (inst funop :copy x-imag y-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-double-reg-real-tn x)))
           (str-float real-tn offset nfp))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
           (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
(define-move-vop move-complex-double-float-arg :move-arg
  (complex-double-reg descriptor-reg) (complex-double-reg))

(define-move-vop move-arg :move-arg
  (single-reg double-reg complex-single-reg complex-double-reg)
  (descriptor-reg))

;;;; Arithmetic VOPs.

(define-vop (float-op)
  (:args (x) (y))
  (:results (r))
  (:variant-vars operation)
  (:policy :fast-safe)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:node-var node)
  (:generator 0
    (inst fbinop operation x y r)
    (when (policy node (or (= debug 3) (> safety speed)))
      (note-next-instruction vop :internal-error)
      (inst fsts fp-single-zero-tn 0 csp-tn))))

(macrolet ((frob (name sc zero-sc ptype)
             `(define-vop (,name float-op)
                (:args (x :scs (,sc ,zero-sc))
                       (y :scs (,sc ,zero-sc)))
                (:results (r :scs (,sc)))
                (:arg-types ,ptype ,ptype)
                (:result-types ,ptype))))
  (frob single-float-op single-reg fp-single-zero single-float)
  (frob double-float-op double-reg fp-double-zero double-float))

(macrolet ((frob (translate op sname scost dname dcost)
             `(progn
                (define-vop (,sname single-float-op)
                  (:translate ,translate)
                  (:variant ,op)
                  (:variant-cost ,scost))
                (define-vop (,dname double-float-op)
                  (:translate ,translate)
                  (:variant ,op)
                  (:variant-cost ,dcost)))))
  (frob + :add +/single-float 2 +/double-float 2)
  (frob - :sub -/single-float 2 -/double-float 2)
  (frob * :mpy */single-float 4 */double-float 5)
  (frob / :div //single-float 12 //double-float 19))


(macrolet ((frob (name translate sc type inst)
             `(define-vop (,name)
                (:args (x :scs (,sc)))
                (:results (y :scs (,sc)))
                (:translate ,translate)
                (:policy :fast-safe)
                (:arg-types ,type)
                (:result-types ,type)
                (:note "inline float arithmetic")
                (:vop-var vop)
                (:save-p :compute-only)
                (:node-var node)
                (:generator 1
                  ,inst
                  (when (policy node (or (= debug 3) (> safety speed)))
                    (note-next-instruction vop :internal-error)
                    (inst fsts fp-single-zero-tn 0 csp-tn))))))
  (frob abs/single-float abs single-reg single-float
    (inst funop :abs x y))
  (frob abs/double-float abs double-reg double-float
    (inst funop :abs x y))
  (frob %negate/single-float %negate single-reg single-float
    (inst fbinop :sub fp-single-zero-tn x y))
  (frob %negate/double-float %negate double-reg double-float
    (inst fbinop :sub fp-double-zero-tn x y)))


;;;; Comparison:

(define-vop (float-compare)
  (:args (x) (y))
  (:conditional)
  (:info target not-p)
  (:variant-vars condition complement)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    ;; This is the condition to nullify the branch, so it is inverted.
    (inst fcmp (if not-p condition complement) x y)
    (note-next-instruction vop :internal-error)
    (inst ftest)
    (inst b target :nullify t)))

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

(macrolet ((frob (translate condition complement sname dname)
             `(progn
                (define-vop (,sname single-float-compare)
                  (:translate ,translate)
                  (:variant ,condition ,complement))
                (define-vop (,dname double-float-compare)
                  (:translate ,translate)
                  (:variant ,condition ,complement)))))
  (frob < #b01001 #b10101 </single-float </double-float)
  (frob > #b10001 #b01101 >/single-float >/double-float)
  (frob = #b00101 #b11001 eql/single-float eql/double-float))


;;;; Conversion:

(macrolet ((frob (name translate 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)
                (:node-var node)
                (:generator 2
                  (inst fcnvff x y)
                  (when (policy node (or (= debug 3) (> safety speed)))
                    (note-next-instruction vop :internal-error)
                    (inst fsts fp-single-zero-tn 0 csp-tn))))))
  (frob %single-float/double-float %single-float
    double-reg double-float
    single-reg single-float)
  (frob %double-float/single-float %double-float
    single-reg single-float
    double-reg double-float))

(macrolet ((frob (name translate to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (signed-reg)
                          :load-if (not (sc-is x signed-stack))
                          :target stack-temp))
                (:arg-types signed-num)
                (:results (y :scs (,to-sc)))
                (:result-types ,to-type)
                (:policy :fast-safe)
                (:note "inline float coercion")
                (:translate ,translate)
                (:vop-var vop)
                (:save-p :compute-only)
                (:node-var node)
                (:temporary (:scs (signed-stack) :from (:argument 0))
                            stack-temp)
                (:temporary (:scs (single-reg) :to (:result 0) :target y)
                            fp-temp)
                (:temporary (:scs (any-reg) :from (:argument 0)
                                  :to (:result 0)) index)
                (:generator 5
                  (let* ((nfp (current-nfp-tn vop))
                         (stack-tn
                          (sc-case x
                            (signed-stack
                             x)
                            (signed-reg
                             (storew x nfp (tn-offset stack-temp))
                             stack-temp)))
                         (offset (* (tn-offset stack-tn) n-word-bytes)))
                    (cond ((< offset (ash 1 4))
                           (inst flds offset nfp fp-temp))
                          (t
                           (inst ldo offset zero-tn index)
                           (inst fldx index nfp fp-temp)))
                    (inst fcnvxf fp-temp y)
                    (when (policy node (or (= debug 3) (> safety speed)))
                      (note-next-instruction vop :internal-error)
                      (inst fsts fp-single-zero-tn 0 csp-tn)))))))
  (frob %single-float/signed %single-float
    single-reg single-float)
  (frob %double-float/signed %double-float
    double-reg double-float))


(macrolet ((frob (trans from-sc from-type inst note)
             `(define-vop (,(symbolicate trans "/" from-type))
                (:args (x :scs (,from-sc)
                          :target fp-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 ,note)
                (:vop-var vop)
                (:save-p :compute-only)
                (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
                (:temporary (:scs (signed-stack) :to (:result 0) :target y)
                            stack-temp)
                (:temporary (:scs (any-reg) :from (:argument 0)
                                  :to (:result 0)) index)
                (:generator 3
                  (let* ((nfp (current-nfp-tn vop))
                         (stack-tn
                          (sc-case y
                            (signed-stack y)
                            (signed-reg stack-temp)))
                         (offset (* (tn-offset stack-tn) n-word-bytes)))
                    (inst ,inst x fp-temp)
                    (cond ((< offset (ash 1 4))
                           (note-next-instruction vop :internal-error)
                           (inst fsts fp-temp offset nfp))
                          (t
                           (inst ldo offset zero-tn index)
                           (note-next-instruction vop :internal-error)
                           (inst fstx fp-temp index nfp)))
                    (unless (eq y stack-tn)
                      (loadw y nfp (tn-offset stack-tn))))))))
  (frob %unary-round single-reg single-float fcnvfx "inline float round")
  (frob %unary-round double-reg double-float fcnvfx "inline float round")
  (frob %unary-truncate single-reg single-float fcnvfxt
    "inline float truncate")
  (frob %unary-truncate double-reg double-float fcnvfxt
    "inline float truncate"))


(define-vop (make-single-float)
  (:args (bits :scs (signed-reg)
               :load-if (or (not (sc-is bits signed-stack))
                            (sc-is res single-stack))
               :target res))
  (:results (res :scs (single-reg)
                 :load-if (not (sc-is bits single-stack))))
  (:arg-types signed-num)
  (:result-types single-float)
  (:translate make-single-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:scs (single-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 bits
        (signed-reg
         (sc-case res
           (single-reg
            (let ((offset (* (tn-offset temp) n-word-bytes)))
              (inst stw bits offset nfp)
              (cond ((< offset (ash 1 4))
                     (inst flds offset nfp res))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fldx index nfp res)))))
           (single-stack
            (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
        (signed-stack
         (sc-case res
           (single-reg
            (let ((offset (* (tn-offset bits) n-word-bytes)))
              (cond ((< offset (ash 1 4))
                     (inst flds offset nfp res))
                    (t
                     (inst ldo offset zero-tn index)
                     (inst fldx index nfp res)))))))))))

(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))))
  (:arg-types signed-num unsigned-num)
  (:result-types double-float)
  (:translate make-double-float)
  (:policy :fast-safe)
  (:temporary (:scs (double-stack) :to (:result 0)) temp)
  (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
  (:vop-var vop)
  (:generator 2
    (let* ((nfp (current-nfp-tn vop))
           (stack-tn (sc-case res
                       (double-stack res)
                       (double-reg temp)))
           (offset (* (tn-offset stack-tn) n-word-bytes)))