float.lisp

开源跨平台Lisp编译器

  (:policy :fast-safe)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases.
    (cond
     ;; y is ST0.
     ((and (sc-is y single-reg) (zerop (tn-offset y)))
      (sc-case x
        (single-reg
         (inst fcom x))
        ((single-stack descriptor-reg)
         (if (sc-is x single-stack)
             (inst fcom (ea-for-sf-stack x))
           (inst fcom (ea-for-sf-desc x)))))
      (inst fnstsw)                     ; status word to ax
      (inst and ah-tn #x45)
      (inst cmp ah-tn #x01))

     ;; general case when y is not in ST0
     (t
      ;; x to ST0
      (sc-case x
         (single-reg
          (unless (zerop (tn-offset x))
                  (copy-fp-reg-to-fr0 x)))
         ((single-stack descriptor-reg)
          (inst fstp fr0)
          (if (sc-is x single-stack)
              (inst fld (ea-for-sf-stack x))
            (inst fld (ea-for-sf-desc x)))))
      (sc-case y
        (single-reg
         (inst fcom y))
        ((single-stack descriptor-reg)
         (if (sc-is y single-stack)
             (inst fcom (ea-for-sf-stack y))
           (inst fcom (ea-for-sf-desc y)))))
      (inst fnstsw)                     ; status word to ax
      (inst and ah-tn #x45)))
    (inst jmp (if not-p :ne :e) target)))

(define-vop (>double-float)
  (:translate >)
  (:args (x :scs (double-reg double-stack descriptor-reg))
         (y :scs (double-reg double-stack descriptor-reg)))
  (:arg-types double-float double-float)
  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases.
    (cond
     ;; y is ST0.
     ((and (sc-is y double-reg) (zerop (tn-offset y)))
      (sc-case x
        (double-reg
         (inst fcomd x))
        ((double-stack descriptor-reg)
         (if (sc-is x double-stack)
             (inst fcomd (ea-for-df-stack x))
           (inst fcomd (ea-for-df-desc x)))))
      (inst fnstsw)                     ; status word to ax
      (inst and ah-tn #x45)
      (inst cmp ah-tn #x01))

     ;; general case when y is not in ST0
     (t
      ;; x to ST0
      (sc-case x
         (double-reg
          (unless (zerop (tn-offset x))
                  (copy-fp-reg-to-fr0 x)))
         ((double-stack descriptor-reg)
          (inst fstp fr0)
          (if (sc-is x double-stack)
              (inst fldd (ea-for-df-stack x))
            (inst fldd (ea-for-df-desc x)))))
      (sc-case y
        (double-reg
         (inst fcomd y))
        ((double-stack descriptor-reg)
         (if (sc-is y double-stack)
             (inst fcomd (ea-for-df-stack y))
           (inst fcomd (ea-for-df-desc y)))))
      (inst fnstsw)                     ; status word to ax
      (inst and ah-tn #x45)))
    (inst jmp (if not-p :ne :e) target)))

#!+long-float
(define-vop (>long-float)
  (:translate >)
  (:args (x :scs (long-reg))
         (y :scs (long-reg)))
  (:arg-types long-float long-float)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    (cond
      ;; y is in ST0; x is in any reg.
      ((zerop (tn-offset y))
       (inst fcomd x)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45)
       (inst cmp ah-tn #x01))
      ;; x is in ST0; y is in another reg.
      ((zerop (tn-offset x))
       (inst fcomd y)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45))
      ;; y and x are the same register, not ST0
      ;; y and x are different registers, neither ST0.
      (t
       (inst fxch x)
       (inst fcomd y)
       (inst fxch x)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45)))
    (inst jmp (if not-p :ne :e) target)))

;;; Comparisons with 0 can use the FTST instruction.

(define-vop (float-test)
  (:args (x))
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p y)
  (:variant-vars code)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp y)
  (:generator 2
     (note-this-location vop :internal-error)
     (cond
      ;; x is in ST0
      ((zerop (tn-offset x))
       (inst ftst))
      ;; x not ST0
      (t
       (inst fxch x)
       (inst ftst)
       (inst fxch x)))
     (inst fnstsw)                      ; status word to ax
     (inst and ah-tn #x45)              ; C3 C2 C0
     (unless (zerop code)
        (inst cmp ah-tn code))
     (inst jmp (if not-p :ne :e) target)))

(define-vop (=0/single-float float-test)
  (:translate =)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x40))
(define-vop (=0/double-float float-test)
  (:translate =)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x40))
#!+long-float
(define-vop (=0/long-float float-test)
  (:translate =)
  (:args (x :scs (long-reg)))
  (:arg-types long-float (:constant (long-float 0l0 0l0)))
  (:variant #x40))

(define-vop (<0/single-float float-test)
  (:translate <)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x01))
(define-vop (<0/double-float float-test)
  (:translate <)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x01))
#!+long-float
(define-vop (<0/long-float float-test)
  (:translate <)
  (:args (x :scs (long-reg)))
  (:arg-types long-float (:constant (long-float 0l0 0l0)))
  (:variant #x01))

(define-vop (>0/single-float float-test)
  (:translate >)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x00))
(define-vop (>0/double-float float-test)
  (:translate >)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x00))
#!+long-float
(define-vop (>0/long-float float-test)
  (:translate >)
  (:args (x :scs (long-reg)))
  (:arg-types long-float (:constant (long-float 0l0 0l0)))
  (:variant #x00))

#!+long-float
(deftransform eql ((x y) (long-float long-float))
  `(and (= (long-float-low-bits x) (long-float-low-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 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)
                     (with-empty-tn@fp-top(y)
                       (note-this-location vop :internal-error)
                       (inst fild temp)))
                    (signed-stack
                     (with-empty-tn@fp-top(y)
                       (note-this-location vop :internal-error)
                       (inst fild x))))))))
  (frob %single-float/signed %single-float single-reg single-float)
  (frob %double-float/signed %double-float double-reg double-float)
  #!+long-float
  (frob %long-float/signed %long-float long-reg long-float))

(macrolet ((frob (name translate to-sc to-type)
             `(define-vop (,name)
                (:args (x :scs (unsigned-reg)))
                (: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 6
                 (inst push 0)
                 (inst push x)
                 (with-empty-tn@fp-top(y)
                   (note-this-location vop :internal-error)
                   (inst fildl (make-ea :dword :base esp-tn)))
                 (inst add esp-tn 8)))))
  (frob %single-float/unsigned %single-float single-reg single-float)
  (frob %double-float/unsigned %double-float double-reg double-float)
  #!+long-float
  (frob %long-float/unsigned %long-float long-reg long-float))

;;; These should be no-ops but the compiler might want to move some
;;; things around.
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
             `(define-vop (,name)
               (:args (x :scs (,from-sc) :target y))
               (: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)
                (unless (location= x y)
                  (cond
                   ((zerop (tn-offset x))
                    ;; x is in ST0, y is in another reg. not ST0
                    (inst fst  y))
                   ((zerop (tn-offset y))
                    ;; y is in ST0, x is in another reg. not ST0
                    (copy-fp-reg-to-fr0 x))
                   (t
                    ;; Neither x or y are in ST0, and they are not in
                    ;; the same reg.
                    (inst fxch x)
                    (inst fst  y)
                    (inst fxch x))))))))

  (frob %single-float/double-float %single-float double-reg
        double-float single-reg single-float)
  #!+long-float
  (frob %single-float/long-float %single-float long-reg
        long-float single-reg single-float)
  (frob %double-float/single-float %double-float single-reg single-float
        double-reg double-float)
  #!+long-float
  (frob %double-float/long-float %double-float long-reg long-float
        double-reg double-float)
  #!+long-float
  (frob %long-float/single-float %long-float single-reg single-float
        long-reg long-float)
  #!+long-float
  (frob %long-float/double-float %long-float double-reg double-float
        long-reg long-float))

(macrolet ((frob (trans from-sc from-type round-p)
             `(define-vop (,(symbolicate trans "/" from-type))
               (:args (x :scs (,from-sc)))
               (:temporary (:sc signed-stack) stack-temp)
               ,@(unless round-p
                       '((:temporary (:sc unsigned-stack) scw)
                         (:temporary (:sc any-reg) rcw)))
               (: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
                ,@(unless round-p
                   '((note-this-location vop :internal-error)
                     ;; Catch any pending FPE exceptions.
                     (inst wait)))
                (,(if round-p 'progn 'pseudo-atomic)
                 ;; Normal mode (for now) is "round to best".
                 (with-tn@fp-top (x)
                   ,@(unless round-p
                     '((inst fnstcw scw) ; save current control word
                       (move rcw scw)   ; into 16-bit register
                       (inst or rcw (ash #b11 10)) ; CHOP