float.lisp

开源跨平台Lisp编译器

                       (if (= (tn-offset fp) esp-offset)
                           (let* ((offset (* (tn-offset y) n-word-bytes))
                                  (ea (make-ea :dword :base fp :disp offset)))
                             ,@(ecase format
                                      (:single '((inst movss ea x)))
                                      (:double '((inst movsd ea x)))))
                           (let ((ea (make-ea
                                      :dword :base fp
                                      :disp (- (* (1+ (tn-offset y))
                                                  n-word-bytes)))))
                             ,@(ecase format
                                 (:single '((inst movss ea x)))
                                 (:double '((inst movsd ea x))))))))))
                (define-move-vop ,name :move-arg
                  (,sc descriptor-reg) (,sc)))))
  (frob move-single-float-arg single-reg single-stack :single)
  (frob move-double-float-arg double-reg double-stack :double))

;;;; complex float MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
             `(progn
                (define-vop (,name)
                  (:args (x :scs (,sc) :target y)
                         (fp :scs (any-reg)
                             :load-if (not (sc-is y ,sc))))
                  (:results (y))
                  (:note "complex float argument move")
                  (:generator ,(ecase format (:single 2) (:double 3))
                    (sc-case y
                      (,sc
                       (unless (location= x y)
                         (let ((x-real (complex-double-reg-real-tn x))
                               (y-real (complex-double-reg-real-tn y)))
                           (inst movsd y-real x-real))
                         (let ((x-imag (complex-double-reg-imag-tn x))
                               (y-imag (complex-double-reg-imag-tn y)))
                           (inst movsd y-imag x-imag))))
                      (,stack-sc
                       (let ((real-tn (complex-double-reg-real-tn x)))
                         ,@(ecase format
                                  (:single
                                   '((inst movss
                                      (ea-for-csf-real-stack y fp)
                                      real-tn)))
                                  (:double
                                   '((inst movsd
                                      (ea-for-cdf-real-stack y fp)
                                      real-tn)))))
                       (let ((imag-tn (complex-double-reg-imag-tn x)))
                         ,@(ecase format
                                  (:single
                                   '((inst movss
                                      (ea-for-csf-imag-stack y fp) imag-tn)))
                                  (:double
                                   '((inst movsd
                                      (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
                (define-move-vop ,name :move-arg
                  (,sc descriptor-reg) (,sc)))))
  (frob move-complex-single-float-arg
        complex-single-reg complex-single-stack :single)
  (frob move-complex-double-float-arg
        complex-double-reg complex-double-stack :double))

(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) :target r)
                       (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 ((generate (movinst opinst commutative)
             `(progn
                (cond
                  ((location= x r)
                   (inst ,opinst x y))
                  ((and ,commutative (location= y r))
                   (inst ,opinst y x))
                  ((not (location= r y))
                   (inst ,movinst r x)
                   (inst ,opinst r y))
                  (t
                   (inst ,movinst tmp x)
                   (inst ,opinst tmp y)
                   (inst ,movinst r tmp)))))
           (frob (op sinst sname scost dinst dname dcost commutative)
             `(progn
                (define-vop (,sname single-float-op)
                    (:translate ,op)
                  (:temporary (:sc single-reg) tmp)
                  (:generator ,scost
                    (generate movss ,sinst ,commutative)))
                (define-vop (,dname double-float-op)
                  (:translate ,op)
                  (:temporary (:sc single-reg) tmp)
                  (:generator ,dcost
                    (generate movsd ,dinst ,commutative))))))
  (frob + addss +/single-float 2 addsd +/double-float 2 t)
  (frob - subss -/single-float 2 subsd -/double-float 2 nil)
  (frob * mulss */single-float 4 mulsd */double-float 5 t)
  (frob / divss //single-float 12 divsd //double-float 19 nil))

(define-vop (fsqrt)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate %sqrt)
  (: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)
     (inst sqrtsd y x)))

(macrolet ((frob ((name translate sc type) &body body)
             `(define-vop (,name)
                  (:args (x :scs (,sc)))
                (:results (y :scs (,sc)))
                (:translate ,translate)
                (:policy :fast-safe)
                (:arg-types ,type)
                (:result-types ,type)
                (:temporary (:sc any-reg) hex8)
                (:temporary
                 (:sc ,sc) xmm)
                (:note "inline float arithmetic")
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 1
                            (note-this-location vop :internal-error)
                            ;; we should be able to do this better.  what we
                            ;; really would like to do is use the target as the
                            ;; temp whenever it's not also the source
                            (unless (location= x y)
                              (inst movq y x))
                            ,@body))))
  (frob (%negate/double-float %negate double-reg double-float)
        (inst lea hex8 (make-ea :qword :disp 1))
        (inst ror hex8 1)               ; #x8000000000000000
        (inst movd xmm hex8)
        (inst xorpd y xmm))
  (frob (%negate/single-float %negate single-reg single-float)
        (inst lea hex8 (make-ea :qword :disp 1))
        (inst rol hex8 31)
        (inst movd xmm hex8)
        (inst xorps y xmm))
  (frob (abs/double-float abs  double-reg double-float)
        (inst mov hex8 -1)
        (inst shr hex8 1)
        (inst movd xmm hex8)
        (inst andpd y xmm))
  (frob (abs/single-float abs  single-reg single-float)
        (inst mov hex8 -1)
        (inst shr hex8 33)
        (inst movd xmm hex8)
        (inst andps y xmm)))

;;;; comparison

(define-vop (float-compare)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison"))

;;; comiss and comisd can cope with one or other arg in memory: we
;;; could (should, indeed) extend these to cope with descriptor args
;;; and stack args

(define-vop (single-float-compare float-compare)
  (:args (x :scs (single-reg)) (y :scs (single-reg)))
  (:conditional)
  (:arg-types single-float single-float))
(define-vop (double-float-compare float-compare)
  (:args (x :scs (double-reg)) (y :scs (double-reg)))
  (:conditional)
  (:arg-types double-float double-float))

(define-vop (=/single-float single-float-compare)
    (:translate =)
  (:info target not-p)
  (:vop-var vop)
  (:generator 3
    (note-this-location vop :internal-error)
    (inst comiss x y)
    ;; if PF&CF, there was a NaN involved => not equal
    ;; otherwise, ZF => equal
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :ne target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :e target)
             (emit-label not-lab))))))

(define-vop (=/double-float double-float-compare)
    (:translate =)
  (:info target not-p)
  (:vop-var vop)
  (:generator 3
    (note-this-location vop :internal-error)
    (inst comisd x y)
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :ne target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :e target)
             (emit-label not-lab))))))

(define-vop (<double-float double-float-compare)
  (:translate <)
  (:info target not-p)
  (:generator 3
    (inst comisd x y)
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :nc target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :c target)
             (emit-label not-lab))))))

(define-vop (<single-float single-float-compare)
  (:translate <)
  (:info target not-p)
  (:generator 3
    (inst comiss x y)
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :nc target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :c target)
             (emit-label not-lab))))))

(define-vop (>double-float double-float-compare)
  (:translate >)
  (:info target not-p)
  (:generator 3
    (inst comisd x y)
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :na target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :a target)
             (emit-label not-lab))))))

(define-vop (>single-float single-float-compare)
  (:translate >)
  (:info target not-p)
  (:generator 3
    (inst comiss x y)
    (cond (not-p
           (inst jmp :p target)
           (inst jmp :na target))
          (t
           (let ((not-lab (gen-label)))
             (inst jmp :p not-lab)
             (inst jmp :a target)
             (emit-label not-lab))))))



;;;; conversion

(macrolet ((frob (name translate inst to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (signed-stack signed-reg) :target temp))
                (:temporary (:sc signed-stack) 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
                  (sc-case x
                    (signed-reg
                     (inst mov temp x)
                     (note-this-location vop :internal-error)
                     (inst ,inst y temp))
                    (signed-stack
                     (note-this-location vop :internal-error)
                     (inst ,inst y x)))))))
  (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
  (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))

(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
             `(define-vop (,name)