float.lisp

开源跨平台Lisp编译器

               (note-next-instruction vop :internal-error)

               ;; Finally save the result.
               (sc-case r
                 (double-reg
                  (cond ((zerop (tn-offset r))
                         (maybe-fp-wait node))
                        (t
                         (inst fst r))))
                 (double-stack
                  (inst fstd (ea-for-df-stack r))))))))

         #!+long-float
         (define-vop (,lname)
           (:translate ,op)
           (:args (x :scs (long-reg) :to :eval)
                  (y :scs (long-reg) :to :eval))
           (:temporary (:sc long-reg :offset fr0-offset
                            :from :eval :to :result) fr0)
           (:results (r :scs (long-reg)))
           (:arg-types long-float long-float)
           (:result-types long-float)
           (:policy :fast-safe)
           (:note "inline float arithmetic")
           (:vop-var vop)
           (:save-p :compute-only)
           (:node-var node)
           (:generator ,lcost
             ;; Handle a few special cases.
             (cond
              ;; x, y, and r are the same register.
              ((and (location= x r) (location= y r))
               (cond ((zerop (tn-offset r))
                      (inst ,fop fr0))
                     (t
                      (inst fxch x)
                      (inst ,fopd fr0)
                      ;; XX the source register will not be valid.
                      (note-next-instruction vop :internal-error)
                      (inst fxch r))))

              ;; x and r are the same register.
              ((location= x r)
               (cond ((zerop (tn-offset r))
                      ;; ST(0) = ST(0) op ST(y)
                      (inst ,fopd y))
                     (t
                      ;; y to ST0
                      (unless (zerop (tn-offset y))
                        (copy-fp-reg-to-fr0 y))
                      ;; ST(i) = ST(i) op ST0
                      (inst ,fop-sti r)))
               (maybe-fp-wait node vop))
              ;; y and r are the same register.
              ((location= y r)
               (cond ((zerop (tn-offset r))
                      ;; ST(0) = ST(x) op ST(0)
                      (inst ,foprd x))
                     (t
                      ;; x to ST0
                      (unless (zerop (tn-offset x))
                        (copy-fp-reg-to-fr0 x))
                      ;; ST(i) = ST(0) op ST(i)
                      (inst ,fopr-sti r)))
               (maybe-fp-wait node vop))
              ;; the default case
              (t
               ;; Get the result to ST0.

               ;; Special handling is needed if x or y are in ST0, and
               ;; simpler code is generated.
               (cond
                ;; x is in ST0.
                ((zerop (tn-offset x))
                 ;; ST0 = ST0 op y
                 (inst ,fopd y))
                ;; y is in ST0
                ((zerop (tn-offset y))
                 ;; ST0 = x op ST0
                 (inst ,foprd x))
                (t
                 ;; x to ST0
                 (copy-fp-reg-to-fr0 x)
                 ;; ST0 = ST0 op y
                 (inst ,fopd y)))

               (note-next-instruction vop :internal-error)

               ;; Finally save the result.
               (cond ((zerop (tn-offset r))
                      (maybe-fp-wait node))
                     (t
                      (inst fst r))))))))))

    (frob + fadd-sti fadd-sti
          fadd fadd +/single-float 2
          faddd faddd +/double-float 2
          +/long-float 2)
    (frob - fsub-sti fsubr-sti
          fsub fsubr -/single-float 2
          fsubd fsubrd -/double-float 2
          -/long-float 2)
    (frob * fmul-sti fmul-sti
          fmul fmul */single-float 3
          fmuld fmuld */double-float 3
          */long-float 3)
    (frob / fdiv-sti fdivr-sti
          fdiv fdivr //single-float 12
          fdivd fdivrd //double-float 12
          //long-float 12))

(macrolet ((frob (name inst translate sc type)
             `(define-vop (,name)
               (:args (x :scs (,sc) :target fr0))
               (:results (y :scs (,sc)))
               (:translate ,translate)
               (:policy :fast-safe)
               (:arg-types ,type)
               (:result-types ,type)
               (:temporary (:sc double-reg :offset fr0-offset
                                :from :argument :to :result) fr0)
               (:ignore fr0)
               (:note "inline float arithmetic")
               (:vop-var vop)
               (:save-p :compute-only)
               (:generator 1
                (note-this-location vop :internal-error)
                (unless (zerop (tn-offset x))
                  (inst fxch x)         ; x to top of stack
                  (unless (location= x y)
                    (inst fst x)))      ; Maybe save it.
                (inst ,inst)            ; Clobber st0.
                (unless (zerop (tn-offset y))
                  (inst fst y))))))

  (frob abs/single-float fabs abs single-reg single-float)
  (frob abs/double-float fabs abs double-reg double-float)
  #!+long-float
  (frob abs/long-float fabs abs long-reg long-float)
  (frob %negate/single-float fchs %negate single-reg single-float)
  (frob %negate/double-float fchs %negate double-reg double-float)
  #!+long-float
  (frob %negate/long-float fchs %negate long-reg long-float))

;;;; comparison

(define-vop (=/float)
  (:args (x) (y))
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
     (note-this-location vop :internal-error)
     (cond
      ;; x is in ST0; y is in any reg.
      ((zerop (tn-offset x))
       (inst fucom y))
      ;; y is in ST0; x is in another reg.
      ((zerop (tn-offset y))
       (inst fucom x))
      ;; x and y are the same register, not ST0
      ((location= x y)
       (inst fxch x)
       (inst fucom fr0-tn)
       (inst fxch x))
      ;; x and y are different registers, neither ST0.
      (t
       (inst fxch x)
       (inst fucom y)
       (inst fxch x)))
     (inst fnstsw)                      ; status word to ax
     (inst and ah-tn #x45)              ; C3 C2 C0
     (inst cmp ah-tn #x40)
     (inst jmp (if not-p :ne :e) target)))

(define-vop (=/single-float =/float)
  (:translate =)
  (:args (x :scs (single-reg))
         (y :scs (single-reg)))
  (:arg-types single-float single-float))

(define-vop (=/double-float =/float)
  (:translate =)
  (:args (x :scs (double-reg))
         (y :scs (double-reg)))
  (:arg-types double-float double-float))

#!+long-float
(define-vop (=/long-float =/float)
  (:translate =)
  (:args (x :scs (long-reg))
         (y :scs (long-reg)))
  (:arg-types long-float long-float))

(define-vop (<single-float)
  (:translate <)
  (:args (x :scs (single-reg single-stack descriptor-reg))
         (y :scs (single-reg single-stack descriptor-reg)))
  (:arg-types single-float single-float)
  (:temporary (:sc single-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 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))

     ;; 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)             ; C3 C2 C0
      (inst cmp ah-tn #x01)))
    (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))

     ;; 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)             ; C3 C2 C0
      (inst cmp ah-tn #x01)))
    (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
      ;; x is in ST0; y is in any reg.
      ((zerop (tn-offset x))
       (inst fcomd y)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45)            ; C3 C2 C0
       (inst cmp ah-tn #x01))
      ;; y is in ST0; x is in another reg.
      ((zerop (tn-offset y))
       (inst fcomd x)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45))
      ;; x and y are the same register, not ST0
      ;; x and y are different registers, neither ST0.
      (t
       (inst fxch y)
       (inst fcomd x)
       (inst fxch y)
       (inst fnstsw)                    ; status word to ax
       (inst and ah-tn #x45)))          ; C3 C2 C0
    (inst jmp (if not-p :ne :e) target)))

(define-vop (>single-float)
  (:translate >)
  (:args (x :scs (single-reg single-stack descriptor-reg))
         (y :scs (single-reg single-stack descriptor-reg)))
  (:arg-types single-float single-float)
  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)