float.lisp

开源跨平台Lisp编译器

  (:note "inline complex single-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-single-reg
       (let ((r-real (complex-single-reg-real-tn r)))
         (unless (location= real r-real)
           (inst fmovs r-real real)))
       (let ((r-imag (complex-single-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (inst fmovs r-imag imag))))
      (complex-single-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (unless (location= real r)
           (inst stf real nfp offset))
         (inst stf imag nfp (+ offset n-word-bytes)))))))

(define-vop (make-complex-double-float)
  (:translate complex)
  (:args (real :scs (double-reg) :target r
               :load-if (not (location= real r)))
         (imag :scs (double-reg) :to :save))
  (:arg-types double-float double-float)
  (:results (r :scs (complex-double-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-double-stack))))
  (:result-types complex-double-float)
  (:note "inline complex double-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-double-reg
       (let ((r-real (complex-double-reg-real-tn r)))
         (unless (location= real r-real)
           (move-double-reg r-real real)))
       (let ((r-imag (complex-double-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (move-double-reg r-imag imag))))
      (complex-double-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (unless (location= real r)
           (inst stdf real nfp offset))
         (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))

#!+long-float
(define-vop (make-complex-long-float)
  (:translate complex)
  (:args (real :scs (long-reg) :target r
               :load-if (not (location= real r)))
         (imag :scs (long-reg) :to :save))
  (:arg-types long-float long-float)
  (:results (r :scs (complex-long-reg) :from (:argument 0)
               :load-if (not (sc-is r complex-long-stack))))
  (:result-types complex-long-float)
  (:note "inline complex long-float creation")
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case r
      (complex-long-reg
       (let ((r-real (complex-long-reg-real-tn r)))
         (unless (location= real r-real)
           (move-long-reg r-real real)))
       (let ((r-imag (complex-long-reg-imag-tn r)))
         (unless (location= imag r-imag)
           (move-long-reg r-imag imag))))
      (complex-long-stack
       (let ((nfp (current-nfp-tn vop))
             (offset (* (tn-offset r) n-word-bytes)))
         (unless (location= real r)
           (store-long-reg real nfp offset))
         (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))

(define-vop (complex-single-float-value)
  (:args (x :scs (complex-single-reg) :target r
            :load-if (not (sc-is x complex-single-stack))))
  (:arg-types complex-single-float)
  (:results (r :scs (single-reg)))
  (:result-types single-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-single-reg
       (let ((value-tn (ecase slot
                         (:real (complex-single-reg-real-tn x))
                         (:imag (complex-single-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (inst fmovs r value-tn))))
      (complex-single-stack
       (inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
                                              (tn-offset x))
                                           n-word-bytes))))))

(define-vop (realpart/complex-single-float complex-single-float-value)
  (:translate realpart)
  (:note "complex single float realpart")
  (:variant :real))

(define-vop (imagpart/complex-single-float complex-single-float-value)
  (:translate imagpart)
  (:note "complex single float imagpart")
  (:variant :imag))

(define-vop (complex-double-float-value)
  (:args (x :scs (complex-double-reg) :target r
            :load-if (not (sc-is x complex-double-stack))))
  (:arg-types complex-double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    (sc-case x
      (complex-double-reg
       (let ((value-tn (ecase slot
                         (:real (complex-double-reg-real-tn x))
                         (:imag (complex-double-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (move-double-reg r value-tn))))
      (complex-double-stack
       (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
                                               (tn-offset x))
                                            n-word-bytes))))))

(define-vop (realpart/complex-double-float complex-double-float-value)
  (:translate realpart)
  (:note "complex double float realpart")
  (:variant :real))

(define-vop (imagpart/complex-double-float complex-double-float-value)
  (:translate imagpart)
  (:note "complex double float imagpart")
  (:variant :imag))

#!+long-float
(define-vop (complex-long-float-value)
  (:args (x :scs (complex-long-reg) :target r
            :load-if (not (sc-is x complex-long-stack))))
  (:arg-types complex-long-float)
  (:results (r :scs (long-reg)))
  (:result-types long-float)
  (:variant-vars slot)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case x
      (complex-long-reg
       (let ((value-tn (ecase slot
                         (:real (complex-long-reg-real-tn x))
                         (:imag (complex-long-reg-imag-tn x)))))
         (unless (location= value-tn r)
           (move-long-reg r value-tn))))
      (complex-long-stack
       (load-long-reg r (current-nfp-tn vop)
                      (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
                         n-word-bytes))))))

#!+long-float
(define-vop (realpart/complex-long-float complex-long-float-value)
  (:translate realpart)
  (:note "complex long float realpart")
  (:variant :real))

#!+long-float
(define-vop (imagpart/complex-long-float complex-long-float-value)
  (:translate imagpart)
  (:note "complex long float imagpart")
  (:variant :imag))



;;;; Complex float arithmetic

#!+complex-fp-vops
(progn

;; Negate a complex
(macrolet
    ((frob (float-type fneg cost)
       (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
              (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
              (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
         `(define-vop (,vop-name)
            (:args (x :scs (,complex-reg)))
            (:arg-types ,c-type)
            (:results (r :scs (,complex-reg)))
            (:result-types ,c-type)
            (:policy :fast-safe)
            (:note "inline complex float arithmetic")
            (:translate %negate)
            (:generator ,cost
              (let ((xr (,real-tn x))
                    (xi (,imag-tn x))
                    (rr (,real-tn r))
                    (ri (,imag-tn r)))
                (,@fneg rr xr)
                (,@fneg ri xi)))))))
  (frob single (inst fnegs) 4)
  (frob double (negate-double-reg) 4))

;; Add and subtract for two complex arguments
(macrolet
    ((frob (op inst float-type cost)
       (let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
         `(define-vop (,vop-name)
           (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
           (:results (r :scs (,complex-reg)))
           (:arg-types ,c-type ,c-type)
           (:result-types ,c-type)
           (:policy :fast-safe)
           (:note "inline complex float arithmetic")
           (:translate ,op)
           (:generator ,cost
            (let ((xr (,real-part x))
                  (xi (,imag-part x))
                  (yr (,real-part y))
                  (yi (,imag-part y))
                  (rr (,real-part r))
                  (ri (,imag-part r)))
              (inst ,inst rr xr yr)
              (inst ,inst ri xi yi)))))))
  (frob + fadds single 4)
  (frob + faddd double 4)
  (frob - fsubs single 4)
  (frob - fsubd double 4))

;; Add and subtract a complex and a float

(macrolet
    ((frob (size op fop fmov cost)
       (let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
                                    op
                                    "-" size "-FLOAT"))
             (complex-reg (symbolicate "COMPLEX-" size "-REG"))
             (real-reg (symbolicate size "-REG"))
             (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
             (r-type (symbolicate size "-FLOAT"))
             (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
             (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
         `(define-vop (,vop-name)
              (:args (x :scs (,complex-reg))
                     (y :scs (,real-reg)))
            (:results (r :scs (,complex-reg)))
            (:arg-types ,c-type ,r-type)
            (:result-types ,c-type)
            (:policy :fast-safe)
            (:note "inline complex float/float arithmetic")
            (:translate ,op)
            (:generator ,cost
              (let ((xr (,real-part x))
                    (xi (,imag-part x))
                    (rr (,real-part r))
                    (ri (,imag-part r)))
                (inst ,fop rr xr y)
                (unless (location= ri xi)
                  (,@fmov ri xi))))))))

  (frob single + fadds (inst fmovs) 2)
  (frob single - fsubs (inst fmovs) 2)
  (frob double + faddd (move-double-reg) 4)
  (frob double - fsubd (move-double-reg) 4))

;; Add a float and a complex
(macrolet
    ((frob (size fop fmov cost)
       (let ((vop-name
              (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
             (complex-reg (symbolicate "COMPLEX-" size "-REG"))
             (real-reg (symbolicate size "-REG"))
             (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
             (r-type (symbolicate size "-FLOAT"))
             (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
             (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
         `(define-vop (,vop-name)
              (:args (y :scs (,real-reg))
                     (x :scs (,complex-reg)))
            (:results (r :scs (,complex-reg)))
            (:arg-types ,r-type ,c-type)
            (:result-types ,c-type)
            (:policy :fast-safe)
            (:note "inline complex float/float arithmetic")
            (:translate +)
            (:generator ,cost
              (let ((xr (,real-part x))
                    (xi (,imag-part x))
                    (rr (,real-part r))
                    (ri (,imag-part r)))
                (inst ,fop rr xr y)
                (unless (location= ri xi)
                  (,@fmov ri xi))))))))
  (frob single fadds (inst fmovs) 1)
  (frob double faddd (move-double-reg) 2))

;; Subtract a complex from a float

(macrolet
    ((frob (size fop fneg cost)
       (let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
             (complex-reg (symbolicate "COMPLEX-" size "-REG"))
             (real-reg (symbolicate size "-REG"))
             (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
             (r-type (symbolicate size "-FLOAT"))
             (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
             (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
         `(define-vop (single-float---complex-single-float)
              (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
            (:results (r :scs (,complex-reg)))
            (:arg-types ,r-type ,c-type)
            (:result-types ,c-type)
            (:policy :fast-safe)
            (:note "inline complex float/float arithmetic")
            (:translate -)
            (:generator ,cost
               (let ((yr (,real-part y))
                     (yi (,imag-part y))
                     (rr (,real-part r))
                     (ri (,imag-part r)))
                 (inst ,fop rr x yr)
                 (,@fneg ri yi))))
       ))

  (frob single fsubs (inst fnegs) 2)
  (frob double fsubd (negate-double-reg) 2)))

;; Multiply two complex numbers

#+nil
(macrolet
    ((frob (size fmul fadd fsub cost)
       (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
             (complex-reg (symbolicate "COMPLEX-" size "-REG"))
             (real-reg (symbolicate size "-REG"))
             (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
             (real-part (symbolicate "COMPLEX-" si