;;;; floating point support for the Sparc

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

;;;; float move functions

(define-move-fun (load-single 1) (vop x y)
  ((single-stack) (single-reg))
  (inst ldf y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes)))

(define-move-fun (store-single 1) (vop x y)
  ((single-reg) (single-stack))
  (inst stf x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))


(define-move-fun (load-double 2) (vop x y)
  ((double-stack) (double-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) n-word-bytes)))
    (inst lddf y nfp offset)))

(define-move-fun (store-double 2) (vop x y)
  ((double-reg) (double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) n-word-bytes)))
    (inst stdf x nfp offset)))

;;; The offset may be an integer or a TN in which case it will be
;;; temporarily modified but is restored if restore-offset is true.
(defun load-long-reg (reg base offset &optional (restore-offset t))
  #!+:sparc-v9
  (inst ldqf reg base offset)
  #!-:sparc-v9
  (let ((reg0 (make-random-tn :kind :normal
			      :sc (sc-or-lose 'double-reg)
			      :offset (tn-offset reg)))
	(reg2 (make-random-tn :kind :normal
			      :sc (sc-or-lose 'double-reg)
			      :offset (+ 2 (tn-offset reg)))))
    (cond ((integerp offset)
	   (inst lddf reg0 base offset)
	   (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
	  (t
	   (inst lddf reg0 base offset)
	   (inst add offset (* 2 n-word-bytes))
	   (inst lddf reg2 base offset)
	   (when restore-offset
	     (inst sub offset (* 2 n-word-bytes)))))))

#!+long-float
(define-move-fun (load-long 2) (vop x y)
  ((long-stack) (long-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) n-word-bytes)))
    (load-long-reg y nfp offset)))

;;; The offset may be an integer or a TN in which case it will be
;;; temporarily modified but is restored if restore-offset is true.
(defun store-long-reg (reg base offset &optional (restore-offset t))
  #!+:sparc-v9
  (inst stqf reg base offset)
  #!-:sparc-v9
  (let ((reg0 (make-random-tn :kind :normal
			      :sc (sc-or-lose 'double-reg)
			      :offset (tn-offset reg)))
	(reg2 (make-random-tn :kind :normal
			      :sc (sc-or-lose 'double-reg)
			      :offset (+ 2 (tn-offset reg)))))
    (cond ((integerp offset)
	   (inst stdf reg0 base offset)
	   (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
	  (t
	   (inst stdf reg0 base offset)
	   (inst add offset (* 2 n-word-bytes))
	   (inst stdf reg2 base offset)
	   (when restore-offset
	     (inst sub offset (* 2 n-word-bytes)))))))

#!+long-float
(define-move-fun (store-long 2) (vop x y)
  ((long-reg) (long-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) n-word-bytes)))
    (store-long-reg x nfp offset)))


;;;; Move VOPs:

;;; Exploit the V9 double-float move instruction. This is conditional
;;; on the :sparc-v9 feature.
(defun move-double-reg (dst src)
  #!+:sparc-v9
  (inst fmovd dst src)
  #!-:sparc-v9
  (dotimes (i 2)
    (let ((dst (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ i (tn-offset dst))))
	  (src (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ i (tn-offset src)))))
      (inst fmovs dst src))))

;;; Exploit the V9 long-float move instruction. This is conditional
;;; on the :sparc-v9 feature.
(defun move-long-reg (dst src)
  #!+:sparc-v9
  (inst fmovq dst src)
  #!-:sparc-v9
  (dotimes (i 4)
    (let ((dst (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ i (tn-offset dst))))
	  (src (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ i (tn-offset src)))))
      (inst fmovs dst src))))

(macrolet ((frob (vop sc format)
	     `(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)))))
  (frob single-move single-reg :single)
  (frob double-move double-reg :double)
  #!+long-float
  (frob long-move long-reg :long))


(define-vop (move-from-float)
  (:args (x :to :save))
  (:results (y))
  (:note "float to pointer coercion")
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:variant-vars format size type data)
  (:generator 13
    (with-fixed-allocation (y ndescr type size))
    (ecase format
      (:single
       (inst stf x y (- (* data n-word-bytes) other-pointer-lowtag)))
      (:double
       (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
      (:long
       (store-long-reg x y (- (* data n-word-bytes)
			      other-pointer-lowtag))))))

(macrolet ((frob (name sc &rest args)
	     `(progn
		(define-vop (,name move-from-float)
		  (:args (x :scs (,sc) :to :save))
		  (:results (y :scs (descriptor-reg)))
		  (:variant ,@args))
		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
  (frob move-from-single single-reg :single
    single-float-size single-float-widetag single-float-value-slot)
  (frob move-from-double double-reg :double
    double-float-size double-float-widetag double-float-value-slot)
  #!+long-float
  (frob move-from-long long-reg	:long
     long-float-size long-float-widetag long-float-value-slot))

(macrolet ((frob (name sc format value)
	     `(progn
		(define-vop (,name)
		  (:args (x :scs (descriptor-reg)))
		  (:results (y :scs (,sc)))
		  (:note "pointer to float coercion")
		  (:generator 2
		    (inst ,(ecase format
			     (:single 'ldf)
			     (:double 'lddf))
			  y x
			  (- (* ,value n-word-bytes) other-pointer-lowtag))))
		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
  (frob move-to-single single-reg :single single-float-value-slot)
  (frob move-to-double double-reg :double double-float-value-slot))

#!+long-float
(define-vop (move-to-long)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (long-reg)))
  (:note "pointer to float coercion")
  (:generator 2
    (load-long-reg y x (- (* long-float-value-slot n-word-bytes)
			  other-pointer-lowtag))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))

(macrolet ((frob (name sc stack-sc format)
	     `(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)))))
  (frob move-single-float-arg single-reg single-stack :single)
  (frob move-double-float-arg double-reg double-stack :double))

#!+long-float
(define-vop (move-long-float-arg)
  (:args (x :scs (long-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
  (:results (y))
  (:note "float argument move")
  (:generator 3
    (sc-case y
      (long-reg
       (unless (location= x y)
	 (move-long-reg y x)))
      (long-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
	 (store-long-reg x nfp offset))))))
;;;
#!+long-float
(define-move-vop move-long-float-arg :move-arg
  (long-reg descriptor-reg) (long-reg))


;;;; Complex float move functions

(defun complex-single-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
		  :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
		  :offset (1+ (tn-offset x))))

(defun complex-double-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
		  :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
		  :offset (+ (tn-offset x) 2)))

#!+long-float
(defun complex-long-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
		  :offset (tn-offset x)))
#!+long-float
(defun complex-long-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
		  :offset (+ (tn-offset x) 4)))


(define-move-fun (load-complex-single 2) (vop x y)
  ((complex-single-stack) (complex-single-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) n-word-bytes)))
    (let ((real-tn (complex-single-reg-real-tn y)))
      (inst ldf real-tn nfp offset))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
      (inst ldf imag-tn nfp (+ offset n-word-bytes)))))

(define-move-fun (store-complex-single 2) (vop x y)
  ((complex-single-reg) (complex-single-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) n-word-bytes)))
    (let ((real-tn (complex-single-reg-real-tn x)))
      (inst stf real-tn nfp offset))
    (let ((imag-tn (complex-single-reg-imag-tn x)))
      (inst stf imag-tn nfp (+ offset n-word-bytes)))))


(define-move-fun (load-complex-double 4) (vop x y)
  ((complex-double-stack) (complex-double-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) n-word-bytes)))
    (let ((real-tn (complex-double-reg-real-tn y)))
      (inst lddf real-tn nfp offset))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
      (inst lddf imag-tn nfp (+ offset (* 2 n-word-bytes))))))

(define-move-fun (store-complex-double 4) (vop x y)
  ((complex-double-reg) (complex-double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) n-word-bytes)))
    (let ((real-tn (complex-double-reg-real-tn x)))
      (inst stdf real-tn nfp offset))
    (let ((imag-tn (complex-double-reg-imag-tn x)))
      (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes))))))


#!+long-float
(define-move-fun (load-complex-long 5) (vop x y)
  ((complex-long-stack) (complex-long-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) n-word-bytes)))
    (let ((real-tn (complex-long-reg-real-tn y)))
      (load-long-reg real-tn nfp offset))
    (let ((imag-tn (complex-long-reg-imag-tn y)))
      (load-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))

#!+long-float
(define-move-fun (store-complex-long 5) (vop x y)
  ((complex-long-reg) (complex-long-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) n-word-bytes)))
    (let ((real-tn (complex-long-reg-real-tn x)))
      (store-long-reg real-tn nfp offset))
    (let ((imag-tn (complex-long-reg-imag-tn x)))
      (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))

;;;
;;; Complex float register to register moves.
;;;
(define-vop (complex-single-move)
  (:args (x :scs (complex-single-reg) :target y
	    :load-if (not (location= x y))))
  (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
  (:note "complex single float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-single-reg-real-tn x))
	     (y-real (complex-single-reg-real-tn y)))
	 (inst fmovs y-real x-real))
       (let ((x-imag (complex-single-reg-imag-tn x))
	     (y-imag (complex-single-reg-imag-tn y)))
	 (inst fmovs y-imag x-imag)))))
;;;
(define-move-vop complex-single-move :move
  (complex-single-reg) (complex-single-reg))

(define-vop (complex-double-move)
  (:args (x :scs (complex-double-reg)
	    :target y :load-if (not (location= x y))))
  (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
  (:note "complex double float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-double-reg-real-tn x))
	     (y-real (complex-double-reg-real-tn y)))
	 (move-double-reg y-real x-real))
       (let ((x-imag (complex-double-reg-imag-tn x))
	     (y-imag (complex-double-reg-imag-tn y)))
	 (move-double-reg y-imag x-imag)))))
;;;
(define-move-vop complex-double-move :move
  (complex-double-reg) (complex-double-reg))

#!+long-float
(define-vop (complex-long-move)
  (:args (x :scs (complex-long-reg)
	    :target y :load-if (not (location= x y))))
  (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))
  (:note "complex long float move")
  (:generator 0
     (unless (location= x y)
       ;; Note the complex-float-regs are aligned to every second
       ;; float register so there is not need to worry about overlap.
       (let ((x-real (complex-long-reg-real-tn x))
	     (y-real (complex-long-reg-real-tn y)))
	 (move-long-reg y-real x-real))
       (let ((x-imag (complex-long-reg-imag-tn x))
	     (y-imag (complex-long-reg-imag-tn y)))
	 (move-long-reg y-imag x-imag)))))
;;;
#!+long-float
(define-move-vop complex-long-move :move
  (complex-long-reg) (complex-long-reg))

;;;
;;; Move from a complex float to a descriptor register allocating a
;;; new complex float object in the process.
;;;
(define-vop (move-from-complex-single)
  (:args (x :scs (complex-single-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note "complex single float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-single-float-widetag
			       complex-single-float-size))
     (let ((real-tn (complex-single-reg-real-tn x)))
       (inst stf real-tn y (- (* complex-single-float-real-slot
				 n-word-bytes)
			      other-pointer-lowtag)))
     (let ((imag-tn (complex-single-reg-imag-tn x)))
       (inst stf imag-tn y (- (* complex-single-float-imag-slot
				 n-word-bytes)
			      other-pointer-lowtag)))))
;;;
(define-move-vop move-from-complex-single :move
  (complex-single-reg) (descriptor-reg))

(define-vop (move-from-complex-double)
  (:args (x :scs (complex-double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note "complex double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-double-float-widetag
			       complex-double-float-size))
     (let ((real-tn (complex-double-reg-real-tn x)))
       (inst stdf real-tn y (- (* complex-double-float-real-slot
				  n-word-bytes)
			       other-pointer-lowtag)))
     (let ((imag-tn (complex-double-reg-imag-tn x)))
       (inst stdf imag-tn y (- (* complex-double-float-imag-slot
				  n-word-bytes)
			       other-pointer-lowtag)))))
;;;
(define-move-vop move-from-complex-double :move
  (complex-double-reg) (descriptor-reg))

#!+long-float
(define-vop (move-from-complex-long)
  (:args (x :scs (complex-long-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note "complex long float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr complex-long-float-widetag
			       complex-long-float-size))
     (let ((real-tn (complex-long-reg-real-tn x)))
       (store-long-reg real-tn y (- (* complex-long-float-real-slot
				       n-word-bytes)
				    other-pointer-lowtag)))
     (let ((imag-tn (complex-long-reg-imag-tn x)))
       (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
				       n-word-bytes)
				    other-pointer-lowtag)))))
;;;
#!+long-float
(define-move-vop move-from-complex-long :move
  (complex-long-reg) (descriptor-reg))

;;;
;;; Move from a descriptor to a complex float register
;;;
(define-vop (move-to-complex-single)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (complex-single-reg)))
  (:note "pointer to complex float coercion")
  (:generator 2
    (let ((real-tn (complex-single-reg-real-tn y)))
      (inst ldf real-tn x (- (* complex-single-float-real-slot n-word-bytes)
			     other-pointer-lowtag)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
      (inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
			     other-pointer-lowtag)))))
(define-move-vop move-to-complex-single :move
  (descriptor-reg) (complex-single-reg))

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

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

;;;
;;; Complex float move-arg vop
;;;
(define-vop (move-complex-single-float-arg)
  (:args (x :scs (complex-single-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
  (:results (y))
  (:note "complex single-float argument move")
  (:generator 1
    (sc-case y
      (complex-single-reg
       (unless (location= x y)
	 (let ((x-real (complex-single-reg-real-tn x))
	       (y-real (complex-single-reg-real-tn y)))
	   (inst fmovs y-real x-real))
	 (let ((x-imag (complex-single-reg-imag-tn x))
	       (y-imag (complex-single-reg-imag-tn y)))
	   (inst fmovs y-imag x-imag))))
      (complex-single-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
	 (let ((real-tn (complex-single-reg-real-tn x)))
	   (inst stf real-tn nfp offset))
	 (let ((imag-tn (complex-single-reg-imag-tn x)))
	   (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
  (complex-single-reg descriptor-reg) (complex-single-reg))

(define-vop (move-complex-double-float-arg)
  (:args (x :scs (complex-double-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
  (:results (y))
  (:note "complex double-float argument move")
  (:generator 2
    (sc-case y
      (complex-double-reg
       (unless (location= x y)
	 (let ((x-real (complex-double-reg-real-tn x))
	       (y-real (complex-double-reg-real-tn y)))
	   (move-double-reg y-real x-real))
	 (let ((x-imag (complex-double-reg-imag-tn x))
	       (y-imag (complex-double-reg-imag-tn y)))
	   (move-double-reg y-imag x-imag))))
      (complex-double-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
	 (let ((real-tn (complex-double-reg-real-tn x)))
	   (inst stdf real-tn nfp offset))
	 (let ((imag-tn (complex-double-reg-imag-tn x)))
	   (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(define-move-vop move-complex-double-float-arg :move-arg
  (complex-double-reg descriptor-reg) (complex-double-reg))

#!+long-float
(define-vop (move-complex-long-float-arg)
  (:args (x :scs (complex-long-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
  (:results (y))
  (:note "complex long-float argument move")
  (:generator 2
    (sc-case y
      (complex-long-reg
       (unless (location= x y)
	 (let ((x-real (complex-long-reg-real-tn x))
	       (y-real (complex-long-reg-real-tn y)))
	   (move-long-reg y-real x-real))
	 (let ((x-imag (complex-long-reg-imag-tn x))
	       (y-imag (complex-long-reg-imag-tn y)))
	   (move-long-reg y-imag x-imag))))
      (complex-long-stack
       (let ((offset (* (tn-offset y) n-word-bytes)))
	 (let ((real-tn (complex-long-reg-real-tn x)))
	   (store-long-reg real-tn nfp offset))
	 (let ((imag-tn (complex-long-reg-imag-tn x)))
	   (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
#!+long-float
(define-move-vop move-complex-long-float-arg :move-arg
  (complex-long-reg descriptor-reg) (complex-long-reg))


(define-move-vop move-arg :move-arg
  (single-reg double-reg #!+long-float long-reg
   complex-single-reg complex-double-reg #!+long-float complex-long-reg)
  (descriptor-reg))


;;;; Arithmetic VOPs:

(define-vop (float-op)
  (:args (x) (y))
  (:results (r))
  (:policy :fast-safe)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only))

(macrolet ((frob (name sc ptype)
	     `(define-vop (,name float-op)
		(:args (x :scs (,sc))
		       (y :scs (,sc)))
		(:results (r :scs (,sc)))
		(:arg-types ,ptype ,ptype)
		(:result-types ,ptype))))
  (frob single-float-op single-reg single-float)
  (frob double-float-op double-reg double-float)
  #!+long-float
  (frob long-float-op long-reg long-float))

(macrolet ((frob (op sinst sname scost dinst dname dcost)
	     `(progn
		(define-vop (,sname single-float-op)
		  (:translate ,op)
		  (:generator ,scost
		    (inst ,sinst r x y)))
		(define-vop (,dname double-float-op)
		  (:translate ,op)
		  (:generator ,dcost
		    (inst ,dinst r x y))))))
  (frob + fadds +/single-float 2 faddd +/double-float 2)
  (frob - fsubs -/single-float 2 fsubd -/double-float 2)
  (frob * fmuls */single-float 4 fmuld */double-float 5)
  (frob / fdivs //single-float 12 fdivd //double-float 19))

#!+long-float
(macrolet ((frob (op linst lname lcost)
	     `(define-vop (,lname long-float-op)
		  (:translate ,op)
		  (:generator ,lcost
		    (inst ,linst r x y)))))
  (frob + faddq +/long-float 2)
  (frob - fsubq -/long-float 2)
  (frob * fmulq */long-float 6)
  (frob / fdivq //long-float 20))


(macrolet ((frob (name inst translate sc type)
	     `(define-vop (,name)
		(:args (x :scs (,sc)))
		(:results (y :scs (,sc)))
		(:translate ,translate)
		(:policy :fast-safe)
		(:arg-types ,type)
		(:result-types ,type)
		(:note "inline float arithmetic")
		(:vop-var vop)
		(:save-p :compute-only)
		(:generator 1
		  (note-this-location vop :internal-error)
		  (inst ,inst y x)))))
  (frob abs/single-float fabss abs single-reg single-float)
  (frob %negate/single-float fnegs %negate single-reg single-float))

(defun negate-double-reg (dst src)
  #!+:sparc-v9
  (inst fnegd dst src)
  #!-:sparc-v9
  ;; Negate the MS part of the numbers, then copy over the rest
  ;; of the bits.
  (inst fnegs dst src)
  (let ((dst-odd (make-random-tn :kind :normal
				 :sc (sc-or-lose 'single-reg)
				 :offset (+ 1 (tn-offset dst))))
	(src-odd (make-random-tn :kind :normal
				 :sc (sc-or-lose 'single-reg)
				 :offset (+ 1 (tn-offset src)))))
    (inst fmovs dst-odd src-odd)))

(defun abs-double-reg (dst src)
  #!+:sparc-v9
  (inst fabsd dst src)
  #!-:sparc-v9
  ;; Abs the MS part of the numbers, then copy over the rest
  ;; of the bits.
  (inst fabss dst src)
  (let ((dst-2 (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ 1 (tn-offset dst))))
	(src-2 (make-random-tn :kind :normal
			       :sc (sc-or-lose 'single-reg)
			       :offset (+ 1 (tn-offset src)))))
    (inst fmovs dst-2 src-2)))

(define-vop (abs/double-float)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate abs)
  (:policy :fast-safe)
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (abs-double-reg y x)))

(define-vop (%negate/double-float)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate %negate)
  (:policy :fast-safe)
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (negate-double-reg y x)))

#!+long-float
(define-vop (abs/long-float)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate abs)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    #!+:sparc-v9
    (inst fabsq y x)
    #!-:sparc-v9
    (inst fabss y x)
    (dotimes (i 3)
      (let ((y-odd (make-random-tn
		    :kind :normal
		    :sc (sc-or-lose 'single-reg)
		    :offset (+ i 1 (tn-offset y))))
	    (x-odd (make-random-tn
		    :kind :normal
		    :sc (sc-or-lose 'single-reg)
		    :offset (+ i 1 (tn-offset x)))))
	(inst fmovs y-odd x-odd)))))

#!+long-float
(define-vop (%negate/long-float)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate %negate)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    #!+:sparc-v9
    (inst fnegq y x)
    #!-:sparc-v9
    (inst fnegs y x)
    (dotimes (i 3)
      (let ((y-odd (make-random-tn
		    :kind :normal
		    :sc (sc-or-lose 'single-reg)
		    :offset (+ i 1 (tn-offset y))))
	    (x-odd (make-random-tn
		    :kind :normal
		    :sc (sc-or-lose 'single-reg)
		    :offset (+ i 1 (tn-offset x)))))
	(inst fmovs y-odd x-odd)))))


;;;; Comparison:

(define-vop (float-compare)
  (:args (x) (y))
  (:conditional)
  (:info target not-p)
  (:variant-vars format yep nope)
  (:policy :fast-safe)
  (:note "inline float comparison")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (note-this-location vop :internal-error)
    (ecase format
      (:single (inst fcmps x y))
      (:double (inst fcmpd x y))
      (:long (inst fcmpq x y)))
    ;; The SPARC V9 doesn't need an instruction between a
    ;; floating-point compare and a floating-point branch.
    #!-:sparc-v9 (inst nop)
    (inst fb (if not-p nope yep) target)
    (inst nop)))

(macrolet ((frob (name sc ptype)
	     `(define-vop (,name float-compare)
		(:args (x :scs (,sc))
		       (y :scs (,sc)))
		(:arg-types ,ptype ,ptype))))
  (frob single-float-compare single-reg single-float)
  (frob double-float-compare double-reg double-float)
  #!+long-float
  (frob long-float-compare long-reg long-float))

(macrolet ((frob (translate yep nope sname dname #!+long-float lname)
	     `(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)))))
  (frob < :l :ge </single-float </double-float #!+long-float </long-float)
  (frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
  (frob = :eq :ne eql/single-float eql/double-float #!+long-float eql/long-float))

#!+long-float
(deftransform eql ((x y) (long-float long-float))
  '(and (= (long-float-low-bits x) (long-float-low-bits y))
	(= (long-float-mid-bits x) (long-float-mid-bits y))
	(= (long-float-high-bits x) (long-float-high-bits y))
	(= (long-float-exp-bits x) (long-float-exp-bits y))))


;;;; Conversion:

(macrolet ((frob (name translate inst to-sc to-type)
	     `(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))))))
  (frob %single-float/signed %single-float fitos single-reg single-float)
  (frob %double-float/signed %double-float fitod double-reg double-float)
  #!+long-float
  (frob %long-float/signed %long-float fitoq long-reg long-float))

(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
	     `(define-vop (,name)
		(:args (x :scs (,from-sc)))
		(:results (y :scs (,to-sc)))
		(: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)))))
  (frob %single-float/double-float %single-float fdtos
    double-reg double-float single-reg single-float)
  #!+long-float
  (frob %single-float/long-float %single-float fqtos
    long-reg long-float single-reg single-float)
  (frob %double-float/single-float %double-float fstod
    single-reg single-float double-reg double-float)
  #!+long-float
  (frob %double-float/long-float %double-float fqtod
    long-reg long-float double-reg double-float)
  #!+long-float
  (frob %long-float/single-float %long-float fstoq
    single-reg single-float long-reg long-float)
  #!+long-float
  (frob %long-float/double-float %long-float fdtoq
    double-reg double-float long-reg long-float))

(macrolet ((frob (trans from-sc from-type inst)
	     `(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)
  #!+long-float
  (frob %unary-truncate long-reg long-float fqtoi)
  ;; KLUDGE -- these two forms were protected by #-sun4.
  ;; (frob %unary-round single-reg single-float fstoir)
  ;; (frob %unary-round double-reg double-float fdtoir)
)

(deftransform %unary-round ((x) (float) (signed-byte 32))
  '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
	  (extra (- x trunc))
	  (absx (abs extra))
	  (one-half (float 1/2 x)))
     (if (if (oddp trunc)
	     (>= absx one-half)
	     (> absx one-half))
	 (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
	 trunc)))

(define-vop (make-single-float)
  (:args (bits :scs (signed-reg) :target res
	       :load-if (not (sc-is bits signed-stack))))
  (:results (res :scs (single-reg)
		 :load-if (not (sc-is res single-stack))))
  (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
  (:temporary (:scs (signed-stack)) stack-temp)
  (:arg-types signed-num)
  (:result-types single-float)
  (:translate make-single-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case bits
      (signed-reg
       (sc-case res
	 (single-reg
	  (inst st bits (current-nfp-tn vop)
		(* (tn-offset stack-temp) n-word-bytes))
	  (inst ldf res (current-nfp-tn vop)
		(* (tn-offset stack-temp) n-word-bytes)))
	 (single-stack
	  (inst st bits (current-nfp-tn vop)
		(* (tn-offset res) n-word-bytes)))))
      (signed-stack
       (sc-case res
	 (single-reg
	  (inst ldf res (current-nfp-tn vop)
		(* (tn-offset bits) n-word-bytes)))
	 (single-stack
	  (unless (location= bits res)
	    (inst ld temp (current-nfp-tn vop)
		  (* (tn-offset bits) n-word-bytes))
	    (inst st temp (current-nfp-tn vop)
		  (* (tn-offset res) n-word-bytes)))))))))

(define-vop (make-double-float)
  (:args (hi-bits :scs (signed-reg))
	 (lo-bits :scs (unsigned-reg)))
  (:results (res :scs (double-reg)
		 :load-if (not (sc-is res double-stack))))
  (:temporary (:scs (double-stack)) temp)
  (:arg-types signed-num unsigned-num)
  (:result-types double-float)
  (:translate make-double-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let ((stack-tn (sc-case res
		      (double-stack res)
		      (double-reg temp))))
      (inst st hi-bits (current-nfp-tn vop)
	    (* (tn-offset stack-tn) n-word-bytes))
      (inst st lo-bits (current-nfp-tn vop)
	    (* (1+ (tn-offset stack-tn)) n-word-bytes)))
    (when (sc-is res double-reg)
      (inst lddf res (current-nfp-tn vop)
	    (* (tn-offset temp) n-word-bytes)))))

#!+long-float
(define-vop (make-long-float)
    (:args (hi-bits :scs (signed-reg))
	   (lo1-bits :scs (unsigned-reg))
	   (lo2-bits :scs (unsigned-reg))
	   (lo3-bits :scs (unsigned-reg)))
  (:results (res :scs (long-reg)
		 :load-if (not (sc-is res long-stack))))
  (:temporary (:scs (long-stack)) temp)
  (:arg-types signed-num unsigned-num unsigned-num unsigned-num)
  (:result-types long-float)
  (:translate make-long-float)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 2
    (let ((stack-tn (sc-case res
		      (long-stack res)
		      (long-reg temp))))
      (inst st hi-bits (current-nfp-tn vop)
	    (* (tn-offset stack-tn) n-word-bytes))
      (inst st lo1-bits (current-nfp-tn vop)
	    (* (1+ (tn-offset stack-tn)) n-word-bytes))
      (inst st lo2-bits (current-nfp-tn vop)
	    (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
      (inst st lo3-bits (current-nfp-tn vop)
	    (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
    (when (sc-is res long-reg)
      (load-long-reg res (current-nfp-tn vop)
		     (* (tn-offset temp) n-word-bytes)))))

(define-vop (single-float-bits)
  (:args (float :scs (single-reg descriptor-reg)
		:load-if (not (sc-is float single-stack))))
  (:results (bits :scs (signed-reg)
		  :load-if (or (sc-is float descriptor-reg single-stack)
			       (not (sc-is bits signed-stack)))))
  (:temporary (:scs (signed-stack)) stack-temp)
  (:arg-types single-float)
  (:result-types signed-num)
  (:translate single-float-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 4
    (sc-case bits
      (signed-reg
       (sc-case float
	 (single-reg
	  (inst stf float (current-nfp-tn vop)
		(* (tn-offset stack-temp) n-word-bytes))
	  (inst ld bits (current-nfp-tn vop)
		(* (tn-offset stack-temp) n-word-bytes)))
	 (single-stack
	  (inst ld bits (current-nfp-tn vop)
		(* (tn-offset float) n-word-bytes)))
	 (descriptor-reg
	  (loadw bits float single-float-value-slot
		 other-pointer-lowtag))))
      (signed-stack
       (sc-case float
	 (single-reg
	  (inst stf float (current-nfp-tn vop)
		(* (tn-offset bits) n-word-bytes))))))))

(define-vop (double-float-high-bits)
  (:args (float :scs (double-reg descriptor-reg)
		:load-if (not (sc-is float double-stack))))
  (:results (hi-bits :scs (signed-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types double-float)
  (:result-types signed-num)
  (:translate double-float-high-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (double-reg
       (inst stdf float (current-nfp-tn vop)
	     (* (tn-offset stack-temp) n-word-bytes))
       (inst ld hi-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) n-word-bytes)))
      (double-stack
       (inst ld hi-bits (current-nfp-tn vop)
	     (* (tn-offset float) n-word-bytes)))
      (descriptor-reg
       (loadw hi-bits float double-float-value-slot
	      other-pointer-lowtag)))))

(define-vop (double-float-low-bits)
  (:args (float :scs (double-reg descriptor-reg)
		:load-if (not (sc-is float double-stack))))
  (:results (lo-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types double-float)
  (:result-types unsigned-num)
  (:translate double-float-low-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (double-reg
       (inst stdf float (current-nfp-tn vop)
	     (* (tn-offset stack-temp) n-word-bytes))
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (double-stack
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw lo-bits float (1+ double-float-value-slot)
	      other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-exp-bits)
  (:args (float :scs (long-reg descriptor-reg)
		:load-if (not (sc-is float long-stack))))
  (:results (exp-bits :scs (signed-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types signed-num)
  (:translate long-float-exp-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
				    :sc (sc-or-lose 'double-reg)
				    :offset (tn-offset float))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld exp-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) n-word-bytes)))
      (long-stack
       (inst ld exp-bits (current-nfp-tn vop)
	     (* (tn-offset float) n-word-bytes)))
      (descriptor-reg
       (loadw exp-bits float long-float-value-slot
	      other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-high-bits)
  (:args (float :scs (long-reg descriptor-reg)
		:load-if (not (sc-is float long-stack))))
  (:results (high-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-high-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
				    :sc (sc-or-lose 'double-reg)
				    :offset (tn-offset float))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld high-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (long-stack
       (inst ld high-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw high-bits float (1+ long-float-value-slot)
	      other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-mid-bits)
  (:args (float :scs (long-reg descriptor-reg)
		:load-if (not (sc-is float long-stack))))
  (:results (mid-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-mid-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
				    :sc (sc-or-lose 'double-reg)
				    :offset (+ 2 (tn-offset float)))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld mid-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) n-word-bytes)))
      (long-stack
       (inst ld mid-bits (current-nfp-tn vop)
	     (* (+ 2 (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw mid-bits float (+ 2 long-float-value-slot)
	      other-pointer-lowtag)))))

#!+long-float
(define-vop (long-float-low-bits)
  (:args (float :scs (long-reg descriptor-reg)
		:load-if (not (sc-is float long-stack))))
  (:results (lo-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types long-float)
  (:result-types unsigned-num)
  (:translate long-float-low-bits)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 5
    (sc-case float
      (long-reg
       (let ((float (make-random-tn :kind :normal
				    :sc (sc-or-lose 'double-reg)
				    :offset (+ 2 (tn-offset float)))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) n-word-bytes)))
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) n-word-bytes)))
      (long-stack
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (+ 3 (tn-offset float)) n-word-bytes)))
      (descriptor-reg
       (loadw lo-bits float (+ 3 long-float-value-slot)
	      other-pointer-lowtag)))))


;;;; Float mode hackery:

(sb!xc:deftype float-modes () '(unsigned-byte 32))
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
  float-modes)

(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:sc unsigned-stack) temp)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (inst stfsr nfp (* n-word-bytes (tn-offset temp)))
      (loadw res nfp (tn-offset temp))
      (inst nop))))

#+nil
(define-vop (floating-point-modes)
  (:results (res :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:translate floating-point-modes)
  (:policy :fast-safe)
  (:vop-var vop)
  (:temporary (:sc double-stack) temp)
  (:generator 3
    (let* ((nfp (current-nfp-tn vop))
	   (offset (* 4 (tn-offset temp))))
      (inst stxfsr nfp offset)
      ;; The desired FP mode data is in the least significant 32
      ;; bits, which is stored at the next higher word in memory.
      (loadw res nfp (+ offset 4))
      ;; Is this nop needed? (toy@rtp.ericsson.se)
      (inst nop))))

(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc unsigned-stack) temp)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop)))
      (storew new nfp (tn-offset temp))
      (inst ldfsr nfp (* n-word-bytes (tn-offset temp)))
      (move res new))))

#+nil
(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc unsigned-reg) my-fsr)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop))
	  (offset (* n-word-bytes (tn-offset temp))))
      (pseudo-atomic ()
        ;; Get the current FSR, so we can get the new %fcc's
        (inst stxfsr nfp offset)
	(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 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)))))

#+nil
(define-vop (set-floating-point-modes)
  (:args (new :scs (unsigned-reg) :target res))
  (:results (res :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:result-types unsigned-num)
  (:translate (setf floating-point-modes))
  (:policy :fast-safe)
  (:temporary (:sc double-stack) temp)
  (:temporary (:sc unsigned-reg) my-fsr)
  (:vop-var vop)
  (:generator 3
    (let ((nfp (current-nfp-tn vop))
	  (offset (* n-word-bytes (tn-offset temp))))
      (inst stx new nfp offset)
      (inst ldxfsr nfp offset)
      (move res new))))


;;;; Special functions.

#!-long-float
(define-vop (fsqrt)
  (:args (x :scs (double-reg)))
  (:results (y :scs (double-reg)))
  (:translate %sqrt)
  (:policy :fast-safe)
  (:guard #!+(or :sparc-v7 :sparc-v8 :sparc-v9) t
	  #!-(or :sparc-v7 :sparc-v8 :sparc-v9) nil)
  (:arg-types double-float)
  (:result-types double-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (inst fsqrtd y x)))

#!+long-float
(define-vop (fsqrt-long)
  (:args (x :scs (long-reg)))
  (:results (y :scs (long-reg)))
  (:translate %sqrt)
  (:policy :fast-safe)
  (:arg-types long-float)
  (:result-types long-float)
  (:note "inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (inst fsqrtq y x)))


;;;; Complex float VOPs

(define-vop (make-complex-single-float)
  (:translate complex)
  (:args (real :scs (single-reg) :target r
	       :load-if (not (location= real r)))
	 (imag :scs (single-reg) :to :save))
  (:arg-types single-float single-float)
  (:results (r :scs (complex-single-reg) :from (:argument 0)
	       :load-if (not (sc-is r complex-single-stack))))
  (:result-types complex-single-float)
  (: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-" 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)
		#!-: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)
		#!-: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)
		#!-: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 #!-: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))))))))
  (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 #!-:sparc-v9 t #!+:sparc-v9 nil)
	    (: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 #!+:sparc-v9 t #!-:sparc-v9 nil)
	    (: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 :pt)
		(inst nop)))))))
  (frob single fcmps)
  (frob double fcmpd))

) ; end progn complex-fp-vops

#!+sparc-v9
(progn

;; Vops to take advantage of the conditional move instruction
;; available on the Sparc V9
  
(defknown (%%max %%min) ((or (unsigned-byte #.n-word-bits)
			     (signed-byte #.n-word-bits)
			     single-float double-float)
			 (or (unsigned-byte #.n-word-bits)
			     (signed-byte #.n-word-bits)
			     single-float double-float))
  (or (unsigned-byte #.n-word-bits)
      (signed-byte #.n-word-bits)
      single-float double-float)
  (movable foldable flushable))

;; We need these definitions for byte-compiled code
(defun %%min (x y)
  (declare (type (or (unsigned-byte 32) (signed-byte 32)
		     single-float double-float) x y))
  (if (< x y)
      x y))

(defun %%max (x y)
  (declare (type (or (unsigned-byte 32) (signed-byte 32)
		     single-float double-float) x y))
  (if (> x y)
      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 #!+:sparc-v9 t #!-:sparc-v9 nil)
	    (: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 #!+:sparc-v9 t #!-:sparc-v9 nil)
  (:vop-var vop)
  (:generator 3
    (let ((offset (- (* double-float-value-slot n-word-bytes)
		     other-pointer-lowtag)))
      (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))))))
    
) ; PROGN

(in-package "SB!C")
;;; FIXME
#| #!+sparc-v9 |#
#+nil
(progn
;;; The sparc-v9 architecture has conditional move instructions that
;;; can be used.  This should be faster than using the obvious if
;;; expression since we don't have to do branches.
  
(def-source-transform min (&rest args)
  (case (length args)
    ((0 2) (values nil t))
    (1 `(values ,(first args)))
    (t (sb!c::associate-arguments 'min (first args) (rest args)))))

(def-source-transform max (&rest args)
  (case (length args)
    ((0 2) (values nil t))
    (1 `(values ,(first args)))
    (t (sb!c::associate-arguments 'max (first args) (rest args)))))

;; Derive the types of max and min
(defoptimizer (max derive-type) ((x y))
  (multiple-value-bind (definitely-< definitely->=)
      (ir1-transform-<-helper x y)
    (cond (definitely-<
	      (continuation-type y))
	  (definitely->=
	      (continuation-type x))
	  (t
	   (make-canonical-union-type (list (continuation-type x)
					    (continuation-type y)))))))

(defoptimizer (min derive-type) ((x y))
  (multiple-value-bind (definitely-< definitely->=)
      (ir1-transform-<-helper x y)
    (cond (definitely-<
	      (continuation-type x))
	  (definitely->=
	      (continuation-type y))
	  (t
	   (make-canonical-union-type (list (continuation-type x)
					    (continuation-type y)))))))

(deftransform max ((x y) (number number) * :when :both)
  (let ((x-type (continuation-type x))
	(y-type (continuation-type y))
	(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
	(unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
	(d-float (specifier-type 'double-float))
	(s-float (specifier-type 'single-float)))
    ;; Use %%max if both args are good types of the same type.  As a
    ;; last resort, use the obvious comparison to select the desired
    ;; element.
    (cond ((and (csubtypep x-type signed)
		(csubtypep y-type signed))
	   `(%%max x y))
	  ((and (csubtypep x-type unsigned)
		(csubtypep y-type unsigned))
	   `(%%max x y))
	  ((and (csubtypep x-type d-float)
		(csubtypep y-type d-float))
	   `(%%max x y))
	  ((and (csubtypep x-type s-float)
		(csubtypep y-type s-float))
	   `(%%max x y))
	  (t
	   (let ((arg1 (gensym))
		 (arg2 (gensym)))
	     `(let ((,arg1 x)
		    (,arg2 y))
	       (if (> ,arg1 ,arg2)
		   ,arg1 ,arg2)))))))

(deftransform min ((x y) (real real) * :when :both)
  (let ((x-type (continuation-type x))
	(y-type (continuation-type y))
	(signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
	(unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
	(d-float (specifier-type 'double-float))
	(s-float (specifier-type 'single-float)))
    (cond ((and (csubtypep x-type signed)
		(csubtypep y-type signed))
	   `(%%min x y))
	  ((and (csubtypep x-type unsigned)
		(csubtypep y-type unsigned))
	   `(%%min x y))
	  ((and (csubtypep x-type d-float)
		(csubtypep y-type d-float))
	   `(%%min x y))
	  ((and (csubtypep x-type s-float)
		(csubtypep y-type s-float))
	   `(%%min x y))
	  (t
	   (let ((arg1 (gensym))
		 (arg2 (gensym)))
	     `(let ((,arg1 x)
		    (,arg2 y))
		(if (< ,arg1 ,arg2)
		    ,arg1 ,arg2)))))))

) ; PROGN