Skip to content
Snippets Groups Projects
float.lisp 64.9 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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.3 1997/03/26 20:29:14 dtc Exp $")
ram's avatar
ram committed
;;;
;;; **********************************************************************
;;;
;;; 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.
ram's avatar
ram committed
;;;

ram's avatar
ram committed


(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)))

ram's avatar
ram committed

;;;; 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))))
ram's avatar
ram committed

(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))))
ram's avatar
ram committed

;;; 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))
ram's avatar
ram committed
	      ((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))
ram's avatar
ram committed
	      ((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))))
ram's avatar
ram committed
  (: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))
		(0s0 (load-symbol-value y *fp-constant-0s0*))
		(1s0 (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))))))))
ram's avatar
ram committed
(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))))
ram's avatar
ram committed
  (: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)
ram's avatar
ram committed
             (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))
ram's avatar
ram committed
				((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
ram's avatar
ram committed
		      ;; 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)))
ram's avatar
ram committed
	      ;; 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
ram's avatar
ram committed
			  (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)))
ram's avatar
ram committed
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
ram's avatar
ram committed
	      ;; 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
ram's avatar
ram committed
		    (inst fstp fr0)
		    (inst fld (ea-for-sf-stack x)))
		   (descriptor-reg
		    (inst fstp fr0)
		    (inst fld (ea-for-sf-desc x))))
ram's avatar
ram committed
		 ;; 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
ram's avatar
ram committed
		  (cond ((zerop (tn-offset r))
			 (when (policy node (or (= debug 3) (> safety speed)))
ram's avatar
ram committed
			(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))))
ram's avatar
ram committed
	      ;; 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
ram's avatar
ram committed
			  (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)))
ram's avatar
ram committed
	       (when (policy node (or (= debug 3) (> safety speed)))
		     (note-next-instruction vop :internal-error)
		     (inst wait)))
ram's avatar
ram committed
	      ;; 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
ram's avatar
ram committed
			  (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)
ram's avatar
ram committed
		      (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
ram's avatar
ram committed
		    (inst fstp fr0)
		    (inst fldd (ea-for-df-desc x))))
ram's avatar
ram committed
		 ;; 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)
ram's avatar
ram committed
	       ;; 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)))))))))))
ram's avatar
ram committed
    (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))
ram's avatar
ram committed
	 ((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))
ram's avatar
ram committed
	 ((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))
ram's avatar
ram committed
	 ((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))
ram's avatar
ram committed
	 ((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 0s0 0s0)))
  (: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 0s0 0s0)))
  (: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 0s0 0s0)))
  (: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)