float.lisp

开源跨平台Lisp编译器

(define-vop (move-to-complex-double)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (complex-double-reg)))
  (:note "pointer to complex float coercion")
  (:generator 2
    (let ((real-tn (complex-double-reg-real-tn y)))
      (inst ldt real-tn (- (* complex-double-float-real-slot
                              n-word-bytes)
                           other-pointer-lowtag)
            x))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
      (inst ldt imag-tn (- (* complex-double-float-imag-slot
                              n-word-bytes)
                           other-pointer-lowtag)
            x))))
(define-move-vop move-to-complex-double :move
  (descriptor-reg) (complex-double-reg))

;;;
;;; complex float MOVE-ARG VOP
;;;
(define-vop (move-complex-single-float-arg)
  (:args (x :scs (complex-single-reg) :target y)
         (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
  (:results (y))
  (:note "complex single float argument move")
  (:generator 1
    (sc-case y
      (complex-single-reg
       (unless (location= x y)
         (let ((x-real (complex-single-reg-real-tn x))
               (y-real (complex-single-reg-real-tn y)))
           (inst fmove x-real y-real))
         (let ((x-imag (complex-single-reg-imag-tn x))
               (y-imag (complex-single-reg-imag-tn y)))
           (inst fmove x-imag y-imag))))
      (complex-single-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-single-reg-real-tn x)))
           (inst sts real-tn offset nfp))
         (let ((imag-tn (complex-single-reg-imag-tn x)))
           (inst sts imag-tn (+ offset n-word-bytes) nfp)))))))
(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 argument 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 fmove x-real y-real))
         (let ((x-imag (complex-double-reg-imag-tn x))
               (y-imag (complex-double-reg-imag-tn y)))
           (inst fmove x-imag y-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
         (let ((real-tn (complex-double-reg-real-tn x)))
           (inst stt real-tn offset nfp))
         (let ((imag-tn (complex-double-reg-imag-tn x)))
           (inst stt 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))


;;;; float 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))

;;; We need to insure that ops that can cause traps do not clobber an
;;; argument register with invalid results. This so the software trap
;;; handler can re-execute the instruction and produce correct IEEE
;;; result. The :from :load hopefully does that.
(macrolet ((frob (name sc ptype)
             `(define-vop (,name float-op)
                (:args (x :scs (,sc))
                       (y :scs (,sc)))
                (:results (r :scs (,sc) :from :load))
                (:arg-types ,ptype ,ptype)
                (:result-types ,ptype))))
  (frob single-float-op single-reg single-float)
  (frob double-float-op double-reg double-float))

;; This is resumption-safe with underflow traps enabled,
;; with software handling and (notyet) dynamic rounding mode.
(macrolet ((frob (op sinst sname scost dinst dname dcost)
             `(progn
                (define-vop (,sname single-float-op)
                  (:translate ,op)
                  (:variant-cost ,scost)
                  (:generator ,scost
                    (inst ,sinst x y r)
                    (note-this-location vop :internal-error)
                    (inst trapb)))
                (define-vop (,dname double-float-op)
                  (:translate ,op)
                  (:variant-cost ,dcost)
                  (:generator ,dcost
                    (inst ,dinst x y r)
                    (note-this-location vop :internal-error)
                    (inst trapb))))))
  ;; Not sure these cost number are right. +*- about same / is 4x
  (frob + adds_su +/single-float 1 addt_su +/double-float 1)
  (frob - subs_su -/single-float 1 subt_su -/double-float 1)
  (frob * muls_su */single-float 1 mult_su */double-float 1)
  (frob / divs_su //single-float 4 divt_su //double-float 4))

(macrolet ((frob (name inst translate sc type)
             `(define-vop (,name)
                (:args (x :scs (,sc) :target y))
                (: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 x y)))))
  (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))


;;;; float comparison

(define-vop (float-compare)
  (:args (x) (y))
  (:conditional)
  (:info target not-p)
  (:variant-vars eq complement)
  (:temporary (:scs (single-reg)) temp)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (note-this-location vop :internal-error)
    (if eq
        (inst cmpteq x y temp)
        (if complement
            (inst cmptle x y temp)
            (inst cmptlt x y temp)))
    (inst trapb)
    (if (if complement (not not-p) not-p)
        (inst fbeq temp target)
        (inst fbne temp 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 complement sname dname eq)
             `(progn
                (define-vop (,sname single-float-compare)
                  (:translate ,translate)
                  (:variant ,eq ,complement))
                (define-vop (,dname double-float-compare)
                  (:translate ,translate)
                  (:variant ,eq ,complement)))))
  (frob < nil </single-float </double-float nil)
  (frob > t >/single-float >/double-float nil)
  (frob = nil =/single-float =/double-float t))


;;;; float conversion

(macrolet
    ((frob (name translate inst ld-inst to-sc to-type)
           `(define-vop (,name)
              (:args (x :scs (signed-reg) :target temp
                        :load-if (not (sc-is x signed-stack))))
             (:temporary (:scs (,to-sc)) freg1)
             (:temporary (:scs (,to-sc)) freg2)
             (:temporary (:scs (single-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
                          (let ((stack-tn
                                 (sc-case x
                                          (signed-reg
                                           (inst stl x
                                                 (* (tn-offset temp)
                                                    n-word-bytes)
                                                 (current-nfp-tn vop))
                                           temp)
                                          (signed-stack
                                           x))))
                            (inst ,ld-inst freg1
                                  (* (tn-offset stack-tn) n-word-bytes)
                                  (current-nfp-tn vop))
                            (note-this-location vop :internal-error)
                            (inst cvtlq freg1 freg2)
                            (inst ,inst freg2 y)
                            (inst excb)
                            )))))
  (frob %single-float/signed %single-float cvtqs_sui lds single-reg single-float)
  (frob %double-float/signed %double-float cvtqt_sui lds double-reg double-float))

;;; see previous comment about software trap handlers: also applies here
(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) :from :load))
               (: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 x y)
                (inst excb)
                ))))
  (frob %single-float/double-float %single-float cvtts_su
        double-reg double-float single-reg single-float)
  (frob %double-float/single-float %double-float fmove
        single-reg single-float double-reg double-float))

(macrolet
    ((frob (trans from-sc from-type inst &optional single)
       (declare (ignorable single))
       `(define-vop (,(symbolicate trans "/" from-type))
         (:args (x :scs (,from-sc) :target temp))
         (:temporary (:from :load ;(:argument 0)
                      :sc single-reg) temp)
         (:temporary (:scs (signed-stack)) stack-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 "inline float truncate")
         (:vop-var vop)
         (:save-p :compute-only)
         (:generator 5
          (note-this-location vop :internal-error)
          (inst ,inst x temp)
          (sc-case y
           (signed-stack
            (inst stt temp
                  (* (tn-offset y) n-word-bytes)
                  (current-nfp-tn vop)))
           (signed-reg
            (inst stt temp
                  (* (tn-offset stack-temp)
                     n-word-bytes)
                  (current-nfp-tn vop))
            (inst ldq y
                  (* (tn-offset stack-temp) n-word-bytes)
                  (current-nfp-tn vop))))
          (inst excb)
          ))))
  (frob %unary-truncate single-reg single-float cvttq/c_sv t)