- `(progn
- (define-vop (,vop)
- (:args (x :scs (,sc)
- :target y
- :load-if (not (location= x y))))
- (:results (y :scs (,sc)
- :load-if (not (location= x y))))
- (:note "float move")
- (:generator 0
- (unless (location= y x)
- ,@(ecase format
- (:single `((inst fmovs y x)))
- (:double `((move-double-reg y x)))
- (:long `((move-long-reg y x)))))))
- (define-move-vop ,vop :move (,sc) (,sc)))))
+ `(progn
+ (define-vop (,vop)
+ (:args (x :scs (,sc)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (,sc)
+ :load-if (not (location= x y))))
+ (:note "float move")
+ (:generator 0
+ (unless (location= y x)
+ ,@(ecase format
+ (:single `((inst fmovs y x)))
+ (:double `((move-double-reg y x)))
+ (:long `((move-long-reg y x)))))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (nfp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float argument move")
- (:generator ,(ecase format (:single 1) (:double 2))
- (sc-case y
- (,sc
- (unless (location= x y)
- ,@(ecase format
- (:single '((inst fmovs y x)))
- (:double '((move-double-reg y x))))))
- (,stack-sc
- (let ((offset (* (tn-offset y) n-word-bytes)))
- (inst ,(ecase format
- (:single 'stf)
- (:double 'stdf))
- x nfp offset))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(ecase format (:single 1) (:double 2))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ ,@(ecase format
+ (:single '((inst fmovs y x)))
+ (:double '((move-double-reg y x))))))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (inst ,(ecase format
+ (:single 'stf)
+ (:double 'stdf))
+ x nfp offset))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
- `(progn
- (define-vop (,sname single-float-compare)
- (:translate ,translate)
- (:variant :single ,yep ,nope))
- (define-vop (,dname double-float-compare)
- (:translate ,translate)
- (:variant :double ,yep ,nope))
- #!+long-float
- (define-vop (,lname long-float-compare)
- (:translate ,translate)
- (:variant :long ,yep ,nope)))))
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant :single ,yep ,nope))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant :double ,yep ,nope))
+ #!+long-float
+ (define-vop (,lname long-float-compare)
+ (:translate ,translate)
+ (:variant :long ,yep ,nope)))))
- `(define-vop (,name)
- (:args (x :scs (signed-reg) :target stack-temp
- :load-if (not (sc-is x signed-stack))))
- (:temporary (:scs (single-stack) :from :argument) stack-temp)
- (:temporary (:scs (single-reg) :to :result :target y) 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 st x
- (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes))
- stack-temp)
- (signed-stack
- x))))
- (inst ldf temp
- (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
- (note-this-location vop :internal-error)
- (inst ,inst y temp))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg) :target stack-temp
+ :load-if (not (sc-is x signed-stack))))
+ (:temporary (:scs (single-stack) :from :argument) stack-temp)
+ (:temporary (:scs (single-reg) :to :result :target y) 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 st x
+ (current-nfp-tn vop)
+ (* (tn-offset temp) n-word-bytes))
+ stack-temp)
+ (signed-stack
+ x))))
+ (inst ldf temp
+ (current-nfp-tn vop)
+ (* (tn-offset stack-tn) n-word-bytes))
+ (note-this-location vop :internal-error)
+ (inst ,inst y temp))))))
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (: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)
- (inst ,inst y x)))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (: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)
+ (inst ,inst y x)))))
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc) :target temp))
- (:temporary (:from (: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 temp x)
- (sc-case y
- (signed-stack
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset y) n-word-bytes)))
- (signed-reg
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ld y (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))))))))
- (frob %unary-truncate single-reg single-float fstoi)
- (frob %unary-truncate double-reg double-float fdtoi)
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from (: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 temp x)
+ (sc-case y
+ (signed-stack
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset y) n-word-bytes)))
+ (signed-reg
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld y (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))))))))
+ (frob %unary-truncate/single-float single-reg single-float fstoi)
+ (frob %unary-truncate/double-float double-reg double-float fdtoi)
- (inst ldx my-fsr nfp offset)
- ;; Carefully merge in the new mode bits with the rest of the
- ;; FSR. This is only needed if we care about preserving the
- ;; high 32 bits of the FSR, which contain the additional
- ;; %fcc's on the sparc V9. If not, we don't need this, but we
- ;; do need to make sure that the unused bits are written as
- ;; zeroes, according the V9 architecture manual.
- (inst sra new 0)
- (inst srlx my-fsr 32)
- (inst sllx my-fsr 32)
- (inst or my-fsr new)
- ;; Save it back and load it into the fsr register
- (inst stx my-fsr nfp offset)
- (inst ldxfsr nfp offset)
- (move res new)))))
+ (inst ldx my-fsr nfp offset)
+ ;; Carefully merge in the new mode bits with the rest of the
+ ;; FSR. This is only needed if we care about preserving the
+ ;; high 32 bits of the FSR, which contain the additional
+ ;; %fcc's on the sparc V9. If not, we don't need this, but we
+ ;; do need to make sure that the unused bits are written as
+ ;; zeroes, according the V9 architecture manual.
+ (inst sra new 0)
+ (inst srlx my-fsr 32)
+ (inst sllx my-fsr 32)
+ (inst or my-fsr new)
+ ;; Save it back and load it into the fsr register
+ (inst stx my-fsr nfp offset)
+ (inst ldxfsr nfp offset)
+ (move res new)))))
- (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)))))))
+ (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)))))))
- (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)))))))
+ (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)))))))
- 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))))))))
-
+ 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))))))))
+
- (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))))))))
+ (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))))))))
- (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))))
+ (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))))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" 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 (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
- (: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)))
- ;; All of the temps are needed in case the result TN happens to
- ;; be the same as one of the arg TN's
- (inst ,fmul prod-1 xr yr)
- (inst ,fmul prod-2 xi yi)
- (inst ,fmul prod-3 xr yi)
- (inst ,fmul prod-4 xi yr)
- (inst ,fsub rr prod-1 prod-2)
- (inst ,fadd ri prod-3 prod-4)))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" 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 (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
+ (: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)))
+ ;; All of the temps are needed in case the result TN happens to
+ ;; be the same as one of the arg TN's
+ (inst ,fmul prod-1 xr yr)
+ (inst ,fmul prod-2 xi yi)
+ (inst ,fmul prod-3 xr yi)
+ (inst ,fmul prod-4 xi yr)
+ (inst ,fsub rr prod-1 prod-2)
+ (inst ,fadd ri prod-3 prod-4)))))))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" 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 (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) p1 p2)
- (: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)))
- (cond ((location= r x)
- (inst ,fmul p1 xr yr)
- (inst ,fmul p2 xr yi)
- (inst ,fmul rr xi yi)
- (inst ,fsub rr p1 xr)
- (inst ,fmul p1 xi yr)
- (inst ,fadd ri p2 p1))
- ((location= r y)
- (inst ,fmul p1 yr xr)
- (inst ,fmul p2 yr xi)
- (inst ,fmul rr yi xi)
- (inst ,fsub rr p1 rr)
- (inst ,fmul p1 yi xr)
- (inst ,fadd ri p2 p1))
- (t
- (inst ,fmul rr yr xr)
- (inst ,fmul ri xi yi)
- (inst ,fsub rr rr ri)
- (inst ,fmul p1 xr yi)
- (inst ,fmul ri xi yr)
- (inst ,fadd ri ri p1)))))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" 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 (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) p1 p2)
+ (: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)))
+ (cond ((location= r x)
+ (inst ,fmul p1 xr yr)
+ (inst ,fmul p2 xr yi)
+ (inst ,fmul rr xi yi)
+ (inst ,fsub rr p1 xr)
+ (inst ,fmul p1 xi yr)
+ (inst ,fadd ri p2 p1))
+ ((location= r y)
+ (inst ,fmul p1 yr xr)
+ (inst ,fmul p2 yr xi)
+ (inst ,fmul rr yi xi)
+ (inst ,fsub rr p1 rr)
+ (inst ,fmul p1 yi xr)
+ (inst ,fadd ri p2 p1))
+ (t
+ (inst ,fmul rr yr xr)
+ (inst ,fmul ri xi yi)
+ (inst ,fsub rr rr ri)
+ (inst ,fmul p1 xr yi)
+ (inst ,fmul ri xi yr)
+ (inst ,fadd ri ri p1)))))))))
- float-type
- "-FLOAT-*-"
- float-type
- "-FLOAT"))
- (vop-name-r (symbolicate float-type
- "-FLOAT-*-COMPLEX-"
- float-type
- "-FLOAT"))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; Complex * float
- (define-vop (,vop-name)
- (:args (x :scs (,complex-sc-type))
- (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))
- ;; Float * complex
- (define-vop (,vop-name-r)
- (:args (y :scs (,real-sc-type))
- (x :scs (,complex-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))))))
+ float-type
+ "-FLOAT-*-"
+ float-type
+ "-FLOAT"))
+ (vop-name-r (symbolicate float-type
+ "-FLOAT-*-COMPLEX-"
+ float-type
+ "-FLOAT"))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; Complex * float
+ (define-vop (,vop-name)
+ (:args (x :scs (,complex-sc-type))
+ (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))
+ ;; Float * complex
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,real-sc-type))
+ (x :scs (,complex-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))))))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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 division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (: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))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp-r ratio xi)
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xr)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
- (inst b done)
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp-r ratio xr)
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xi)
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label done)
- (unless (location= temp-r rr)
- (,@fmov rr temp-r))
- (unless (location= temp-i ri)
- (,@fmov ri temp-i))
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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 division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (: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))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xr)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+ (inst b done)
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xi)
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label done)
+ (unless (location= temp-r rr)
+ (,@fmov rr temp-r))
+ (unless (location= temp-i ri)
+ (,@fmov ri temp-i))
+ ))))))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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 division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (: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))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fmul temp-r ratio xi)
- (inst ,fmul temp-i ratio xr)
-
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst b done)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
-
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fmul temp-r ratio xr)
- (inst ,fmul temp-i ratio xi)
-
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
-
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
-
- (emit-label done)
-
- (inst ,fdiv rr temp-r den)
- (inst ,fdiv ri temp-i den)
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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 division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (: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))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fmul temp-i ratio xr)
+
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst b done)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fmul temp-i ratio xi)
+
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+
+ (emit-label done)
+
+ (inst ,fdiv rr temp-r den)
+ (inst ,fdiv ri temp-i den)
+ ))))))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (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-sc-type)) (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate /)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fdiv rr xr y) ; xr * y
- (inst ,fdiv ri xi y) ; xi * yi
- ))))))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (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-sc-type)) (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate /)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fdiv rr xr y) ; xr * y
+ (inst ,fdiv ri xi y) ; xi * yi
+ ))))))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (r-type (symbolicate float-type "-FLOAT"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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 (,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 division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp)
- (:generator ,cost
- (let ((yr (,real-tn y))
- (yi (,imag-tn y))
- (rr (,real-tn r))
- (ri (,imag-tn r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
- (inst ,fdiv rr x den) ; rr = x/den
- (inst b done)
- (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
- (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
- (inst ,fdiv temp x den) ; temp = x/den
- (emit-label done)
-
- (,@fneg ri temp)))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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 (,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 division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp)
+ (:generator ,cost
+ (let ((yr (,real-tn y))
+ (yi (,imag-tn y))
+ (rr (,real-tn r))
+ (ri (,imag-tn r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
+ (inst ,fdiv rr x den) ; rr = x/den
+ (inst b done)
+ (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
+ (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
+ (inst ,fdiv temp x den) ; temp = x/den
+ (emit-label done)
+
+ (,@fneg ri temp)))))))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex conjugate")
- (:translate conjugate)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (,@fneg ri xi)
- (unless (location= rr xr)
- (,@fmov rr xr))))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex conjugate")
+ (:translate conjugate)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (,@fneg ri xi)
+ (unless (location= rr xr)
+ (,@fmov rr xr))))))))
- (symbolicate "COMPLEX-" float-type "-FLOAT-"
- float-type "-FLOAT-COMPARE"))
- (vop-name-r
- (symbolicate float-type "-FLOAT-COMPLEX-"
- float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; (= float complex)
- (define-vop (,vop-name)
- (:args (x :scs (,real-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:translate ,trans-1)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))
- ;; (= complex float)
- (define-vop (,vop-name-r)
- (:args (y :scs (,complex-reg))
- (x :scs (,real-reg)))
- (:arg-types ,c-type ,r-type)
- (:translate ,trans-2)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-"
+ float-type "-FLOAT-COMPARE"))
+ (vop-name-r
+ (symbolicate float-type "-FLOAT-COMPLEX-"
+ float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; (= float complex)
+ (define-vop (,vop-name)
+ (:args (x :scs (,real-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:translate ,trans-1)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))
+ ;; (= complex float)
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,complex-reg))
+ (x :scs (,real-reg)))
+ (:arg-types ,c-type ,r-type)
+ (:translate ,trans-2)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))))))
- (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- (inst ,fcmp xr yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp xi yi)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop)))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ (inst ,fcmp xr yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp xi yi)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop)))))))
- (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (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)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc descriptor-reg) true)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator 5
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- ;; Assume comparison is true
- (load-symbol true t)
- (inst ,fcmp xr yr)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst ,fcmp xi yi)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst cmp true null-tn)
- (inst b (if not-p :eq :ne) target :pt)
- (inst nop)))))))
+ (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (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)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc descriptor-reg) true)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Assume comparison is true
+ (load-symbol true t)
+ (inst ,fcmp xr yr)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst ,fcmp xi yi)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst cmp true null-tn)
+ (inst b (if not-p :eq :ne) target :pt)
+ (inst nop)))))))
- (trans-name (symbolicate "%%" name)))
- `(define-vop (,vop-name)
- (:args (x :scs (,sc-type))
- (y :scs (,sc-type)))
- (:results (r :scs (,sc-type)))
- (:arg-types ,type ,type)
- (:result-types ,type)
- (:policy :fast-safe)
- (:note ,note)
- (:translate ,trans-name)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator ,cost
- (inst ,compare x y)
- (cond ((location= r x)
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,min r y ,cc))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,max r x ,cc))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst ,cmov ,max r x ,cc)
- (inst ,cmov ,min r y ,cc))))))))
+ (trans-name (symbolicate "%%" name)))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,sc-type))
+ (y :scs (,sc-type)))
+ (:results (r :scs (,sc-type)))
+ (:arg-types ,type ,type)
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:note ,note)
+ (:translate ,trans-name)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator ,cost
+ (inst ,compare x y)
+ (cond ((location= r x)
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,min r y ,cc))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,max r x ,cc))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst ,cmov ,max r x ,cc)
+ (inst ,cmov ,min r y ,cc))))))))
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst cmove :l r y :fcc0))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst cmove :ge r x :fcc0))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst cmove :ge r x :fcc0)
- (inst cmove :l r y :fcc0))))))
-
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst cmove :l r y :fcc0))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst cmove :ge r x :fcc0))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst cmove :ge r x :fcc0)
+ (inst cmove :l r y :fcc0))))))
+