;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.5 1997/04/24 20:27:06 dtc Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains floating point support for the x86.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Re-written and enhanced by Douglas Crosher, 1996, 1997.
;;;

(in-package :x86)


(defmacro ea-for-xf-desc(tn slot)
  `(make-ea
    :dword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))

(defun ea-for-sf-desc(tn)
  (ea-for-xf-desc tn vm:single-float-value-slot))

(defun ea-for-df-desc(tn)
  (ea-for-xf-desc tn vm:double-float-value-slot))

(defmacro ea-for-xf-stack(tn kind)
  `(make-ea
    :dword :base ebp-tn
    :disp (- (* (+ (tn-offset ,tn) (case ,kind (:single 1) (:double 2)))
	      vm:word-bytes))))

(defun ea-for-sf-stack(tn)
  (ea-for-xf-stack tn :single))

(defun ea-for-df-stack(tn)
  (ea-for-xf-stack tn :double))

;;; Abstract out the copying of a FP register to the FP stack top, and
;;; provide two alternatives for its implementation. Note: it's not
;;; necessary to distinguish between a single or double register move
;;; here.
;;;
;;; Using a Pop then load.
(defmacro copy-fp-reg-to-fr0 (reg)
  `(progn 
     (assert (not (zerop (tn-offset ,reg))))
     (inst fstp fr0-tn)
     (inst fld (make-random-tn :kind :normal
			       :sc (sc-or-lose 'double-reg)
			       :offset (1- (tn-offset ,reg))))))
;;;
;;; Using Fxch then Fst to restore the original reg contents.
#+nil
(defmacro copy-fp-reg-to-fr0 (reg)
  `(progn
     (assert (not (zerop (tn-offset ,reg))))
     (inst fxch ,reg)
     (inst fst  ,reg)))


;;;; Move functions:

;;; x is source, y is destination
(define-move-function (load-single 6) (vop x y)
  ((single-stack) (single-reg))
  (with-empty-tn@fp-top(y)
     (inst fld (ea-for-sf-stack x))))

(define-move-function (store-single 6) (vop x y)
  ((single-reg) (single-stack))
  (cond ((zerop (tn-offset x))
	 (inst fst (ea-for-sf-stack y)))
	(t
	 (inst fxch x)
	 (inst fst (ea-for-sf-stack y))
	 ;; This may not be necessary as ST0 is likely invalid now.
	 (inst fxch x))))

(define-move-function (load-double 6) (vop x y)
  ((double-stack) (double-reg))
  (with-empty-tn@fp-top(y)
     (inst fldd (ea-for-df-stack x))))

(define-move-function (store-double 6) (vop x y)
  ((double-reg) (double-stack))
  (cond ((zerop (tn-offset x))
	 (inst fstd (ea-for-df-stack y)))
	(t
	 (inst fxch x)
	 (inst fstd (ea-for-df-stack y))
	 ;; This may not be necessary as ST0 is likely invalid now.
	 (inst fxch x))))

;;; The i387 has instructions to load some useful constants.
;;; This doesn't save much time but might cut down on memory
;;; access and reduce the size of the constant vector (CV).
;;; Intel claims they are stored in a more precise form on chip.
;;; Anyhow, might as well use the feature. It can be turned
;;; off by hacking the "immediate-constant-sc" in vm.lisp.
(define-move-function (load-fp-constant 6) (vop x y)
  ((fp-single-constant)(single-reg)
   (fp-double-constant)(double-reg))

  (let ((value (c::constant-value (c::tn-leaf x))))
    (with-empty-tn@fp-top(y)
      (cond ((zerop value)
	     (inst fldz))
	    ((or (= value 1s0)(= value 1d0))
	     (inst fld1))
	    ((= value #.pi)
	     (inst fldpi))
	    ((= value #.i387-l2t)
	     (inst fldl2t))
	    ((= value #.i387-l2e)
	     (inst fldl2e))
	    ((= value #.i387-lg2)
	     (inst fldlg2))
	    ((= value #.i387-ln2)
	     (inst fldln2))
	    (t (warn "Ignoring bogus i387 Constant ~a" value))))))


;;;; Move VOPs:

;;;
;;; Float register to register moves.
;;;
(define-vop (single-move)
  (:args (x :scs (single-reg) :target y
	    :load-if (not (and (sc-is x single-stack)
			       (sc-is y single-stack)
			       (location= x y)))))
  (:results (y :scs (single-reg)
	       :load-if (not (and (sc-is x single-stack)
				  (sc-is y single-stack)
				  (location= x y)))))
  (:note "float move")
  (:generator 0
     (unless (location= x y)
        (cond ((zerop (tn-offset y))
	       (copy-fp-reg-to-fr0 x))
	      ((zerop (tn-offset x))
	       (inst fst y))
	      (t
	       (inst fxch x)
	       (inst fst y)
	       (inst fxch x))))))
(define-move-vop single-move :move (single-reg) (single-reg))

(define-vop (double-move)
  (:args (x :scs (double-reg) :target y
	    :load-if (not (and (sc-is x double-stack)
			       (sc-is y double-stack)
			       (location= x y)))))
  (:results (y :scs (double-reg)
	       :load-if (not (and (sc-is x double-stack)
				  (sc-is y double-stack)
				  (location= x y)))))
  (:note "float move")
  (:generator 0
     (unless (location= x y)
        (cond ((zerop (tn-offset y))
	       (copy-fp-reg-to-fr0 x))
	      ((zerop (tn-offset x))
	       (inst fstd y))
	      (t
	       (inst fxch x)
	       (inst fstd y)
	       (inst fxch x))))))
(define-move-vop double-move :move (double-reg) (double-reg))


;;;
;;; Move from float to a descriptor reg. allocating a new float
;;; object in the process.
;;;
(define-vop (move-from-single)
  (:args (x :scs (single-reg) :to :save
	    :load-if (not (sc-is x fp-single-constant))))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:sc dword-reg) ndescr)
  (:note "float to pointer coercion")
  (:generator 13
     (if (sc-is x fp-single-constant)
	 (ecase (c::constant-value (c::tn-leaf x))
		(0f0 (load-symbol-value y *fp-constant-0s0*))
		(1f0 (load-symbol-value y *fp-constant-1s0*)))
       (with-fixed-allocation (y ndescr vm:single-float-type
				 vm:single-float-size)
	    (with-tn@fp-top(x)
	      (inst fst (make-ea :dword :base y
				 :disp (- (* vm:single-float-value-slot
					     vm:word-bytes)
					  vm:other-pointer-type))))))))
(define-move-vop move-from-single :move
  (single-reg) (descriptor-reg))

(define-vop (move-from-double)
  (:args (x :scs (double-reg) :to :save
	    :load-if (not (sc-is x fp-double-constant))))
  (:results (y :scs (descriptor-reg)))
  (:temporary (:sc dword-reg) ndescr)
  (:note "float to pointer coercion")
  (:generator 13
     (if (sc-is x fp-double-constant)
	 (ecase (c::constant-value (c::tn-leaf x))
		(0d0 (load-symbol-value y *fp-constant-0d0*))
		(1d0 (load-symbol-value y *fp-constant-1d0*)))
       (with-fixed-allocation (y ndescr vm:double-float-type
				 vm:double-float-size)
          (with-tn@fp-top(x)
             (inst fstd (make-ea :dword :base y
				 :disp (- (* vm:double-float-value-slot
					     vm:word-bytes)
					  vm:other-pointer-type))))))))
(define-move-vop move-from-double :move
  (double-reg) (descriptor-reg))

;;;
;;; Move from a descriptor to a float register
;;;
(macrolet ((frob (name sc double-p)
	     `(progn
		(define-vop (,name)
		  (:args (x :scs (descriptor-reg)))
		  (:results (y :scs (,sc)))
		  (:note "pointer to float coercion")
		  (:generator 2
		     (with-empty-tn@fp-top(y)
		       ,@(if double-p
			     '((inst fldd (ea-for-df-desc x)))
			   '((inst fld  (ea-for-sf-desc x)))))))
		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
	  (frob move-to-single single-reg nil)
	  (frob move-to-double double-reg   t))

;;;
;;; The move argument vops.
;;;
;;; Note these are also used to stuffs fp numbers onto the c-call
;;; stack so the order is different than the lisp-stack.

;;; The general move-argument vop
(macrolet ((frob (name sc stack-sc double-p)
	     `(progn
		(define-vop (,name)
		  (:args (x :scs (,sc) :target y)
			 (fp :scs (any-reg)
			     :load-if (not (sc-is y ,sc))))
		  (:results (y))
		  (:note "float argument move")
		  (:generator ,(if double-p 3 2)
		    (sc-case y
		      (,sc
		       (unless (location= x y)
	                  (cond ((zerop (tn-offset y))
				 (copy-fp-reg-to-fr0 x))
				((zerop (tn-offset x))
				 (inst fstd y))
				(t
				 (inst fxch x)
				 (inst fstd y)
				 (inst fxch x)))))
		      (,stack-sc
		       (if (= (tn-offset fp) esp-offset)
			   (let* ((offset (* (tn-offset y) word-bytes))
				  (ea (make-ea :dword :base fp :disp offset)))
			     (with-tn@fp-top(x)
					    ,@(if double-p
						  '((inst fstd ea))
						'((inst fst  ea)))))
			 (let ((ea (make-ea
				    :dword :base fp
				    :disp (- (* (+ (tn-offset y)
						   ,(if double-p 2 1))
						vm:word-bytes)))))
			   (with-tn@fp-top(x)
					  ,@(if double-p
						'((inst fstd ea))
					      '((inst fst  ea))))))))))
		(define-move-vop ,name :move-argument
		  (,sc descriptor-reg) (,sc)))))
  (frob move-single-float-argument single-reg single-stack nil)
  (frob move-double-float-argument double-reg double-stack t))


;;;
(define-move-vop move-argument :move-argument
  (single-reg double-reg) (descriptor-reg any-reg))


;;;; Arithmetic VOPs:

;;; dtc: The floating point arithmetic vops.
;;; 
;;; Note: Although these can accept x and y on the stack or pointed to
;;; from a descriptor register, they will work with register loading
;;; without these.  Same deal with the result - it need only be a
;;; register.  When load-tns are needed they will probably be in ST0
;;; and the code below should be able to correctly handle all cases.
;;;
;;; However it seems to produce better code if all arg. and result
;;; options are used; on the P86 there is no extra cost in using a
;;; memory operand to the FP instructions - not so on the PPro.
;;;
;;; It may also be useful to handle constant args?
(macrolet
    ((frob (op fop-sti fopr-sti
	       fop fopr sname scost
	       fopd foprd dname dcost)
       `(progn
	 (define-vop (,sname)
	   (:translate ,op)
	   (:args (x :scs (single-reg single-stack descriptor-reg)
		     :to :eval)
		  (y :scs (single-reg single-stack descriptor-reg)
		     :to :eval))
	   (:temporary (:sc single-reg :offset fr0-offset
			    :from :eval :to :result) fr0)
	   (:results (r :scs (single-reg single-stack)))
	   (:arg-types single-float single-float)
	   (:result-types single-float)
	   (:policy :fast-safe)
	   (:note "inline float arithmetic")
	   (:vop-var vop)
	   (:save-p :compute-only)
	   (:node-var node)
	   (:generator ,scost
	     ;; Handle a few special cases
	     (cond
	      ;; x, y, and r are the same register.
	      ((and (sc-is x single-reg) (location= x r) (location= y r))
	       (cond ((zerop (tn-offset r))
		      (inst ,fop fr0))
		     (t
		      (inst fxch r)
		      (inst ,fop fr0)
		      ;; XX the source register will not be valid.
		      (note-next-instruction vop :internal-error)
		      (inst fxch r))))

	      ;; x and r are the same register.
	      ((and (sc-is x single-reg) (location= x r))
	       (cond ((zerop (tn-offset r))
		      (sc-case y
		         (single-reg
			  ;; ST(0) = ST(0) op ST(y)
			  (inst ,fop y))
			 (single-stack
			  ;; ST(0) = ST(0) op Mem
			  (inst ,fop (ea-for-sf-stack y)))
			 (descriptor-reg
			  (inst ,fop (ea-for-sf-desc y)))))
		     (t
		      ;; y to ST0
		      (sc-case y
	                 (single-reg
			  (unless (zerop (tn-offset y))
				  (copy-fp-reg-to-fr0 y)))
			 ((single-stack descriptor-reg)
			  (inst fstp fr0)
			  (if (sc-is y single-stack)
			      (inst fld (ea-for-sf-stack y))
			    (inst fld (ea-for-sf-desc y)))))
		      ;; ST(i) = ST(i) op ST0
		      (inst ,fop-sti r)))
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
	      ;; y and r are the same register.
	      ((and (sc-is y single-reg) (location= y r))
	       (cond ((zerop (tn-offset r))
		      (sc-case x
	                 (single-reg
			  ;; ST(0) = ST(x) op ST(0)
			  (inst ,fopr x))
			 (single-stack
			  ;; ST(0) = Mem op ST(0)
			  (inst ,fopr (ea-for-sf-stack x)))
			 (descriptor-reg
			  (inst ,fopr (ea-for-sf-desc x)))))
		     (t
		      ;; x to ST0
		      (sc-case x
		        (single-reg
			 (unless (zerop (tn-offset x))
				 (copy-fp-reg-to-fr0 x)))
			((single-stack descriptor-reg)
			 (inst fstp fr0)
			 (if (sc-is x single-stack)
			     (inst fld (ea-for-sf-stack x))
			   (inst fld (ea-for-sf-desc x)))))
		      ;; ST(i) = ST(0) op ST(i)
		      (inst ,fopr-sti r)))
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
	      ;; The default case
	      (t
	       ;; Get the result to ST0.

	       ;; Special handling is needed if x or y are in ST0, and
	       ;; simpler code is generated.
	       (cond
		;; x is in ST0
		((and (sc-is x single-reg) (zerop (tn-offset x)))
		 ;; ST0 = ST0 op y
		 (sc-case y
	           (single-reg
		    (inst ,fop y))
		   (single-stack
		    (inst ,fop (ea-for-sf-stack y)))
		   (descriptor-reg
		    (inst ,fop (ea-for-sf-desc y)))))
		;; y is in ST0
		((and (sc-is y single-reg) (zerop (tn-offset y)))
		 ;; ST0 = x op ST0
		 (sc-case x
	           (single-reg
		    (inst ,fopr x))
		   (single-stack
		    (inst ,fopr (ea-for-sf-stack x)))
		   (descriptor-reg
		    (inst ,fopr (ea-for-sf-desc x)))))
		(t
		 ;; x to ST0
		 (sc-case x
	           (single-reg
		    (copy-fp-reg-to-fr0 x))
		   (single-stack
		    (inst fstp fr0)
		    (inst fld (ea-for-sf-stack x)))
		   (descriptor-reg
		    (inst fstp fr0)
		    (inst fld (ea-for-sf-desc x))))
		 ;; ST0 = ST0 op y
		 (sc-case y
	           (single-reg
		    (inst ,fop y))
		   (single-stack
		    (inst ,fop (ea-for-sf-stack y)))
		   (descriptor-reg
		    (inst ,fop (ea-for-sf-desc y))))))

	       (note-next-instruction vop :internal-error)

	       ;; Finally save the result
	       (sc-case r
	         (single-reg
		  (cond ((zerop (tn-offset r))
			 (when (policy node (or (= debug 3) (> safety speed)))
			       (inst wait)))
			(t
			 (inst fst r))))
		 (single-stack
		  (inst fst (ea-for-sf-stack r))))))))
	       
	 (define-vop (,dname)
	   (:translate ,op)
	   (:args (x :scs (double-reg double-stack descriptor-reg)
		     :to :eval)
		  (y :scs (double-reg double-stack descriptor-reg)
		     :to :eval))
	   (:temporary (:sc double-reg :offset fr0-offset
			    :from :eval :to :result) fr0)
	   (:results (r :scs (double-reg double-stack)))
	   (:arg-types double-float double-float)
	   (:result-types double-float)
	   (:policy :fast-safe)
	   (:note "inline float arithmetic")
	   (:vop-var vop)
	   (:save-p :compute-only)
	   (:node-var node)
	   (:generator ,dcost
	     ;; Handle a few special cases
	     (cond
	      ;; x, y, and r are the same register.
	      ((and (sc-is x double-reg) (location= x r) (location= y r))
	       (cond ((zerop (tn-offset r))
		      (inst ,fop fr0))
		     (t
		      (inst fxch x)
		      (inst ,fopd fr0)
		      ;; XX the source register will not be valid.
		      (note-next-instruction vop :internal-error)
		      (inst fxch r))))
	      
	      ;; x and r are the same register.
	      ((and (sc-is x double-reg) (location= x r))
	       (cond ((zerop (tn-offset r))
		      (sc-case y
	                 (double-reg
			  ;; ST(0) = ST(0) op ST(y)
			  (inst ,fopd y))
			 (double-stack
			  ;; ST(0) = ST(0) op Mem
			  (inst ,fopd (ea-for-df-stack y)))
			 (descriptor-reg
			  (inst ,fopd (ea-for-df-desc y)))))
		     (t
		      ;; y to ST0
		      (sc-case y
	                 (double-reg
			  (unless (zerop (tn-offset y))
				  (copy-fp-reg-to-fr0 y)))
			 ((double-stack descriptor-reg)
			  (inst fstp fr0)
			  (if (sc-is y double-stack)
			      (inst fldd (ea-for-df-stack y))
			    (inst fldd (ea-for-df-desc y)))))
		      ;; ST(i) = ST(i) op ST0
		      (inst ,fop-sti r)))
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
	      ;; y and r are the same register.
	      ((and (sc-is y double-reg) (location= y r))
	       (cond ((zerop (tn-offset r))
		      (sc-case x
	                 (double-reg
			  ;; ST(0) = ST(x) op ST(0)
			  (inst ,foprd x))
			 (double-stack
			  ;; ST(0) = Mem op ST(0)
			  (inst ,foprd (ea-for-df-stack x)))
			 (descriptor-reg
			  (inst ,foprd (ea-for-df-desc x)))))
		     (t
		      ;; x to ST0
		      (sc-case x
		         (double-reg
			  (unless (zerop (tn-offset x))
				  (copy-fp-reg-to-fr0 x)))
			 ((double-stack descriptor-reg)
			  (inst fstp fr0)
			  (if (sc-is x double-stack)
			      (inst fldd (ea-for-df-stack x))
			    (inst fldd (ea-for-df-desc x)))))
		      ;; ST(i) = ST(0) op ST(i)
		      (inst ,fopr-sti r)))
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
	      ;; The default case
	      (t
	       ;; Get the result to ST0.

	       ;; Special handling is needed if x or y are in ST0, and
	       ;; simpler code is generated.
	       (cond
		;; x is in ST0
		((and (sc-is x double-reg) (zerop (tn-offset x)))
		 ;; ST0 = ST0 op y
		 (sc-case y
	           (double-reg
		    (inst ,fopd y))
		   (double-stack
		    (inst ,fopd (ea-for-df-stack y)))
		   (descriptor-reg
		    (inst ,fopd (ea-for-df-desc y)))))
		;; y is in ST0
		((and (sc-is y double-reg) (zerop (tn-offset y)))
		 ;; ST0 = x op ST0
		 (sc-case x
	           (double-reg
		    (inst ,foprd x))
		   (double-stack
		    (inst ,foprd (ea-for-df-stack x)))
		   (descriptor-reg
		    (inst ,foprd (ea-for-df-desc x)))))
		(t
		 ;; x to ST0
		 (sc-case x
	           (double-reg
		    (copy-fp-reg-to-fr0 x))
		   (double-stack
		    (inst fstp fr0)
		    (inst fldd (ea-for-df-stack x)))
		   (descriptor-reg
		    (inst fstp fr0)
		    (inst fldd (ea-for-df-desc x))))
		 ;; ST0 = ST0 op y
		 (sc-case y
		   (double-reg
		    (inst ,fopd y))
		   (double-stack
		    (inst ,fopd (ea-for-df-stack y)))
		   (descriptor-reg
		    (inst ,fopd (ea-for-df-desc y))))))

	       (note-next-instruction vop :internal-error)

	       ;; Finally save the result
	       (sc-case r
	         (double-reg
		  (cond ((zerop (tn-offset r))
			 (when (policy node (or (= debug 3) (> safety speed)))
			       (inst wait)))
			(t
			 (inst fst r))))
		 (double-stack
		  (inst fstd (ea-for-df-stack r)))))))))))
    
    (frob + fadd-sti fadd-sti
	  fadd fadd +/single-float 2
	  faddd faddd +/double-float 2)
    (frob - fsub-sti fsubr-sti
	  fsub fsubr -/single-float 2
	  fsubd fsubrd -/double-float 2)
    (frob * fmul-sti fmul-sti
	  fmul fmul */single-float 3
	  fmuld fmuld */double-float 3)
    (frob / fdiv-sti fdivr-sti
	  fdiv fdivr //single-float 12
	  fdivd fdivrd //double-float 12))


(macrolet ((frob (name inst translate sc type)
	     `(define-vop (,name)
	       (:args (x :scs (,sc) :target fr0))
	       (:results (y :scs (,sc)))
	       (:translate ,translate)
	       (:policy :fast-safe)
	       (:arg-types ,type)
	       (:result-types ,type)
	       (:temporary (:sc double-reg :offset fr0-offset
				:from :argument :to :result) fr0)
	       (:ignore fr0)
	       (:note "inline float arithmetic")
	       (:vop-var vop)
	       (:save-p :compute-only)
	       (:generator 1
		(note-this-location vop :internal-error)
		(unless (zerop (tn-offset x))
		  (inst fxch x)		; x to top of stack
		  (unless (location= x y)
		    (inst fst x)))	; maybe save it
		(inst ,inst)		; clobber st0
		(unless (zerop (tn-offset y))
		  (inst fst y))))))

  (frob abs/single-float fabs abs single-reg single-float)
  (frob abs/double-float fabs abs double-reg double-float)
  (frob %negate/single-float fchs %negate single-reg single-float)
  (frob %negate/double-float fchs %negate double-reg double-float))


;;;; Comparison:

(define-vop (=/float)
  (:args (x) (y))
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
     (note-this-location vop :internal-error)
     (cond
      ;; x is in ST0; y is in any reg.
      ((zerop (tn-offset x))
       (inst fucom y))
      ;; y is in ST0; x is in another reg.
      ((zerop (tn-offset y))
       (inst fucom x))
      ;; x and y are the same register, not ST0
      ((location= x y)
       (inst fxch x)
       (inst fucom fr0-tn)
       (inst fxch x))
      ;; x and y are different registers, neither ST0.
      (t
       (inst fxch x)
       (inst fucom y)
       (inst fxch x)))
     (inst fnstsw)			; status word to %ea
     (inst and ah-tn #x45)		; C3 C2 C0
     (inst cmp ah-tn #x40)
     (inst jmp (if not-p :ne :e) target)))

(define-vop (=/single-float =/float)
  (:translate =)
  (:args (x :scs (single-reg))
	 (y :scs (single-reg)))
  (:arg-types single-float single-float))

(define-vop (=/double-float =/float)
  (:translate =)
  (:args (x :scs (double-reg))
	 (y :scs (double-reg)))
  (:arg-types double-float double-float))


(define-vop (<single-float)
  (:translate <)
  (:args (x :scs (single-reg single-stack descriptor-reg))
	 (y :scs (single-reg single-stack descriptor-reg)))
  (:arg-types single-float single-float)
  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases
    (cond
     ;; y is ST0.
     ((and (sc-is y single-reg) (zerop (tn-offset y)))
      (sc-case x
        (single-reg
	 (inst fcom x))
	((single-stack descriptor-reg)
	 (if (sc-is x single-stack)
	     (inst fcom (ea-for-sf-stack x))
	   (inst fcom (ea-for-sf-desc x)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45))

     ;; General case when y is not in ST0.
     (t
      ;; x to ST0
      (sc-case x
         (single-reg
	  (unless (zerop (tn-offset x))
		  (copy-fp-reg-to-fr0 x)))
	 ((single-stack descriptor-reg)
	  (inst fstp fr0)
	  (if (sc-is x single-stack)
	      (inst fld (ea-for-sf-stack x))
	    (inst fld (ea-for-sf-desc x)))))
      (sc-case y
        (single-reg
	 (inst fcom y))
	((single-stack descriptor-reg)
	 (if (sc-is y single-stack)
	     (inst fcom (ea-for-sf-stack y))
	   (inst fcom (ea-for-sf-desc y)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)		; C3 C2 C0
      (inst cmp ah-tn #x01)))
    (inst jmp (if not-p :ne :e) target)))

(define-vop (<double-float)
  (:translate <)
  (:args (x :scs (double-reg double-stack descriptor-reg))
	 (y :scs (double-reg double-stack descriptor-reg)))
  (:arg-types double-float double-float)
  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases
    (cond
     ;; y is ST0.
     ((and (sc-is y double-reg) (zerop (tn-offset y)))
      (sc-case x
        (double-reg
	 (inst fcomd x))
	((double-stack descriptor-reg)
	 (if (sc-is x double-stack)
	     (inst fcomd (ea-for-df-stack x))
	   (inst fcomd (ea-for-df-desc x)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45))

     ;; General case when y is not in ST0.
     (t
      ;; x to ST0
      (sc-case x
         (double-reg
	  (unless (zerop (tn-offset x))
		  (copy-fp-reg-to-fr0 x)))
	 ((double-stack descriptor-reg)
	  (inst fstp fr0)
	  (if (sc-is x double-stack)
	      (inst fldd (ea-for-df-stack x))
	    (inst fldd (ea-for-df-desc x)))))
      (sc-case y
        (double-reg
	 (inst fcomd y))
	((double-stack descriptor-reg)
	 (if (sc-is y double-stack)
	     (inst fcomd (ea-for-df-stack y))
	   (inst fcomd (ea-for-df-desc y)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)		; C3 C2 C0
      (inst cmp ah-tn #x01)))
    (inst jmp (if not-p :ne :e) target)))


(define-vop (>single-float)
  (:translate >)
  (:args (x :scs (single-reg single-stack descriptor-reg))
	 (y :scs (single-reg single-stack descriptor-reg)))
  (:arg-types single-float single-float)
  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases
    (cond
     ;; y is ST0.
     ((and (sc-is y single-reg) (zerop (tn-offset y)))
      (sc-case x
        (single-reg
	 (inst fcom x))
	((single-stack descriptor-reg)
	 (if (sc-is x single-stack)
	     (inst fcom (ea-for-sf-stack x))
	   (inst fcom (ea-for-sf-desc x)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)
      (inst cmp ah-tn #x01))

     ;; General case when y is not in ST0.
     (t
      ;; x to ST0
      (sc-case x
         (single-reg
	  (unless (zerop (tn-offset x))
		  (copy-fp-reg-to-fr0 x)))
	 ((single-stack descriptor-reg)
	  (inst fstp fr0)
	  (if (sc-is x single-stack)
	      (inst fld (ea-for-sf-stack x))
	    (inst fld (ea-for-sf-desc x)))))
      (sc-case y
        (single-reg
	 (inst fcom y))
	((single-stack descriptor-reg)
	 (if (sc-is y single-stack)
	     (inst fcom (ea-for-sf-stack y))
	   (inst fcom (ea-for-sf-desc y)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)))
    (inst jmp (if not-p :ne :e) target)))

(define-vop (>double-float)
  (:translate >)
  (:args (x :scs (double-reg double-stack descriptor-reg))
	 (y :scs (double-reg double-stack descriptor-reg)))
  (:arg-types double-float double-float)
  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp)
  (:generator 3
    ;; Handle a few special cases
    (cond
     ;; y is ST0.
     ((and (sc-is y double-reg) (zerop (tn-offset y)))
      (sc-case x
        (double-reg
	 (inst fcomd x))
	((double-stack descriptor-reg)
	 (if (sc-is x double-stack)
	     (inst fcomd (ea-for-df-stack x))
	   (inst fcomd (ea-for-df-desc x)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)
      (inst cmp ah-tn #x01))

     ;; General case when y is not in ST0.
     (t
      ;; x to ST0
      (sc-case x
         (double-reg
	  (unless (zerop (tn-offset x))
		  (copy-fp-reg-to-fr0 x)))
	 ((double-stack descriptor-reg)
	  (inst fstp fr0)
	  (if (sc-is x double-stack)
	      (inst fldd (ea-for-df-stack x))
	    (inst fldd (ea-for-df-desc x)))))
      (sc-case y
        (double-reg
	 (inst fcomd y))
	((double-stack descriptor-reg)
	 (if (sc-is y double-stack)
	     (inst fcomd (ea-for-df-stack y))
	   (inst fcomd (ea-for-df-desc y)))))
      (inst fnstsw)			; status word to %ea
      (inst and ah-tn #x45)))
    (inst jmp (if not-p :ne :e) target)))

;;; Comparisons with 0 can use the FTST instruction.

(define-vop (float-test)
  (:args (x))
  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
  (:conditional)
  (:info target not-p y)
  (:variant-vars code)
  (:policy :fast-safe)
  (:vop-var vop)
  (:save-p :compute-only)
  (:note "inline float comparison")
  (:ignore temp y)
  (:generator 2
     (note-this-location vop :internal-error)
     (cond
      ;; x is in ST0
      ((zerop (tn-offset x))
       (inst ftst))
      ;; x not ST0
      (t
       (inst fxch x)
       (inst ftst)
       (inst fxch x)))
     (inst fnstsw)			; status word to %ea
     (inst and ah-tn #x45)		; C3 C2 C0
     (unless (zerop code)
        (inst cmp ah-tn code))
     (inst jmp (if not-p :ne :e) target)))

(define-vop (=0/single-float float-test)
  (:translate =)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x40))
(define-vop (=0/double-float float-test)
  (:translate =)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x40))

(define-vop (<0/single-float float-test)
  (:translate <)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x01))
(define-vop (<0/double-float float-test)
  (:translate <)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x01))

(define-vop (>0/single-float float-test)
  (:translate >)
  (:args (x :scs (single-reg)))
  (:arg-types single-float (:constant (single-float 0f0 0f0)))
  (:variant #x00))
(define-vop (>0/double-float float-test)
  (:translate >)
  (:args (x :scs (double-reg)))
  (:arg-types double-float (:constant (double-float 0d0 0d0)))
  (:variant #x00))


;;;; Conversion:

(macrolet ((frob (name translate to-sc to-type)
	     `(define-vop (,name)
		(:args (x :scs (signed-stack signed-reg) :target temp))
		(:temporary (:sc signed-stack) temp)
		(:results (y :scs (,to-sc)))
		(:arg-types signed-num)
		(:result-types ,to-type)
		(:policy :fast-safe)
		(:note "inline float coercion")
		(:translate ,translate)
		(:vop-var vop)
		(:save-p :compute-only)
		(:generator 5
		  (sc-case x
		    (signed-reg
		     (inst mov temp x)
		     (with-empty-tn@fp-top(y)
		       (note-this-location vop :internal-error)
		       (inst fild temp)))
		    (signed-stack
		     (with-empty-tn@fp-top(y)
		       (note-this-location vop :internal-error)
		       (inst fild x))))))))
  (frob %single-float/signed %single-float single-reg single-float)
  (frob %double-float/signed %double-float double-reg double-float))

(macrolet ((frob (name translate to-sc to-type)
	     `(define-vop (,name)
		(:args (x :scs (unsigned-reg)))
		(:results (y :scs (,to-sc)))
		(:arg-types unsigned-num)
		(:result-types ,to-type)
		(:policy :fast-safe)
		(:note "inline float coercion")
		(:translate ,translate)
		(:vop-var vop)
		(:save-p :compute-only)
		(:generator 5
		 (inst push 0)
		 (inst push x)
		 (with-empty-tn@fp-top(y)
		   (note-this-location vop :internal-error)
		   (inst fildl (make-ea :dword :base esp-tn)))
		 (inst add esp-tn 8)))))
  (frob %single-float/unsigned %single-float single-reg single-float)
  (frob %double-float/unsigned %double-float double-reg double-float))

;;; These should be no-ops but the compiler might want to move
;;; some things around
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
	     `(define-vop (,name)
	       (:args (x :scs (,from-sc) :target y))
	       (:results (y :scs (,to-sc)))
	       (:arg-types ,from-type)
	       (:result-types ,to-type)
	       (:policy :fast-safe)
	       (:note "inline float coercion")
	       (:translate ,translate)
	       (:vop-var vop)
	       (:save-p :compute-only)
	       (:generator 2
		(note-this-location vop :internal-error)
		(unless (location= x y)
		  (cond 
		   ((zerop (tn-offset x))
		    ;; x is in ST0, y is in another reg. not ST0
		    (inst fst  y))
		   ((zerop (tn-offset y))
		    ;; y is in ST0, x is in another reg. not ST0
		    (copy-fp-reg-to-fr0 x))
		   (t
		    ;; Neither x or y are in ST0, and they are not in
		    ;; the same reg.
		    (inst fxch x)
		    (inst fst  y)
		    (inst fxch x))))))))
  
  (frob %single-float/double-float %single-float double-reg
	double-float single-reg single-float)
  (frob %double-float/single-float %double-float single-reg single-float
	double-reg double-float))



(macrolet ((frob (trans from-sc from-type round-p)
	     `(define-vop (,(symbolicate trans "/" from-type))
	       (:args (x :scs (,from-sc)))
	       (:temporary (:sc signed-stack) stack-temp)
	       ,@(unless round-p
		       '((:temporary (:sc unsigned-stack) scw)
			 (:temporary (:sc any-reg) rcw)))
	       (:results (y :scs (signed-reg)))
	       (:arg-types ,from-type)
	       (:result-types signed-num)
	       (:translate ,trans)
	       (:policy :fast-safe)
	       (:note "inline float truncate")
	       (:vop-var vop)
	       (:save-p :compute-only)
	       (:generator 5
		,@(unless round-p
		   '((note-this-location vop :internal-error)
		     ;; Catch any pending FPE exceptions.
		     (inst wait)))
		;; normal mode (for now) is "round to best"
		(with-tn@fp-top(x)
		  ,@(unless round-p
		    '((inst fnstcw scw)	; save current control word
		      (move rcw scw)	; into 16-bit register
		      (inst or rcw (ash #b11 10)) ; CHOP
		      (move stack-temp rcw)
		      (inst fldcw stack-temp)))
		  (sc-case y
		    (signed-stack
		     (inst fist y))
		    (signed-reg
		     (inst fist stack-temp)
		     (inst mov y stack-temp)))
		  ,@(unless round-p
		     '((inst fldcw scw))))))))
  (frob %unary-truncate single-reg single-float nil)
  (frob %unary-truncate double-reg double-float nil)
  (frob %unary-round single-reg single-float t)
  (frob %unary-round double-reg double-float t))

(macrolet ((frob (trans from-sc from-type round-p)
	     `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
	       (:args (x :scs (,from-sc) :target fr0))
	       (:temporary (:sc double-reg :offset fr0-offset
			    :from :argument :to :result) fr0)
	       ,@(unless round-p
		  '((:temporary (:sc unsigned-stack) stack-temp)
		    (:temporary (:sc unsigned-stack) scw)
		    (:temporary (:sc any-reg) rcw)))
	       (:results (y :scs (unsigned-reg)))
	       (:arg-types ,from-type)
	       (:result-types unsigned-num)
	       (:translate ,trans)
	       (:policy :fast-safe)
	       (:note "inline float truncate")
	       (:vop-var vop)
	       (:save-p :compute-only)
	       (:generator 5
		,@(unless round-p
		   '((note-this-location vop :internal-error)
		     ;; Catch any pending FPE exceptions.
		     (inst wait)))
		;; normal mode (for now) is "round to best"
		(unless (zerop (tn-offset x))
		  (copy-fp-reg-to-fr0 x))
		,@(unless round-p
		   '((inst fnstcw scw)	; save current control word
		     (move rcw scw)	; into 16-bit register
		     (inst or rcw (ash #b11 10)) ; CHOP
		     (move stack-temp rcw)
		     (inst fldcw stack-temp)))
		(inst sub esp-tn 8)
		(inst fistpl (make-ea :dword :base esp-tn))
		(inst pop y)
		(inst fld fr0) ; copy fr0 to at least restore stack.
		(inst add esp-tn 4)
		,@(unless round-p
		   '((inst fldcw scw)))))))
  (frob %unary-truncate single-reg single-float nil)
  (frob %unary-truncate double-reg double-float nil)
  (frob %unary-round single-reg single-float t)
  (frob %unary-round double-reg double-float t))


(define-vop (make-single-float)
  (:args (bits :scs (signed-reg) :target res
	       :load-if (not (or (and (sc-is bits signed-stack)
				      (sc-is res single-reg))
				 (and (sc-is bits signed-stack)
				      (sc-is res single-stack)
				      (location= bits res))))))
  (:results (res :scs (single-reg single-stack)))
  (:temporary (:sc 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 res
       (single-stack
	(sc-case bits
	  (signed-reg
	   (inst mov res bits))
	  (signed-stack
	   (assert (location= bits res)))))
       (single-reg
	(sc-case bits
	  (signed-reg
	   ;; source must be in memory
	   (inst mov stack-temp bits)
	   (with-empty-tn@fp-top(res)
	      (inst fld stack-temp)))
	  (signed-stack
	   (with-empty-tn@fp-top(res)
	      (inst fld bits))))))))

(define-vop (make-double-float)
  (:args (hi-bits :scs (signed-reg))
	 (lo-bits :scs (unsigned-reg)))
  (:results (res :scs (double-reg)))
  (:temporary (:sc 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 ((offset (1+ (tn-offset temp))))
      (storew hi-bits ebp-tn (- offset))
      (storew lo-bits ebp-tn (- (1+ offset)))
      (with-empty-tn@fp-top(res)
	(inst fldd (make-ea :dword :base ebp-tn
			    :disp (- (* (1+ offset) word-bytes))))))))

(define-vop (single-float-bits)
  (:args (float :scs (single-reg descriptor-reg)))
  (:results (bits :scs (signed-reg)))
  (:temporary (:sc signed-stack :from :argument :to :result) 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
	  (with-tn@fp-top(float)
	    (inst fst stack-temp)
	    (inst mov bits stack-temp)))
	 (single-stack
	  (inst mov bits float))
	 (descriptor-reg
	  (loadw
	   bits float vm:single-float-value-slot vm:other-pointer-type))))
      (signed-stack
       (sc-case float
	 (single-reg
	  (with-tn@fp-top(float)
	    (inst fst bits))))))))

;; must test
(define-vop (double-float-high-bits)
  (:args (float :scs (double-reg descriptor-reg)))
  (:results (hi-bits :scs (signed-reg)))
  (:temporary (:sc double-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 hi-bits
      (signed-reg
       (sc-case float
	 (double-reg
	  (with-tn@fp-top(float)
	    (let ((where (make-ea :dword :base ebp-tn
				  :disp (- (* (+ 2 (tn-offset temp))
					      word-bytes)))))
	      (inst fstd where)))
	  (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
	 (double-stack
	  (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
	 (descriptor-reg
	  (loadw hi-bits float (1+ vm:double-float-value-slot)
		 vm:other-pointer-type))))
      #+nil ;; should not happen
      (signed-stack
       (sc-case float
	 (double-reg
	  (inst stf float (current-nfp-tn vop)
		(* (tn-offset hi-bits) vm:word-bytes))))))))

;;needs testing
(define-vop (double-float-low-bits)
  (:args (float :scs (double-reg descriptor-reg)))
  (:results (lo-bits :scs (unsigned-reg)))
  (:temporary (:sc double-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 lo-bits
      (unsigned-reg
       (sc-case float
	 (double-reg
	  (with-tn@fp-top(float)
	    (let ((where (make-ea :dword :base ebp-tn
				  :disp (- (* (+ 2 (tn-offset temp))
					      word-bytes)))))
	      (inst fstd where)))
	  (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
	 (double-stack
	  (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
	 (descriptor-reg
	  (loadw lo-bits float  vm:double-float-value-slot
		 vm:other-pointer-type))))
      #+nil ;; should not happen
      (unsigned-stack
       (sc-case float
	 (double-reg
	  (inst stf-odd float (current-nfp-tn vop)
		(* (tn-offset lo-bits) vm:word-bytes))))))))


;;;; Float mode hackery:

(deftype float-modes () '(unsigned-byte 32)) ; really only 16
(defknown floating-point-modes () float-modes (flushable))
(defknown ((setf floating-point-modes)) (float-modes)
  float-modes)

(defconstant npx-env-size (* 7 vm:word-bytes))
(defconstant npx-cw-offset 0)
(defconstant npx-sw-offset 4)

(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 dword-reg :offset  eax-offset :target res)  eax)
  (:temporary (:sc dword-reg) tmp)
  (:generator 8
   (inst mov tmp esp-tn)		; save stack pointer
   (inst sub esp-tn npx-env-size)	; make space on stack
   (inst wait)                          ; Catch any pending FPE exceptions
   (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
   (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset))
   (inst shl eax 16)			; current status to high word
   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
   (inst xor ax-tn #x3f)       ; turn exception mask to trap enable bits
   (inst mov esp-tn tmp)		; reset stack
   (move res eax)))

(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)
  (:vop-var vop)
  (:temporary (:sc dword-reg :offset eax-offset) eax)
  (:temporary (:sc dword-reg) stmp)
  (:temporary (:sc dword-reg) wtmp)
  (:generator 3
   (inst mov stmp esp-tn)		; save stack pointer
   (inst sub esp-tn npx-env-size)	; make space on stack
   (inst wait)                          ; Catch any pending FPE exceptions
   (inst fstenv (make-ea :dword :base esp-tn))
   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset))
   (move wtmp new)
   (inst shr wtmp 16)			; position sticky bits
   (inst and wtmp #x3f)
   (inst and eax wtmp)			; maybe new sticky bits
   (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
   (move eax new)
   (inst xor eax #x3f)	    ; turn trap enable bits into exception mask
   (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
   (inst fldenv (make-ea :dword :base esp-tn))
   (move esp-tn stmp)			; reset stack
   (move res new)))



;;; Lets use some of the 80387 special functions.
;;;
;;; These defs will not take effect unless code/irrat.lisp is modified
;;; to remove the inlined alien routine def.

(macrolet ((frob (func trans op)
	     `(define-vop (,func)
	       (:args (x :scs (double-reg) :target fr0))
	       (:temporary (:sc double-reg :offset fr0-offset
				:from :argument :to :result) fr0)
	       (:ignore fr0)
	       (:results (y :scs (double-reg)))
	       (:arg-types double-float)
	       (:result-types double-float)
	       (:translate ,trans)
	       (:policy :fast-safe)
	       (:note "inline NPX function")
	       (:vop-var vop)
	       (:save-p :compute-only)
	       (:node-var node)
	       (:generator 5
		(note-this-location vop :internal-error)
		(unless (zerop (tn-offset x))
		  (inst fxch x)		; x to top of stack
		  (unless (location= x y)
		    (inst fst x)))	; maybe save it
		(inst ,op)		; clobber st0
		(cond ((zerop (tn-offset y))
		       (when (policy node (or (= debug 3) (> safety speed)))
			     (inst wait)))
		      (t
		       (inst fst y)))))))

  (frob fsin-quick  %sin-quick fsin)		; arg range is 2^63
  (frob fcos-quick  %cos-quick fcos)		; so may need frem1
  (frob fsqrt %sqrt fsqrt))

;;; Versions of fsin and fcos which handle a larger arg. range.
(macrolet ((frob (func trans op)
	     `(define-vop (,func)
		(:translate ,trans)
		(:args (x :scs (double-reg) :target fr0))
		#+nil(:temporary (:sc word-reg :offset eax-offset
				 :from :eval :to :result) temp)
		(:temporary (:sc double-reg :offset fr0-offset
				 :from :argument :to :result) fr0)
		#+nil(:temporary (:sc double-reg :offset fr1-offset
				 :from :argument :to :result) fr1)
		(:results (y :scs (double-reg)))
		(:arg-types double-float)
		(:result-types double-float)
		(:policy :fast-safe)
		(:note "inline sin/cos function")
		(:vop-var vop)
		(:save-p :compute-only)
		#+nil(:ignore temp)
		(:generator 5
		  (note-this-location vop :internal-error)
		  (unless (zerop (tn-offset x))
			  (inst fxch x)		 ; x to top of stack
			  (unless (location= x y)
				  (inst fst x))) ; maybe save it
		  (inst ,op)
		  (inst fnstsw)			 ; status word to %ea
		  (inst and ah-tn #x04)		 ; C2
		  (inst jmp :z DONE)
		  ;; Else x was out of range so reduce it; ST0 is unchanged.
		  #+nil				; @@@
		  (progn			; Arg reduction is errorful
		    (inst fstp fr1) 		; Load 2*PI
		    (inst fldpi)
		    (inst fadd fr0)
		    (inst fxch fr1)
		    LOOP
		    (inst fprem1)
		    (inst fnstsw)		; status word to %ea
		    (inst and ah-tn #x04)	; C2
		    (inst jmp :nz LOOP)
		    (inst ,op))
		  (progn			; @@@
		    (inst fstp fr0)		; Else Load 0.0
		    (inst fldz))		; on too big args
		  DONE
		  (unless (zerop (tn-offset y))
			  (inst fstd y))))))
	  (frob fsin  %sin fsin)
	  (frob fcos  %cos fcos))
	     
(define-vop (ftan)
  (:translate %tan)
  (:args (x :scs (double-reg) :target fr0))
  #+nil(:temporary (:sc word-reg :offset eax-offset
		   :from :eval :to :result) temp)
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline tan function")
  (:vop-var vop)
  (:save-p :compute-only)
  #+nil(:ignore temp)
  (:generator 5
    (note-this-location vop :internal-error)
    (case (tn-offset x)
       (0 
	(inst fstp fr1))
       (1
	(inst fstp fr0))
       (t
	(inst fstp fr0)
	(inst fstp fr0)
	(inst fldd (make-random-tn :kind :normal
				   :sc (sc-or-lose 'double-reg)
				   :offset (- (tn-offset x) 2)))))
    (inst fptan)
    (inst fnstsw)			 ; status word to %ea
    (inst and ah-tn #x04)		 ; C2
    (inst jmp :z DONE)
    ;; Else x was out of range so reduce it; ST0 is unchanged.
    #+nil
    (progn				; @@@ Reduction doesn't work well.
      (inst fldpi)                         ; Load 2*PI
      (inst fadd fr0)
      (inst fxch fr1)
      LOOP
      (inst fprem1)
      (inst fnstsw)			 ; status word to %ea
      (inst and ah-tn #x04)		 ; C2
      (inst jmp :nz LOOP)
      (inst fstp fr1)
      (inst fptan))
    (progn				; @@@ just load 0.0 
      (inst fldz)
      (inst fxch fr1))
    DONE
    ;; Result is in fr1
    (case (tn-offset y)
       (0
	(inst fxch fr1))
       (1)
       (t
	(inst fxch fr1)
	(inst fstd y)))))

(define-vop (ftan-quick)
  (:translate %tan-quick)
  (:args (x :scs (double-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline tan function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
    (note-this-location vop :internal-error)
    (case (tn-offset x)
       (0 
	(inst fstp fr1))
       (1
	(inst fstp fr0))
       (t
	(inst fstp fr0)
	(inst fstp fr0)
	(inst fldd (make-random-tn :kind :normal
				   :sc (sc-or-lose 'double-reg)
				   :offset (- (tn-offset x) 2)))))
    (inst fptan)
    ;; Result is in fr1
    (case (tn-offset y)
      (0
       (inst fxch fr1))
      (1)
      (t
       (inst fxch fr1)
       (inst fstd y)))))
	     
#+nil
(define-vop (fexp)
  (:translate %exp)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:temporary (:sc double-reg :offset fr2-offset
		   :from :argument :to :result) fr2)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline exp function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     (sc-case x
        (double-reg
	 (cond ((zerop (tn-offset x))
		;; x is in fr0
		(inst fstp fr1)
		(inst fldl2e)
		(inst fmul fr1))
	       (t
		;; x is in a FP reg, not fr0
		(inst fstp fr0)
		(inst fldl2e)
		(inst fmul x))))
	((double-stack descriptor-reg)
	 (inst fstp fr0)
	 (inst fldl2e)
	 (if (sc-is x double-stack)
	     (inst fmuld (ea-for-df-stack x))
	   (inst fmuld (ea-for-df-desc x)))))
     ;; Now fr0=x log2(e)
     (inst fst fr1)
     (inst frndint)
     (inst fst fr2)
     (inst fsubp-sti fr1)
     (inst f2xm1)
     (inst fld1)
     (inst faddp-sti fr1)
     (inst fscale)
     (inst fld fr0)
     (case (tn-offset y)
       ((0 1))
       (t (inst fstd y)))))

;;; Modified exp that handles the following special cases:
;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
(define-vop (fexp)
  (:translate %exp)
  (:args (x :scs (double-reg) :target fr0))
  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:temporary (:sc double-reg :offset fr2-offset
		   :from :argument :to :result) fr2)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline exp function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:ignore temp)
  (:generator 5
     (note-this-location vop :internal-error)
     (unless (zerop (tn-offset x))
	     (inst fxch x)		; x to top of stack
	     (unless (location= x y)
		     (inst fst x)))	; maybe save it
     ;; Check for Inf or NaN
     (inst fxam)
     (inst fnstsw)
     (inst sahf)
     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
     (inst and ah-tn #x02)              ; Test sign of Inf.
     (inst jmp :z DONE)                 ; +Inf gives +Inf.
     (inst fstp fr0)                    ; -Inf gives 0
     (inst fldz)
     (inst jmp-short DONE)
     NOINFNAN
     (inst fstp fr1)
     (inst fldl2e)
     (inst fmul fr1)
     ;; Now fr0=x log2(e)
     (inst fst fr1)
     (inst frndint)
     (inst fst fr2)
     (inst fsubp-sti fr1)
     (inst f2xm1)
     (inst fld1)
     (inst faddp-sti fr1)
     (inst fscale)
     (inst fld fr0)
     DONE
     (unless (zerop (tn-offset y))
	     (inst fstd y))))

(define-vop (flog)
  (:translate %log)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline log function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     (sc-case x
        (double-reg
	 (case (tn-offset x)
	    (0
	     ;; x is in fr0
	     (inst fstp fr1)
	     (inst fldln2)
	     (inst fxch fr1))
	    (1
	     ;; x is in fr1
	     (inst fstp fr0)
	     (inst fldln2)
	     (inst fxch fr1))
	    (t
	     ;; x is in a FP reg, not fr0 or fr1
	     (inst fstp fr0)
	     (inst fstp fr0)
	     (inst fldln2)
	     (inst fldd (make-random-tn :kind :normal
					:sc (sc-or-lose 'double-reg)
					:offset (1- (tn-offset x))))))
	 (inst fyl2x))
	((double-stack descriptor-reg)
	 (inst fstp fr0)
	 (inst fstp fr0)
	 (inst fldln2)
	 (if (sc-is x double-stack)
	     (inst fldd (ea-for-df-stack x))
	   (inst fldd (ea-for-df-desc x)))
	 (inst fyl2x)))
     (inst fld fr0)
     (case (tn-offset y)
       ((0 1))
       (t (inst fstd y)))))

(define-vop (flog10)
  (:translate %log10)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline log10 function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     (sc-case x
        (double-reg
	 (case (tn-offset x)
	    (0
	     ;; x is in fr0
	     (inst fstp fr1)
	     (inst fldlg2)
	     (inst fxch fr1))
	    (1
	     ;; x is in fr1
	     (inst fstp fr0)
	     (inst fldlg2)
	     (inst fxch fr1))
	    (t
	     ;; x is in a FP reg, not fr0 or fr1
	     (inst fstp fr0)
	     (inst fstp fr0)
	     (inst fldlg2)
	     (inst fldd (make-random-tn :kind :normal
					:sc (sc-or-lose 'double-reg)
					:offset (1- (tn-offset x))))))
	 (inst fyl2x))
	((double-stack descriptor-reg)
	 (inst fstp fr0)
	 (inst fstp fr0)
	 (inst fldlg2)
	 (if (sc-is x double-stack)
	     (inst fldd (ea-for-df-stack x))
	   (inst fldd (ea-for-df-desc x)))
	 (inst fyl2x)))
     (inst fld fr0)
     (case (tn-offset y)
       ((0 1))
       (t (inst fstd y)))))

(define-vop (fpow)
  (:translate %pow)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from (:argument 0) :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from (:argument 1) :to :result) fr1)
  (:temporary (:sc double-reg :offset fr2-offset
		   :from :load :to :result) fr2)
  (:results (r :scs (double-reg)))
  (:arg-types double-float double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline pow function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     ;; Setup x in fr0 and y in fr1
     (cond 
      ;; x in fr0; y in fr1
      ((and (sc-is x double-reg) (zerop (tn-offset x))
	    (sc-is y double-reg) (= 1 (tn-offset y))))
      ;; y in fr1; x not in fr0
      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
       ;; Load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x)))))
      ;; x in fr0; y not in fr1
      ((and (sc-is x double-reg) (zerop (tn-offset x)))
       (inst fxch fr1)
       ;; Now load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y))))
       (inst fxch fr1))
      ;; x in fr1; y not in fr1
      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
       ;; Load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y))))
       (inst fxch fr1))
      ;; y in fr0;
      ((and (sc-is y double-reg) (zerop (tn-offset y)))
       (inst fxch fr1)
       ;; Now load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x)))))
      ;; Neither x or y are in either fr0 or fr1
      (t
       ;; Load y then x
       (inst fstp fr0)
       (inst fstp fr0)
       (sc-case y
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (- (tn-offset y) 2))))
	  (double-stack
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc y))))
       ;; Load x to fr0
       (sc-case x
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (1- (tn-offset x)))))
	  (double-stack
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc x))))))
      
     ;; Now have x at fr0; and y at fr1
     (inst fyl2x)
     ;; Now fr0=y log2(x)
     (inst fld fr0)
     (inst frndint)
     (inst fst fr2)
     (inst fsubp-sti fr1)
     (inst f2xm1)
     (inst fld1)
     (inst faddp-sti fr1)
     (inst fscale)
     (inst fld fr0)
     (case (tn-offset r)
       ((0 1))
       (t (inst fstd r)))))

(define-vop (fscalen)
  (:translate %scalbn)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
	 (y :scs (signed-stack signed-reg) :target temp))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from (:argument 0) :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
  (:results (r :scs (double-reg)))
  (:arg-types double-float signed-num)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline scalbn function")
  (:generator 5
     ;; Setup x in fr0 and y in fr1
     (sc-case x
       (double-reg
	(case (tn-offset x)
	 (0
	  (inst fstp fr1)
	  (sc-case y
	    (signed-reg
	     (inst mov temp y)
	     (inst fild temp))
	    (signed-stack
	     (inst fild y)))
	  (inst fxch fr1))
	 (1
	  (inst fstp fr0)
	  (sc-case y
	    (signed-reg
	     (inst mov temp y)
	     (inst fild temp))
	    (signed-stack
	     (inst fild y)))
	  (inst fxch fr1))
	 (t
	   (inst fstp fr0)
	   (inst fstp fr0)
	   (sc-case y
	     (signed-reg
	      (inst mov temp y)
	      (inst fild temp))
	     (signed-stack
	      (inst fild y)))
	   (inst fld (make-random-tn :kind :normal
				     :sc (sc-or-lose 'double-reg)
				     :offset (1- (tn-offset x)))))))
       ((double-stack descriptor-reg)
	(inst fstp fr0)
	(inst fstp fr0)
	(sc-case y
          (signed-reg
	   (inst mov temp y)
	   (inst fild temp))
	  (signed-stack
	   (inst fild y)))
	(if (sc-is x double-stack)
	    (inst fldd (ea-for-df-stack x))
	  (inst fldd (ea-for-df-desc x)))))
     (inst fscale)
     (unless (zerop (tn-offset r))
	     (inst fstd r))))

(define-vop (fscale)
  (:translate %scalb)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from (:argument 0) :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from (:argument 1) :to :result) fr1)
  (:results (r :scs (double-reg)))
  (:arg-types double-float double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline scalb function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     ;; Setup x in fr0 and y in fr1
     (cond 
      ;; x in fr0; y in fr1
      ((and (sc-is x double-reg) (zerop (tn-offset x))
	    (sc-is y double-reg) (= 1 (tn-offset y))))
      ;; y in fr1; x not in fr0
      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
       ;; Load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x)))))
      ;; x in fr0; y not in fr1
      ((and (sc-is x double-reg) (zerop (tn-offset x)))
       (inst fxch fr1)
       ;; Now load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y))))
       (inst fxch fr1))
      ;; x in fr1; y not in fr1
      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
       ;; Load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y))))
       (inst fxch fr1))
      ;; y in fr0;
      ((and (sc-is y double-reg) (zerop (tn-offset y)))
       (inst fxch fr1)
       ;; Now load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x)))))
      ;; Neither x or y are in either fr0 or fr1
      (t
       ;; Load y then x
       (inst fstp fr0)
       (inst fstp fr0)
       (sc-case y
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (- (tn-offset y) 2))))
	  (double-stack
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc y))))
       ;; Load x to fr0
       (sc-case x
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (1- (tn-offset x)))))
	  (double-stack
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc x))))))
      
     ;; Now have x at fr0; and y at fr1
     (inst fscale)
     (unless (zerop (tn-offset r))
	     (inst fstd r))))

;;; Seems to work fine on a Pentium, but the range of the x argument
;;; is limited on a 386/486.
(define-vop (flog1p-limited)
  (:translate %log1p-limited)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline log1p with limited x range function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     (sc-case x
        (double-reg
	 (case (tn-offset x)
	    (0
	     ;; x is in fr0
	     (inst fstp fr1)
	     (inst fldln2)
	     (inst fxch fr1))
	    (1
	     ;; x is in fr1
	     (inst fstp fr0)
	     (inst fldln2)
	     (inst fxch fr1))
	    (t
	     ;; x is in a FP reg, not fr0 or fr1
	     (inst fstp fr0)
	     (inst fstp fr0)
	     (inst fldln2)
	     (inst fldd (make-random-tn :kind :normal
					:sc (sc-or-lose 'double-reg)
					:offset (- (tn-offset x) 2)))))
	 (inst fyl2xp1))
	((double-stack descriptor-reg)
	 (inst fstp fr0)
	 (inst fstp fr0)
	 (inst fldln2)
	 (if (sc-is x double-stack)
	     (inst fldd (ea-for-df-stack x))
	   (inst fldd (ea-for-df-desc x)))
	 (inst fyl2xp1)))
     (inst fld fr0)
     (case (tn-offset y)
       ((0 1))
       (t (inst fstd y)))))

(define-vop (flogb)
  (:translate %logb)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from :argument :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from :argument :to :result) fr1)
  (:results (y :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline logb function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     (sc-case x
        (double-reg
	 (case (tn-offset x)
	    (0
	     ;; x is in fr0
	     (inst fstp fr1))
	    (1
	     ;; x is in fr1
	     (inst fstp fr0))
	    (t
	     ;; x is in a FP reg, not fr0 or fr1
	     (inst fstp fr0)
	     (inst fstp fr0)
	     (inst fldd (make-random-tn :kind :normal
					:sc (sc-or-lose 'double-reg)
					:offset (- (tn-offset x) 2))))))
	((double-stack descriptor-reg)
	 (inst fstp fr0)
	 (inst fstp fr0)
	 (if (sc-is x double-stack)
	     (inst fldd (ea-for-df-stack x))
	   (inst fldd (ea-for-df-desc x)))))
     (inst fxtract)
     (case (tn-offset y)
       (0
	(inst fxch fr1))
       (1)
       (t (inst fxch fr1)
	  (inst fstd y)))))

(define-vop (fatan)
  (:translate %atan)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from (:argument 0) :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from (:argument 0) :to :result) fr1)
  (:results (r :scs (double-reg)))
  (:arg-types double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline atan function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     ;; Setup x in fr1 and 1.0 in fr0
     (cond 
      ;; x in fr0
      ((and (sc-is x double-reg) (zerop (tn-offset x)))
       (inst fstp fr1))
      ;; x in fr1
      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
       (inst fstp fr0))
      ;; x not in fr0 or fr1
      (t
       ;; Load x then 1.0
       (inst fstp fr0)
       (inst fstp fr0)
       (sc-case x
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (- (tn-offset x) 2))))
	  (double-stack
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc x))))))
     (inst fld1)
     ;; Now have x at fr1; and 1.0 at fr0
     (inst fpatan)
     (inst fld fr0)
     (case (tn-offset r)
       ((0 1))
       (t (inst fstd r)))))

(define-vop (fatan2)
  (:translate %atan2)
  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
	 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
  (:temporary (:sc double-reg :offset fr0-offset
		   :from (:argument 1) :to :result) fr0)
  (:temporary (:sc double-reg :offset fr1-offset
		   :from (:argument 0) :to :result) fr1)
  (:results (r :scs (double-reg)))
  (:arg-types double-float double-float)
  (:result-types double-float)
  (:policy :fast-safe)
  (:note "inline atan2 function")
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 5
     (note-this-location vop :internal-error)
     ;; Setup x in fr1 and y in fr0
     (cond 
      ;; y in fr0; x in fr1
      ((and (sc-is y double-reg) (zerop (tn-offset y))
	    (sc-is x double-reg) (= 1 (tn-offset x))))
      ;; x in fr1; y not in fr0
      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
       ;; Load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y)))))
      ;; y in fr0; x not in fr1
      ((and (sc-is y double-reg) (zerop (tn-offset y)))
       (inst fxch fr1)
       ;; Now load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x))))
       (inst fxch fr1))
      ;; y in fr1; x not in fr1
      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
       ;; Load x to fr0
       (sc-case x
          (double-reg
	   (copy-fp-reg-to-fr0 x))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc x))))
       (inst fxch fr1))
      ;; x in fr0;
      ((and (sc-is x double-reg) (zerop (tn-offset x)))
       (inst fxch fr1)
       ;; Now load y to fr0
       (sc-case y
          (double-reg
	   (copy-fp-reg-to-fr0 y))
	  (double-stack
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fstp fr0)
	   (inst fldd (ea-for-df-desc y)))))
      ;; Neither y or x are in either fr0 or fr1
      (t
       ;; Load x then y
       (inst fstp fr0)
       (inst fstp fr0)
       (sc-case x
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (- (tn-offset x) 2))))
	  (double-stack
	   (inst fldd (ea-for-df-stack x)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc x))))
       ;; Load y to fr0
       (sc-case y
          (double-reg
	   (inst fldd (make-random-tn :kind :normal
				      :sc (sc-or-lose 'double-reg)
				      :offset (1- (tn-offset y)))))
	  (double-stack
	   (inst fldd (ea-for-df-stack y)))
	  (descriptor-reg
	   (inst fldd (ea-for-df-desc y))))))
      
     ;; Now have y at fr0; and x at fr1
     (inst fpatan)
     (inst fld fr0)
     (case (tn-offset r)
       ((0 1))
       (t (inst fstd r)))))