From a12698c0f29580259e45aa0a3577b65ca785d301 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 2 Apr 2000 18:44:24 +0000
Subject: [PATCH] From Raymond Toy: o Add complex FP vops, enabled by the
 feature :complex-fp-vop. o Add VOPS for max/min of floats using conditional
 moves for the Sparc V9.

---
 compiler/sparc/float.lisp | 935 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 934 insertions(+), 1 deletion(-)

diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
index 3e8028002..499f3d973 100644
--- a/compiler/sparc/float.lisp
+++ b/compiler/sparc/float.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.28 2000/02/24 14:40:34 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.29 2000/04/02 18:44:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1564,3 +1564,936 @@
   (: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-" 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)))))))
+
+  (frob single fmuls fadds fsubs 6)
+  (frob double fmuld faddd fsubd 6))
+
+(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-" 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)))))))))
+
+  (frob single fmuls fadds fsubs 6)
+  (frob double fmuld faddd fsubd 6))
+
+;; Multiply a complex by a float.  The case of float * complex is
+;; handled by a deftransform to convert it to the complex*float case.
+(macrolet
+    ((frob (float-type fmul mov cost)
+       (let* ((vop-name (symbolicate "COMPLEX-"
+				     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))))))))))
+  (frob single fmuls (inst fmovs) 4)
+  (frob double fmuld (move-double-reg) 4))
+
+
+;; Divide a complex by a complex
+
+;; Here's how we do a complex division
+;;
+;; Compute (xr + i*xi)/(yr + i*yi)
+;;
+;; Assume |yi| < |yr|.  Then
+;;
+;; (xr + i*xi)      (xr + i*xi)
+;; ----------- = -----------------
+;; (yr + i*yi)   yr*(1 + i*(yi/yr))
+;;
+;;               (xr + i*xi)*(1 - i*(yi/yr))
+;;             = ---------------------------
+;;                   yr*(1 + (yi/yr)^2)
+;;
+;;               (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr)
+;;             = --------------------------------------
+;;                        yr + (yi/yr)*yi
+;;
+;;
+;; We do the similar thing when |yi| > |yr|.  The result is
+;;
+;;     
+;; (xr + i*xi)      (xr + i*xi)
+;; ----------- = -----------------
+;; (yr + i*yi)   yi*((yr/yi) + i)
+;;
+;;               (xr + i*xi)*((yr/yi) - i)
+;;             = -------------------------
+;;                  yi*((yr/yi)^2 + 1)
+;;
+;;               (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr)
+;;             = ---------------------------------------
+;;                       yi + (yr/yi)*yr
+;;
+
+#+nil
+(macrolet
+    ((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost)
+       (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
+	     (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 (backend-featurep :sparc-v9)
+		  (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))
+		))))))
+
+  (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
+  (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
+
+(macrolet
+    ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
+       (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
+	     (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 (backend-featurep :sparc-v9)
+		  (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)
+		))))))
+
+  (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
+  (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
+
+
+;; Divide a complex by a real
+(macrolet
+    ((frob (float-type fdiv cost)
+       (let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" 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")))
+	 `(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
+	      ))))))
+  (frob single fdivs 2)
+  (frob double fdivd 2))
+
+;; Divide a real by a complex
+
+(macrolet
+    ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
+       (let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
+	     (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 (backend-featurep :sparc-v9)
+		  (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)))))))
+
+  (frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
+  (frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
+
+;; Conjugate of a complex number
+
+(macrolet
+    ((frob (float-type fneg fmov cost)
+       (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
+	     (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))))))))
+
+  (frob single (inst fnegs) (inst fmovs) 4)
+  (frob double (negate-double-reg) (move-double-reg) 4))
+
+;; Compare a float with a complex or a complex with a float
+#+nil
+(macrolet
+    ((frob (name name-r f-type c-type)
+       `(progn
+	 (defknown ,name (,f-type ,c-type) t)
+	 (defknown ,name-r (,c-type ,f-type) t)
+	 (defun ,name (x y)
+	   (declare (type ,f-type x)
+		    (type ,c-type y))
+	   (,name x y))
+	 (defun ,name-r (x y)
+	   (declare (type ,c-type x)
+		    (type ,f-type y))
+	   (,name-r x y))
+	 )))
+  (frob %compare-complex-single-single %compare-single-complex-single
+	single-float (complex single-float))
+  (frob %compare-complex-double-double %compare-double-complex-double
+	double-float (complex double-float)))
+	   
+#+nil
+(macrolet
+    ((frob (trans-1 trans-2 float-type fcmp fsub)
+       (let ((vop-name
+	      (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 (not (backend-featurep :sparc-v9)))
+	      (: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 (not (backend-featurep :sparc-v9)))
+	      (: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))))))))
+  (frob %compare-complex-single-single %compare-single-complex-single
+	single fcmps fsubs)
+  (frob %compare-complex-double-double %compare-double-complex-double
+	double fcmpd fsubd))
+
+;; Compare two complex numbers for equality
+(macrolet
+    ((frob (float-type fcmp)
+       (let ((vop-name
+	      (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)
+	    (:guard (not (backend-featurep :sparc-v9)))
+	    (: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)))))))
+  (frob single fcmps)
+  (frob double fcmpd))
+
+;; Compare a complex with a complex, for V9
+(macrolet
+    ((frob (float-type fcmp)
+       (let ((vop-name
+	      (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 (backend-featurep :sparc-v9))
+	    (: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)))
+		;; 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 :icc :pt)
+		(inst nop)))))))
+  (frob single fcmps)
+  (frob double fcmpd))
+
+) ; end progn complex-fp-vops
+
+#+sparc-v9
+(progn
+
+#+nil
+(macrolet
+    ((frob (op type)
+       (let ((name (symbolicate op "-" type)))
+       `(progn
+	 (defknown ,name (,type ,type)
+	   ,type
+	   (movable foldable flushable))
+	 (defun ,name (x y)
+	   (declare (,type x y))
+	   (,name x y))))))
+  (frob %max single-float)
+  (frob %max double-float)
+  (frob %min double-float)
+  (frob %min single-float))
+
+(defknown (%%max %%min) ((or (unsigned-byte 32) (signed-byte 32)
+			     single-float double-float)
+			 (or (unsigned-byte 32) (signed-byte 32)
+			     single-float double-float))
+  (or (unsigned-byte 32) (signed-byte 32)
+      single-float double-float)
+  (movable foldable flushable))
+
+(defun %%max (x y)
+  (declare (type (or (unsigned-byte 32) (signed-byte 32)
+		     single-float double-float) x y))
+  (%%max x y))
+
+(defun %%min (x y)
+  (declare (type (or (unsigned-byte 32) (signed-byte 32)
+		     single-float double-float) x y))
+  (%%min x y))
+
+
+(macrolet
+    ((frob (name sc-type type compare cmov cost cc max min note)
+       (let ((vop-name (symbolicate name "-" type "=>" type))
+	     (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 (backend-featurep :sparc-v9))
+	    (: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))))))))
+  (frob max single-reg single-float fcmps cfmovs 3
+	:fcc0 :ge :l "inline float max")
+  (frob max double-reg double-float fcmpd cfmovd 3
+	:fcc0 :ge :l "inline float max")
+  (frob min single-reg single-float fcmps cfmovs 3
+	:fcc0 :l :ge "inline float min")
+  (frob min double-reg double-float fcmpd cfmovd 3
+	:fcc0 :l :ge "inline float min")
+  ;; Strictly speaking these aren't float ops, but it's convenient to
+  ;; do them here.
+  ;;
+  ;; The cost is here is the worst case number of instructions.  For
+  ;; 32-bit integer operands, we add 2 more to account for the
+  ;; untagging of fixnums, if necessary.
+  (frob max signed-reg signed-num cmp cmove 5
+	:icc :ge :lt "inline (signed-byte 32) max")
+  (frob max unsigned-reg unsigned-num cmp cmove 5
+	:icc :ge :lt "inline (unsigned-byte 32) max")
+  ;; For fixnums, make the cost lower so we don't have to untag the
+  ;; numbers.
+  (frob max any-reg tagged-num cmp cmove 3
+	:icc :ge :lt "inline fixnum max")
+  (frob min signed-reg signed-num cmp cmove 5
+	:icc :lt :ge "inline (signed-byte 32) min")
+  (frob min unsigned-reg unsigned-num cmp cmove 5
+	:icc :lt :ge "inline (unsigned-byte 32) min")
+  ;; For fixnums, make the cost lower so we don't have to untag the
+  ;; numbers.
+  (frob min any-reg tagged-num cmp cmove 3
+	:icc :lt :ge "inline fixnum min"))
+	   
+#+nil
+(define-vop (max-boxed-double-float=>boxed-double-float)
+  (:args (x :scs (descriptor-reg))
+	 (y :scs (descriptor-reg)))
+  (:results (r :scs (descriptor-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline float max/min")
+  (:translate %max-double-float)
+  (:temporary (:scs (double-reg)) xval)
+  (:temporary (:scs (double-reg)) yval)
+  (:guard (backend-featurep :sparc-v9))
+  (:vop-var vop)
+  (:generator 3
+    (let ((offset (- (* vm:double-float-value-slot vm:word-bytes)
+		     vm:other-pointer-type)))
+      (inst lddf xval x offset)
+      (inst lddf yval y offset)
+      (inst fcmpd xval yval)
+      (cond ((location= r x)
+	     ;; 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))))))
+    
+)
-- 
GitLab