;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /project/cmucl/cvsroot/src/compiler/sparc/float.lisp,v 1.63 2010-03-19 15:19:01 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains floating point support for the MIPS.
;;;
;;; Written by Rob MacLachlan
;;; Sparc conversion by William Lott.
;;; Complex-float and long-float support by Douglas Crosher 1998.
;;;
(in-package "SPARC")
(intl:textdomain "cmucl-sparc-vm")


;;;; Move functions:

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

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


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

(define-move-function (store-double 2) (vop x y)
  ((double-reg) (double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm: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))
  (if (backend-featurep :sparc-v9)
      (inst ldqf reg base offset)
      (let ((reg0 (make-random-tn :kind :normal
				  :sc (sc-or-lose 'double-reg *backend*)
				  :offset (tn-offset reg)))
	    (reg2 (make-random-tn :kind :normal
				  :sc (sc-or-lose 'double-reg *backend*)
				  :offset (+ 2 (tn-offset reg)))))
	(cond ((integerp offset)
	       (inst lddf reg0 base offset)
	       (inst lddf reg2 base (+ offset (* 2 vm:word-bytes))))
	      (t
	       (inst lddf reg0 base offset)
	       (inst add offset (* 2 vm:word-bytes))
	       (inst lddf reg2 base offset)
	       (when restore-offset
		 (inst sub offset (* 2 vm:word-bytes))))))))

#+long-float
(define-move-function (load-long 2) (vop x y)
  ((long-stack) (long-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm: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))
  (if (backend-featurep :sparc-v9)
      (inst stqf reg base offset)
      (let ((reg0 (make-random-tn :kind :normal
				  :sc (sc-or-lose 'double-reg *backend*)
				  :offset (tn-offset reg)))
	    (reg2 (make-random-tn :kind :normal
				  :sc (sc-or-lose 'double-reg *backend*)
				  :offset (+ 2 (tn-offset reg)))))
	(cond ((integerp offset)
	       (inst stdf reg0 base offset)
	       (inst stdf reg2 base (+ offset (* 2 vm:word-bytes))))
	      (t
	       (inst stdf reg0 base offset)
	       (inst add offset (* 2 vm:word-bytes))
	       (inst stdf reg2 base offset)
	       (when restore-offset
		 (inst sub offset (* 2 vm:word-bytes))))))))

#+long-float
(define-move-function (store-long 2) (vop x y)
  ((long-reg) (long-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm: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)
  (cond ((backend-featurep :sparc-v9)
	 (unless (location= dst src)
	   (inst fmovd dst src)))
	(t
	 (dotimes (i 2)
	   (let ((dst (make-random-tn :kind :normal
				      :sc (sc-or-lose 'single-reg *backend*)
				      :offset (+ i (tn-offset dst))))
		 (src (make-random-tn :kind :normal
				      :sc (sc-or-lose 'single-reg *backend*)
				      :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)
  (cond ((backend-featurep :sparc-v9)
	 (inst fmovq dst src))
	(t
	 (dotimes (i 4)
	   (let ((dst (make-random-tn :kind :normal
				      :sc (sc-or-lose 'single-reg *backend*)
				      :offset (+ i (tn-offset dst))))
		 (src (make-random-tn :kind :normal
				      :sc (sc-or-lose 'single-reg *backend*)
				      :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 _N"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 _N"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 vm:word-bytes) vm:other-pointer-type)))
      (:double
       (inst stdf x y (- (* data vm:word-bytes) vm:other-pointer-type)))
      (:long
       (store-long-reg x y (- (* data vm:word-bytes)
			      vm:other-pointer-type))))))

(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
    vm:single-float-size vm:single-float-type vm:single-float-value-slot)
  (frob move-from-double double-reg :double
    vm:double-float-size vm:double-float-type vm:double-float-value-slot)
  #+long-float
  (frob move-from-long long-reg	:long
     vm:long-float-size vm:long-float-type vm:long-float-value-slot))

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

#+long-float
(define-vop (move-to-long)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (long-reg)))
  (:note _N"pointer to float coercion")
  (:generator 2
    (load-long-reg y x (- (* vm:long-float-value-slot vm:word-bytes)
			  vm:other-pointer-type))))
#+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 _N"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) vm:word-bytes)))
			 (inst ,(ecase format
				  (:single 'stf)
				  (:double 'stdf))
			       x nfp offset))))))
		(define-move-vop ,name :move-argument
		  (,sc descriptor-reg) (,sc)))))
  (frob move-single-float-argument single-reg single-stack :single)
  (frob move-double-float-argument double-reg double-stack :double))

#+long-float
(define-vop (move-long-float-argument)
  (:args (x :scs (long-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
  (:results (y))
  (:note _N"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) vm:word-bytes)))
	 (store-long-reg x nfp offset))))))
;;;
#+long-float
(define-move-vop move-long-float-argument :move-argument
  (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 *backend*)
		  :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg *backend*)
		  :offset (1+ (tn-offset x))))

(defun complex-double-reg-real-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :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 *backend*)
		  :offset (tn-offset x)))
#+long-float
(defun complex-long-reg-imag-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
		  :offset (+ (tn-offset x) 4)))

#+double-double
(progn
(defun complex-double-double-reg-real-hi-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (tn-offset x)))
(defun complex-double-double-reg-real-lo-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (+ 2 (tn-offset x))))
(defun complex-double-double-reg-imag-hi-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (+ 4 (tn-offset x))))
(defun complex-double-double-reg-imag-lo-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (+ 6 (tn-offset x))))
)

(define-move-function (load-complex-single 2) (vop x y)
  ((complex-single-stack) (complex-single-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm: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 vm:word-bytes)))))

(define-move-function (store-complex-single 2) (vop x y)
  ((complex-single-reg) (complex-single-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm: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 vm:word-bytes)))))


(define-move-function (load-complex-double 4) (vop x y)
  ((complex-double-stack) (complex-double-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm: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 vm:word-bytes))))))

(define-move-function (store-complex-double 4) (vop x y)
  ((complex-double-reg) (complex-double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm: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 vm:word-bytes))))))


#+long-float
(define-move-function (load-complex-long 5) (vop x y)
  ((complex-long-stack) (complex-long-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm: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 vm:word-bytes))))))

#+long-float
(define-move-function (store-complex-long 5) (vop x y)
  ((complex-long-reg) (complex-long-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm: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 vm:word-bytes))))))

#+double-double
(progn
(define-move-function (load-complex-double-double 4) (vop x y)
  ((complex-double-double-stack) (complex-double-double-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm:word-bytes)))
    (let ((value-tn (complex-double-double-reg-real-hi-tn y)))
      (inst lddf value-tn nfp offset))
    (let ((value-tn (complex-double-double-reg-real-lo-tn y)))
      (inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes))))
    (let ((value-tn (complex-double-double-reg-imag-hi-tn y)))
      (inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes))))
    (let ((value-tn (complex-double-double-reg-imag-lo-tn y)))
      (inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes))))))

(define-move-function (store-complex-double-double 4) (vop x y)
  ((complex-double-double-reg) (complex-double-double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm:word-bytes)))
    (let ((value-tn (complex-double-double-reg-real-hi-tn x)))
      (inst stdf value-tn nfp offset))
    (let ((value-tn (complex-double-double-reg-real-lo-tn x)))
      (inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes))))
    (let ((value-tn (complex-double-double-reg-imag-hi-tn x)))
      (inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes))))
    (let ((value-tn (complex-double-double-reg-imag-lo-tn x)))
      (inst stdf value-tn nfp (+ offset (* 6 vm: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 _N"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 _N"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 _N"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))

#+double-double
(define-vop (complex-double-double-move)
  (:args (x :scs (complex-double-double-reg)
	    :target y :load-if (not (location= x y))))
  (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y))))
  (:note _N"complex double-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-double-reg-real-hi-tn x))
	     (y-real (complex-double-double-reg-real-hi-tn y)))
	 (move-double-reg y-real x-real))
       (let ((x-real (complex-double-double-reg-real-lo-tn x))
	     (y-real (complex-double-double-reg-real-lo-tn y)))
	 (move-double-reg y-real x-real))
       (let ((x-real (complex-double-double-reg-imag-hi-tn x))
	     (y-real (complex-double-double-reg-imag-hi-tn y)))
	 (move-double-reg y-real x-real))
       (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
	     (y-imag (complex-double-double-reg-imag-lo-tn y)))
	 (move-double-reg y-imag x-imag)))))
;;;
#+double-double
(define-move-vop complex-double-double-move :move
  (complex-double-double-reg) (complex-double-double-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 _N"complex single float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr vm:complex-single-float-type
			       vm:complex-single-float-size))
     (let ((real-tn (complex-single-reg-real-tn x)))
       (inst stf real-tn y (- (* vm:complex-single-float-real-slot
				 vm:word-bytes)
			      vm:other-pointer-type)))
     (let ((imag-tn (complex-single-reg-imag-tn x)))
       (inst stf imag-tn y (- (* vm:complex-single-float-imag-slot
				 vm:word-bytes)
			      vm:other-pointer-type)))))
;;;
(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 _N"complex double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr vm:complex-double-float-type
			       vm:complex-double-float-size))
     (let ((real-tn (complex-double-reg-real-tn x)))
       (inst stdf real-tn y (- (* vm:complex-double-float-real-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))
     (let ((imag-tn (complex-double-reg-imag-tn x)))
       (inst stdf imag-tn y (- (* vm:complex-double-float-imag-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))))
;;;
(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 _N"complex long float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr vm:complex-long-float-type
			       vm:complex-long-float-size))
     (let ((real-tn (complex-long-reg-real-tn x)))
       (store-long-reg real-tn y (- (* vm:complex-long-float-real-slot
				       vm:word-bytes)
				    vm:other-pointer-type)))
     (let ((imag-tn (complex-long-reg-imag-tn x)))
       (store-long-reg imag-tn y (- (* vm:complex-long-float-imag-slot
				       vm:word-bytes)
				    vm:other-pointer-type)))))
;;;
#+long-float
(define-move-vop move-from-complex-long :move
  (complex-long-reg) (descriptor-reg))

#+double-double
(define-vop (move-from-complex-double-double)
  (:args (x :scs (complex-double-double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note _N"complex double-double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr vm::complex-double-double-float-type
			       vm::complex-double-double-float-size))
     (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))
     (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))
     (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))
     (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))))
;;;
#+double-double
(define-move-vop move-from-complex-double-double :move
  (complex-double-double-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 _N"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 word-bytes)
			     other-pointer-type)))
    (let ((imag-tn (complex-single-reg-imag-tn y)))
      (inst ldf imag-tn x (- (* complex-single-float-imag-slot word-bytes)
			     other-pointer-type)))))
(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 _N"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 word-bytes)
			      other-pointer-type)))
    (let ((imag-tn (complex-double-reg-imag-tn y)))
      (inst lddf imag-tn x (- (* complex-double-float-imag-slot word-bytes)
			      other-pointer-type)))))
(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 _N"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 word-bytes)
				  other-pointer-type)))
    (let ((imag-tn (complex-long-reg-imag-tn y)))
      (load-long-reg imag-tn x (- (* complex-long-float-imag-slot word-bytes)
				  other-pointer-type)))))
#+long-float
(define-move-vop move-to-complex-long :move
  (descriptor-reg) (complex-long-reg))

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

;;;
;;; Complex float move-argument vop
;;;
(define-vop (move-complex-single-float-argument)
  (:args (x :scs (complex-single-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
  (:results (y))
  (:note _N"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) 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 word-bytes))))))))
(define-move-vop move-complex-single-float-argument :move-argument
  (complex-single-reg descriptor-reg) (complex-single-reg))

(define-vop (move-complex-double-float-argument)
  (:args (x :scs (complex-double-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
  (:results (y))
  (:note _N"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) 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 word-bytes)))))))))
(define-move-vop move-complex-double-float-argument :move-argument
  (complex-double-reg descriptor-reg) (complex-double-reg))

#+long-float
(define-vop (move-complex-long-float-argument)
  (:args (x :scs (complex-long-reg) :target y)
	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
  (:results (y))
  (:note _N"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) 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 word-bytes)))))))))

#+long-float
(define-move-vop move-complex-long-float-argument :move-argument
  (complex-long-reg descriptor-reg) (complex-long-reg))

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

#+double-double
(define-move-vop move-complex-double-double-float-argument :move-argument
  (complex-double-double-reg descriptor-reg) (complex-double-double-reg))

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


;;;; Arithmetic VOPs:

(define-vop (float-op)
  (:args (x) (y))
  (:results (r))
  (:policy :fast-safe)
  (:note _N"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 _N"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)
  (cond ((backend-featurep :sparc-v9)
	 (inst fnegd dst src))
	(t
	 ;; 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 *backend*)
					:offset (+ 1 (tn-offset dst))))
	       (src-odd (make-random-tn :kind :normal
					:sc (sc-or-lose 'single-reg *backend*)
					:offset (+ 1 (tn-offset src)))))
	   (inst fmovs dst-odd src-odd)))))

(defun abs-double-reg (dst src)
  (cond ((backend-featurep :sparc-v9)
	 (inst fabsd dst src))
	(t
	 ;; 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 *backend*)
				      :offset (+ 1 (tn-offset dst))))
	       (src-2 (make-random-tn :kind :normal
				      :sc (sc-or-lose 'single-reg *backend*)
				      :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 _N"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 _N"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 _N"inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (cond ((backend-featurep :sparc-v9)
	   (inst fabsq y x))
	  (t
	   (inst fabss y x)
	   (dotimes (i 3)
	     (let ((y-odd (make-random-tn
			   :kind :normal
			   :sc (sc-or-lose 'single-reg *backend*)
			   :offset (+ i 1 (tn-offset y))))
		   (x-odd (make-random-tn
			   :kind :normal
			   :sc (sc-or-lose 'single-reg *backend*)
			   :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 _N"inline float arithmetic")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 1
    (note-this-location vop :internal-error)
    (cond ((backend-featurep :sparc-v9)
	   (inst fnegq y x))
	  (t
	   (inst fnegs y x)
	   (dotimes (i 3)
	     (let ((y-odd (make-random-tn
			   :kind :normal
			   :sc (sc-or-lose 'single-reg *backend*)
			   :offset (+ i 1 (tn-offset y))))
		   (x-odd (make-random-tn
			   :kind :normal
			   :sc (sc-or-lose 'single-reg *backend*)
			   :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 _N"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.
    (unless (backend-featurep :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))))

#+double-double
(deftransform eql ((x y) (double-double-float double-double-float))
  '(and (eql (double-double-hi x) (double-double-hi y))
	(eql (double-double-lo x) (double-double-lo y))))


;;;; Conversion:

;; Tell the compiler about %%single-float and %%double-float.  Add
;; functions for byte-compiled code.
(macrolet
    ((frob (name type)
       `(progn
	  (defknown ,name ((signed-byte 32))
	    ,type)
	  (defun ,name (n)
	    (declare (type (signed-byte 32) n))
	    (,name n)))))
  (frob %%single-float single-float)
  (frob %%double-float double-float))

;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces.  Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together.  The pieces are done in a way such that no
;; roundoff occurs.  The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two.  The final
;; sum will produce the correct rounded result.  (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(macrolet ((frob (name vop-trans limit unit)
	     `(progn
		(deftransform ,name ((n) ((unsigned-byte 32)))
		  ;; Should this be extended to a (unsigned-byte 53)?  We could.  Just
		  ;; take the low 31 bits, and the rest, and float them and combine
		  ;; them as before.
		  (when (csubtypep (c::continuation-type n)
				   (c::specifier-type '(unsigned-byte 31)))
		    ;; We want to give-up if we know the number can't have the
		    ;; MSB set.  The signed 32-bit vop can handle that.
		    (c::give-up))
		  `(+ (,',vop-trans (ldb (byte ,',limit 0) n))
		      (* (,',vop-trans (ldb (byte ,',(- 32 limit) ,',limit) n))
			 (scale-float ,',unit ,',limit))))
		;; Always convert %foo to %%foo for 32-bit signed values.
		(deftransform ,name ((n) ((signed-byte 32)))
		  `(,',vop-trans n)))))
  ;; If we break up the numbers into the low 12 bits and the high 20
  ;; bits, we can use a single AND instruction to get the low 12 bits.
  ;; This is a microoptimization for Sparc.  Otherwise, the only
  ;; constraint is that the pieces must be small enough to fit in the
  ;; desired float format without rounding.
  (frob %single-float %%single-float 12 1f0)
  (frob %double-float %%double-float 12 1f0))


(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 _N"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) vm:word-bytes))
			    stack-temp)
			   (signed-stack
			    x))))
		    (inst ldf temp
			  (current-nfp-tn vop)
			  (* (tn-offset stack-tn) vm: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))

;; Sparc doesn't have an instruction to convert a 32-bit unsigned
;; integer to a float, but does have one for a 32-bit signed integer.
;; What we do here is break up the 32-bit number into 2 smaller
;; pieces.  Each of these are converted to a float, and the higher
;; order piece is scaled appropriately, and finally everything is
;; summed together.  The pieces are done in a way such that no
;; roundoff occurs.  The scaling should not produce any roundoff
;; either, since the scale factor is an exact power of two.  The final
;; sum will produce the correct rounded result.  (I think,)
;;
;; But need to be careful because we still want to call the VOP for
;; the small pieces, so we need the transform to give up if it's known
;; that the argument is smaller than a 32-bit unsigned integer.
(macrolet ((frob (name limit unit)
	     `(deftransform ,name ((n) ((unsigned-byte 32)))
		;; Should this be extended to a (unsigned-byte 53)?  We could.  Just
		;; take the low 31 bits, and the rest, and float them and combine
		;; them as before.
		(when (csubtypep (c::continuation-type n)
				 (c::specifier-type '(unsigned-byte 31)))
		  ;; We want to give-up if we know the number can't have the
		  ;; MSB set.  The signed 32-bit vop can handle that.
		  (c::give-up))
		`(+ (,',name (ldb (byte ,',limit 0) n))
		    (* (,',name (ldb (byte ,',(- 32 limit) ,',limit) n))
		       (scale-float ,',unit ,',limit))))))
  ;; If we break up the numbers into the low 12 bits and the high 20
  ;; bits, we can use a single AND instruction to get the low 12 bits.
  ;; This is a microoptimization for Sparc.  Otherwise, the only
  ;; constraint is that the pieces must be small enough to fit in the
  ;; desired float format without rounding.
  (frob %single-float 12 1f0)
  (frob %double-float 12 1f0))

(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 _N"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 _N"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) vm:word-bytes)))
		    (signed-reg
		     (inst stf temp (current-nfp-tn vop)
			   (* (tn-offset stack-temp) vm:word-bytes))
		     (inst ldsw y (current-nfp-tn vop)
			   (* (tn-offset stack-temp) vm: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)
  #-sun4
  (frob %unary-round single-reg single-float fstoir)
  #-sun4
  (frob %unary-round double-reg double-float fdtoir))

(define-vop (fast-unary-ftruncate/single-float)
  (:args (x :scs (single-reg)))
  (:arg-types single-float)
  (:results (r :scs (single-reg)))
  (:result-types single-float)
  (:policy :fast-safe)
  (:translate c::fast-unary-ftruncate)
  (:guard (not (backend-featurep :sparc-v9)))
  (:note _N"inline ftruncate")
  (:generator 2
    (inst fstoi r x)
    (inst fitos r r)))

(define-vop (fast-unary-ftruncate/double-float)
  (:args (x :scs (double-reg) :target r))
  (:arg-types double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:policy :fast-safe)
  (:translate c::fast-unary-ftruncate)
  (:guard (not (backend-featurep :sparc-v9)))
  (:note _N"inline ftruncate")
  (:generator 2
    (inst fdtoi r x)
    (inst fitod r r)))

;; The V9 architecture can convert 64-bit integers.
(define-vop (v9-fast-unary-ftruncate/single-float)
  (:args (x :scs (single-reg)))
  (:arg-types single-float)
  (:results (r :scs (single-reg)))
  (:result-types single-float)
  (:temporary (:scs (double-reg)) temp)
  (:policy :fast-safe)
  (:translate c::fast-unary-ftruncate)
  (:guard (backend-featurep :sparc-v9))
  (:note _N"inline ftruncate")
  (:generator 2
    (inst fstox temp x)
    (inst fxtos r temp)))

(define-vop (v9-fast-unary-ftruncate/double-float)
  (:args (x :scs (double-reg) :target r))
  (:arg-types double-float)
  (:results (r :scs (double-reg)))
  (:result-types double-float)
  (:policy :fast-safe)
  (:translate c::fast-unary-ftruncate)
  (:guard (backend-featurep :sparc-v9))
  (:note _N"inline ftruncate")
  (:generator 2
    (inst fdtox r x)
    (inst fxtod r r)))

#+sun4
(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) vm:word-bytes))
	  (inst ldf res (current-nfp-tn vop)
		(* (tn-offset stack-temp) vm:word-bytes)))
	 (single-stack
	  (inst st bits (current-nfp-tn vop)
		(* (tn-offset res) vm:word-bytes)))))
      (signed-stack
       (sc-case res
	 (single-reg
	  (inst ldf res (current-nfp-tn vop)
		(* (tn-offset bits) vm:word-bytes)))
	 (single-stack
	  (unless (location= bits res)
	    (inst ldsw temp (current-nfp-tn vop)
		  (* (tn-offset bits) vm:word-bytes))
	    (inst st temp (current-nfp-tn vop)
		  (* (tn-offset res) vm: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) vm:word-bytes))
      (inst st lo-bits (current-nfp-tn vop)
	    (* (1+ (tn-offset stack-tn)) vm:word-bytes)))
    (when (sc-is res double-reg)
      (inst lddf res (current-nfp-tn vop)
	    (* (tn-offset temp) vm: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) vm:word-bytes))
      (inst st lo1-bits (current-nfp-tn vop)
	    (* (1+ (tn-offset stack-tn)) vm:word-bytes))
      (inst st lo2-bits (current-nfp-tn vop)
	    (* (+ 2 (tn-offset stack-tn)) vm:word-bytes))
      (inst st lo3-bits (current-nfp-tn vop)
	    (* (+ 3 (tn-offset stack-tn)) vm:word-bytes)))
    (when (sc-is res long-reg)
      (load-long-reg res (current-nfp-tn vop)
		     (* (tn-offset temp) vm: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) vm:word-bytes))
	  (inst ldsw bits (current-nfp-tn vop)
		(* (tn-offset stack-temp) vm:word-bytes)))
	 (single-stack
	  (inst ldsw bits (current-nfp-tn vop)
		(* (tn-offset float) vm:word-bytes)))
	 (descriptor-reg
	  (loadw bits float vm:single-float-value-slot
		 vm:other-pointer-type))))
      (signed-stack
       (sc-case float
	 (single-reg
	  (inst stf float (current-nfp-tn vop)
		(* (tn-offset bits) vm: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) vm:word-bytes))
       (inst ldsw hi-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) vm:word-bytes)))
      (double-stack
       (inst ldsw hi-bits (current-nfp-tn vop)
	     (* (tn-offset float) vm:word-bytes)))
      (descriptor-reg
       (loadw hi-bits float vm:double-float-value-slot
	      vm:other-pointer-type)))))

(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) vm:word-bytes))
       (inst ldsw lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
      (double-stack
       (inst ldsw lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset float)) vm:word-bytes)))
      (descriptor-reg
       (loadw lo-bits float (1+ vm:double-float-value-slot)
	      vm:other-pointer-type)))))

(define-vop (double-float-bits)
  (:args (float :scs (double-reg descriptor-reg)
		:load-if (not (sc-is float double-stack))))
  (:results (hi-bits :scs (signed-reg))
	    (lo-bits :scs (unsigned-reg)))
  (:temporary (:scs (double-stack)) stack-temp)
  (:arg-types double-float)
  (:result-types signed-num unsigned-num)
  (:translate kernel::double-float-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) vm:word-bytes))
       (inst ldsw hi-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) vm:word-bytes))
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
      (double-stack
       (inst ldsw hi-bits (current-nfp-tn vop)
	     (* (tn-offset float) vm:word-bytes))
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset float)) vm:word-bytes)))
      (descriptor-reg
       (loadw hi-bits float vm:double-float-value-slot
	      vm:other-pointer-type)
       (loadw lo-bits float (1+ vm:double-float-value-slot)
	      vm:other-pointer-type)))))

#+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 *backend*)
				    :offset (tn-offset float))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) vm:word-bytes)))
       (inst ld exp-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) vm:word-bytes)))
      (long-stack
       (inst ld exp-bits (current-nfp-tn vop)
	     (* (tn-offset float) vm:word-bytes)))
      (descriptor-reg
       (loadw exp-bits float vm:long-float-value-slot
	      vm:other-pointer-type)))))

#+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 *backend*)
				    :offset (tn-offset float))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) vm:word-bytes)))
       (inst ld high-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
      (long-stack
       (inst ld high-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset float)) vm:word-bytes)))
      (descriptor-reg
       (loadw high-bits float (1+ vm:long-float-value-slot)
	      vm:other-pointer-type)))))

#+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 *backend*)
				    :offset (+ 2 (tn-offset float)))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) vm:word-bytes)))
       (inst ld mid-bits (current-nfp-tn vop)
	     (* (tn-offset stack-temp) vm:word-bytes)))
      (long-stack
       (inst ld mid-bits (current-nfp-tn vop)
	     (* (+ 2 (tn-offset float)) vm:word-bytes)))
      (descriptor-reg
       (loadw mid-bits float (+ 2 vm:long-float-value-slot)
	      vm:other-pointer-type)))))

#+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 *backend*)
				    :offset (+ 2 (tn-offset float)))))
	 (inst stdf float (current-nfp-tn vop)
	       (* (tn-offset stack-temp) vm:word-bytes)))
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (1+ (tn-offset stack-temp)) vm:word-bytes)))
      (long-stack
       (inst ld lo-bits (current-nfp-tn vop)
	     (* (+ 3 (tn-offset float)) vm:word-bytes)))
      (descriptor-reg
       (loadw lo-bits float (+ 3 vm:long-float-value-slot)
	      vm:other-pointer-type)))))


;;;; Float mode hackery:

(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 (* 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 (* 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 (* 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 signx new)
	(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 (* 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 (backend-featurep :sparc-v7)
	      (backend-featurep :sparc-v8)
	      (backend-featurep :sparc-v9)))
  (:arg-types double-float)
  (:result-types double-float)
  (:note _N"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 _N"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 _N"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) vm:word-bytes)))
	 (unless (location= real r)
	   (inst stf real nfp offset))
	 (inst stf imag nfp (+ offset vm: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 _N"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) vm:word-bytes)))
	 (unless (location= real r)
	   (inst stdf real nfp offset))
	 (inst stdf imag nfp (+ offset (* 2 vm: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 _N"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) vm:word-bytes)))
	 (unless (location= real r)
	   (store-long-reg real nfp offset))
	 (store-long-reg imag nfp (+ offset (* 4 vm:word-bytes))))))))

(define-vop (complex-single-float-value)
  (:args (x :scs (complex-single-reg descriptor-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))
					   vm:word-bytes)))
      (descriptor-reg
       (inst ldf r x (- (* (ecase slot
			     (:real vm::complex-single-float-real-slot)
			     (:imag vm::complex-single-float-imag-slot))
			   vm:word-bytes)
			vm:other-pointer-type))))))

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

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

(define-vop (complex-double-float-value)
  (:args (x :scs (complex-double-reg descriptor-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))
					    vm:word-bytes)))
      (descriptor-reg
       (inst lddf r x (- (* (ecase slot
				 (:real vm::complex-double-float-real-slot)
				 (:imag vm::complex-double-float-imag-slot))
			       vm:word-bytes)
			    vm:other-pointer-type))))))

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

(define-vop (imagpart/complex-double-float complex-double-float-value)
  (:translate imagpart)
  (:note _N"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))
			 vm:word-bytes))))))

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

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



;;;; Complex float arithmetic

;;; These vops are intended to optimize some complex float arithmetic
;;; by removing lots of redundant moves that the compiler currently
;;; inserts.  It seems the moves are generated because of the way
;;; unboxed complex floats are represented as pairs of registers.  The
;;; compiler doesn't think we can use the parts directly and therefore
;;; copies the parts to another register before operating on them.
;;;
;;; If we had a peephole optimizer, we could make it remove the
;;; redundant moves instead.

#+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 _N"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 _N"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 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"))
	     (load (ecase size
		     (single 'ldf)
		     (double 'lddf)))
	     (zero-sym (ecase size
			 (single '*fp-constant-0f0*)
			 (double '*fp-constant-0d0*)))
	     (slot (ecase size
		     (single vm:single-float-value-slot)
		     (double vm:double-float-value-slot))))
	 `(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)
	    (:temporary (:scs (,real-reg)) zero)
	    (:temporary (:scs (descriptor-reg)) zero-val)
	    (:note _N"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)))
		;; Load up the necessary floating-point zero that we
		;; need.  It would be nice if we could do something
		;; like xr-xr to get a floating-point zero, but that
		;; can cause spurious signals if xr is an infinity or
		;; NaN.
		(load-symbol-value zero-val ,zero-sym)
		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
					     vm:other-pointer-type))
		(inst ,fop rr xr y)
		(inst ,fop ri xi zero)))))))
  
  (frob single + fadds 2)
  (frob single - fsubs 2)
  (frob double + faddd 4)
  (frob double - fsubd 4))

;; Add a float and a complex
(macrolet
    ((frob (size fop 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"))
	     (load (ecase size
		     (single 'ldf)
		     (double 'lddf)))
	     (zero-sym (ecase size
			 (single '*fp-constant-0f0*)
			 (double '*fp-constant-0d0*)))
	     (slot (ecase size
		     (single vm:single-float-value-slot)
		     (double vm:double-float-value-slot))))
	 `(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)
	    (:temporary (:scs (,real-reg)) zero)
	    (:temporary (:scs (descriptor-reg)) zero-val)
	    (:policy :fast-safe)
	    (:note _N"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)))
		(load-symbol-value zero-val ,zero-sym)
		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
					     vm:other-pointer-type))
		(inst ,fop rr xr y)
		(inst ,fop rr xr zero)))))))
  (frob single fadds 1)
  (frob double faddd 2))

;; Subtract a complex from a float.
;;
(macrolet
    ((frob (size fop 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"))
	     (load (ecase size
		     (single 'ldf)
		     (double 'lddf)))
	     (zero-sym (ecase size
			 (single '*fp-constant-0f0*)
			 (double '*fp-constant-0d0*)))
	     (slot (ecase size
		     (single vm:single-float-value-slot)
		     (double vm:double-float-value-slot))))
	 `(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)
	    (:temporary (:scs (,real-reg)) zero)
	    (:temporary (:scs (descriptor-reg)) zero-val)
	    (:policy :fast-safe)
	    (:note _N"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)))
		(load-symbol-value zero-val ,zero-sym)
		(inst ,load zero zero-val (- (* ,slot vm:word-bytes)
					     vm:other-pointer-type))
		(inst ,fop rr x yr)
		(inst ,fop ri zero yi)))))))

  (frob single fsubs 2)
  (frob double fsubd 2))

;; Multiply two complex numbers
(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 _N"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 _N"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 _N"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
;;

(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 _N"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 den ratio)
		(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 fmov 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 _N"inline complex float arithmetic")
	   (:translate /)
	   (:temporary (:sc ,real-sc-type) tmp)
	   (:generator ,cost
	    (let ((xr (,real-part x))
		  (xi (,imag-part x))
		  (rr (,real-part r))
		  (ri (,imag-part r)))
	      (cond ((location= r y)
		     (inst ,fdiv tmp xr y)
		     (inst ,fdiv ri xi y)
		     (,@fmov rr tmp))
		    (t
		     (inst ,fdiv rr xr y) ; xr * y
		     (inst ,fdiv ri xi y) ; xi * yi
		     ))))))))
  (frob single fdivs (inst fmovs) 2)
  (frob double fdivd (move-double-reg) 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 _N"inline complex float division")
	    (:translate /)
	    (:temporary (:sc ,real-reg) ratio)
	    (:temporary (:sc ,real-reg) den)
	    (: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 den ratio)
		(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 ri ratio x) ; ri = (yi/yr)*x
		(inst ,fdiv rr x den)	; rr = x/den
		(inst b done)
		(inst ,fdiv ri ri den) ; ri = (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 ri ratio x) ; ri = (yr/yi)*x
		(inst ,fdiv rr ri den) ; rr = (yr/yi)*x/den
		(inst ,fdiv ri x den) ; ri = x/den
		(emit-label done)

		(,@fneg ri ri)))))))

  (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 _N"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 _N"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 _N"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 _N"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 _N"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 :pt)
		(inst nop)))))))
  (frob single fcmps)
  (frob double fcmpd))


;; Instead of providing vops, we just transform these to the obvious
;; implementation.  There are probably a few unnecessary moves.

(macrolet
    ((cvt (name prototype)
       `(progn
	 (deftransform ,name ((n) (real) * :when :both)
	   '(complex (float n ,prototype)))
	 (deftransform ,name ((n) (complex) * :when :both)
	   '(complex (float (realpart n) ,prototype)
	             (float (imagpart n) ,prototype))))))
  (cvt %complex-single-float 1f0)
  (cvt %complex-double-float 1d0))


) ; 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 #.vm:word-bits)
			     (signed-byte #.vm:word-bits)
			     single-float double-float)
			 (or (unsigned-byte #.vm:word-bits)
			     (signed-byte #.vm:word-bits)
			     single-float double-float))
  (or (unsigned-byte #.vm:word-bits)
      (signed-byte #.vm: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 (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 _N"inline float max")
  (frob max double-reg double-float fcmpd cfmovd 3
	:fcc0 :ge :l _N"inline float max")
  (frob min single-reg single-float fcmps cfmovs 3
	:fcc0 :l :ge _N"inline float min")
  (frob min double-reg double-float fcmpd cfmovd 3
	:fcc0 :l :ge _N"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 _N"inline (signed-byte 32) max")
  (frob max unsigned-reg unsigned-num cmp cmove 5
	:icc :ge :lt _N"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 _N"inline fixnum max")
  (frob min signed-reg signed-num cmp cmove 5
	:icc :lt :ge _N"inline (signed-byte 32) min")
  (frob min unsigned-reg unsigned-num cmp cmove 5
	:icc :lt :ge _N"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 _N"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 _N"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))))))
    
)

(in-package "C")
#+sparc-v9
(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 (the real ,(first args))))
    (t (c::associate-arguments 'min (first args) (rest args)))))

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

;; Derive the types of max and min
(defoptimizer (max derive-type) ((x y))
  ;; It's Y < X instead of X < Y because that's how the
  ;; source-transform, the deftransform and the max function do the
  ;; comparisons.  This is important if the types of X and Y are
  ;; different types, like integer vs double-float because CMUCL
  ;; returns the actual arg, instead of applying float-contagion to
  ;; the result.
  (multiple-value-bind (definitely-< definitely->=)
      (ir1-transform-<-helper y x)
    (cond (definitely-<
	      (continuation-type x))
	  (definitely->=
	      (continuation-type y))
	  (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 y x)
    (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 #.vm:word-bits)))
	(unsigned (specifier-type '(unsigned-byte #.vm: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))
	   `(sparc::%%max x y))
	  ((and (csubtypep x-type unsigned)
		(csubtypep y-type unsigned))
	   `(sparc::%%max x y))
	  ((and (csubtypep x-type d-float)
		(csubtypep y-type d-float))
	   `(sparc::%%max x y))
	  ((and (csubtypep x-type s-float)
		(csubtypep y-type s-float))
	   `(sparc::%%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 #.vm:word-bits)))
	(unsigned (specifier-type '(unsigned-byte #.vm:word-bits)))
	(d-float (specifier-type 'double-float))
	(s-float (specifier-type 'single-float)))
    (cond ((and (csubtypep x-type signed)
		(csubtypep y-type signed))
	   `(sparc::%%min x y))
	  ((and (csubtypep x-type unsigned)
		(csubtypep y-type unsigned))
	   `(sparc::%%min x y))
	  ((and (csubtypep x-type d-float)
		(csubtypep y-type d-float))
	   `(sparc::%%min x y))
	  ((and (csubtypep x-type s-float)
		(csubtypep y-type s-float))
	   `(sparc::%%min x y))
	  (t
	   (let ((arg1 (gensym))
		 (arg2 (gensym)))
	     `(let ((,arg1 x)
		    (,arg2 y))
		(if (< ,arg1 ,arg2)
		    ,arg1 ,arg2)))))))

)



(in-package "SPARC")


;;; Support for double-double floats

#+double-double
(progn
(defun double-double-reg-hi-tn (x)
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (tn-offset x)))

(defun double-double-reg-lo-tn (x)
  ;; The low tn is 2 more than the offset because double regs are
  ;; even.
  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
		  :offset (+ 2 (tn-offset x))))

(define-move-function (load-double-double 4) (vop x y)
  ((double-double-stack) (double-double-reg))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset x) vm:word-bytes)))
    (let ((hi-tn (double-double-reg-hi-tn y)))
      (inst lddf hi-tn nfp offset))
    (let ((lo-tn (double-double-reg-lo-tn y)))
      (inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))

(define-move-function (store-double-double 4) (vop x y)
  ((double-double-reg) (double-double-stack))
  (let ((nfp (current-nfp-tn vop))
	(offset (* (tn-offset y) vm:word-bytes)))
    (let ((hi-tn (double-double-reg-hi-tn x)))
      (inst stdf hi-tn nfp offset))
    (let ((lo-tn (double-double-reg-lo-tn x)))
      (inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))

;;; Double-double float register to register moves

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

;;; Move from a complex float to a descriptor register allocating a
;;; new complex float object in the process.

(define-vop (move-from-double-double)
  (:args (x :scs (double-double-reg) :to :save))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:scs (non-descriptor-reg)) ndescr)
  (:note _N"double-double float to pointer coercion")
  (:generator 13
     (with-fixed-allocation (y ndescr vm::double-double-float-type
			       vm::double-double-float-size))
     (let ((hi-tn (double-double-reg-hi-tn x)))
       (inst stdf hi-tn y (- (* vm::double-double-float-hi-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))
     (let ((lo-tn (double-double-reg-lo-tn x)))
       (inst stdf lo-tn y (- (* vm::double-double-float-lo-slot
				  vm:word-bytes)
			       vm:other-pointer-type)))))
;;;
(define-move-vop move-from-double-double :move
  (double-double-reg) (descriptor-reg))

;;; Move from a descriptor to a double-double float register

(define-vop (move-to-double-double)
  (:args (x :scs (descriptor-reg)))
  (:results (y :scs (double-double-reg)))
  (:note _N"pointer to double-double float coercion")
  (:generator 2
    (let ((hi-tn (double-double-reg-hi-tn y)))
      (inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes)
			     other-pointer-type)))
    (let ((lo-tn (double-double-reg-lo-tn y)))
      (inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes)
			   other-pointer-type)))))

(define-move-vop move-to-double-double :move
  (descriptor-reg) (double-double-reg))

;;; double-double float move-argument vop

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

(define-move-vop move-double-double-float-argument :move-argument
  (double-double-reg descriptor-reg) (double-double-reg))


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

(define-vop (double-double-float-value)
  (:args (x :scs (double-double-reg descriptor-reg) :target r
	    :load-if (not (sc-is x double-double-stack))))
  (:arg-types double-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
      (double-double-reg
       (let ((value-tn (ecase slot
			 (:hi (double-double-reg-hi-tn x))
			 (:lo (double-double-reg-lo-tn x)))))
	 (unless (location= value-tn r)
	   (move-double-reg r value-tn))))
      (double-double-stack
       (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2))
					       (tn-offset x))
					    vm:word-bytes)))
      (descriptor-reg
       (inst lddf r x (- (* vm:word-bytes
			    (ecase slot
			      (:hi vm:double-double-float-hi-slot)
			      (:lo vm:double-double-float-lo-slot)))
			 vm:other-pointer-type))))))

(define-vop (hi/double-double-value double-double-float-value)
  (:translate kernel::double-double-hi)
  (:note _N"double-double high part")
  (:variant :hi))

(define-vop (lo/double-double-value double-double-float-value)
  (:translate kernel::double-double-lo)
  (:note _N"double-double low part")
  (:variant :lo))


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

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

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

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

); progn

