float.lisp

开源跨平台Lisp编译器

         (let ((x-real (complex-single-reg-real-tn x))
               (y-real (complex-single-reg-real-tn y)))
           (inst fmr y-real x-real))
         (let ((x-imag (complex-single-reg-imag-tn x))
               (y-imag (complex-single-reg-imag-tn y)))
           (inst fmr y-imag x-imag))))
      (complex-single-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-single-reg-real-tn x)))
           (inst stfs real-tn nfp offset))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
           (inst stfs imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
  (complex-single-reg descriptor-reg) (complex-single-reg))

(define-vop (move-complex-double-float-arg)
  (:args (x :scs (complex-double-reg) :target y)
         (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
  (:results (y))
  (:note "complex double-float arg move")
  (:generator 2
    (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 fmr y-real x-real))
         (let ((x-imag (complex-double-reg-imag-tn x))
               (y-imag (complex-double-reg-imag-tn y)))
           (inst fmr y-imag x-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-double-reg-real-tn x)))
           (inst stfd real-tn nfp offset))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
           (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(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))
  (:policy :fast-safe)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only))

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

(macrolet ((frob (op sinst sname scost dinst dname dcost)
             `(progn
                (define-vop (,sname single-float-op)
                  (:translate ,op)
                  (:generator ,scost
                    (inst ,sinst r x y)))
                (define-vop (,dname double-float-op)
                  (:translate ,op)
                  (:generator ,dcost
                    (inst ,dinst r x y))))))
  (frob + fadds +/single-float 2 fadd +/double-float 2)
  (frob - fsubs -/single-float 2 fsub -/double-float 2)
  (frob * fmuls */single-float 4 fmul */double-float 5)
  (frob / fdivs //single-float 12 fdiv //double-float 19))

(macrolet ((frob (name inst translate sc type)
             `(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)
                (:generator 1
                  (note-this-location vop :internal-error)
                  (inst ,inst y x)))))
  (frob abs/single-float fabs abs single-reg single-float)
  (frob abs/double-float fabs abs double-reg double-float)
  (frob %negate/single-float fneg %negate single-reg single-float)
  (frob %negate/double-float fneg %negate double-reg double-float))


;;;; 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 :double)
       (inst fcmpo :cr1 x y)))
    (inst b?  :cr1 (if not-p nope yep) target)))

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

(macrolet ((frob (translate yep nope sname dname)
             `(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)))))
  (frob < :lt :ge </single-float </double-float)
  (frob > :gt :le >/single-float >/double-float)
  (frob = :eq :ne eql/single-float eql/double-float))


;;;; Conversion:

(macrolet ((frob (name translate inst to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (signed-reg)))
                (:temporary (:scs (double-stack)) temp)
                (:temporary (:scs (double-reg)) fmagic)
                (:temporary (:scs (signed-reg)) rtemp)
                (: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-offset (* (tn-offset temp) n-word-bytes))
                         (nfp-tn (current-nfp-tn vop))
                         (temp-offset-high (* stack-offset n-word-bytes))
                         (temp-offset-low (* (1+ stack-offset) n-word-bytes)))
                    (inst lis rtemp #x4330)   ; High word of magic constant
                    (inst stw rtemp nfp-tn temp-offset-high)
                    (inst lis rtemp #x8000)
                    (inst stw rtemp nfp-tn temp-offset-low)
                    (inst lfd fmagic nfp-tn temp-offset-high)
                    (inst xor rtemp rtemp x)          ; invert sign bit of x : rtemp had #x80000000
                    (inst stw rtemp nfp-tn temp-offset-low)
                    (inst lfd y nfp-tn temp-offset-high)
                    (note-this-location vop :internal-error)
                    (inst ,inst y y fmagic))))))
  (frob %single-float/signed %single-float fsubs single-reg single-float)
  (frob %double-float/signed %double-float fsub double-reg double-float))

(macrolet ((frob (name translate inst to-sc to-type)
            `(define-vop (,name)
               (:args (x :scs (unsigned-reg)))
               (:temporary (:scs (double-stack)) temp)
               (:temporary (:scs (double-reg)) fmagic)
               (:temporary (:scs (signed-reg)) rtemp)
               (:results (y :scs (,to-sc)))
               (:arg-types unsigned-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-offset (* (tn-offset temp) n-word-bytes))
                         (nfp-tn (current-nfp-tn vop))
                         (temp-offset-high (* stack-offset n-word-bytes))
                         (temp-offset-low (* (1+ stack-offset) n-word-bytes)))
                    (inst lis rtemp #x4330)   ; High word of magic constant
                    (inst stw rtemp nfp-tn temp-offset-high)
                    (inst stw zero-tn nfp-tn temp-offset-low)
                    (inst lfd fmagic nfp-tn temp-offset-high)
                    (inst stw x nfp-tn temp-offset-low)
                    (inst lfd y nfp-tn temp-offset-high)
                   (note-this-location vop :internal-error)
                   (inst ,inst y y fmagic))))))
  (frob %single-float/unsigned %single-float fsubs single-reg single-float)
  (frob %double-float/unsigned %double-float fsub double-reg double-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 frsp
    double-reg double-float single-reg single-float)
  (frob %double-float/single-float %double-float fmr
    single-reg single-float double-reg double-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 (double-stack)) stack-temp)
                (:results (y :scs (signed-reg)))
                (: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)
                  (inst stfd temp (current-nfp-tn vop)
                        (* (tn-offset stack-temp) n-word-bytes))
                  (inst lwz y (current-nfp-tn vop)
                        (+ 4 (* (tn-offset stack-temp) n-word-bytes)))))))
  (frob %unary-truncate single-reg single-float fctiwz)
  (frob %unary-truncate double-reg double-float fctiwz)
  (frob %unary-round single-reg single-float fctiw)
  (frob %unary-round double-reg double-float fctiw))

(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 stw bits (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes))
          (inst lfs res (current-nfp-tn vop)
                (* (tn-offset stack-temp) n-word-bytes)))
         (single-stack
          (inst stw bits (current-nfp-tn vop)
                (* (tn-offset res) n-word-bytes)))))
      (signed-stack
       (sc-case res
         (single-reg
          (inst lfs res (current-nfp-tn vop)
                (* (tn-offset bits) n-word-bytes)))
         (single-stack
          (unless (location= bits res)
            (inst lwz temp (current-nfp-tn vop)
                  (* (tn-offset bits) n-word-bytes))
            (inst stw 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 stw hi-bits (current-nfp-tn vop)
            (* (tn-offset stack-tn) n-word-bytes))
      (inst stw lo-bits (current-nfp-tn vop)
            (* (1+ (tn-offset stack-tn)) n-word-bytes)))
    (when (sc-is res double-reg)
      (inst lfd res (current-nfp-tn vop)
            (* (tn-offset temp) n-word-bytes)))))

(define-vop (single-float-bits)