X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=0d69b015e28fa53036e50c3d0a427ee80a666d33;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=3187f3046e050b4c993ebdc3a6cf1b1e90078c0e;hpb=d93e034b8a53d8e3d8d6fa8b768cb5952d3ee548;p=sbcl.git

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 3187f30..0d69b01 100644
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -62,11 +62,18 @@
 ;;;
 ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to
 ;;; #'NOTE-NEXT-INSTRUCTION.
+;;;
+;;; Until 2004-03-15, the implementation of this was buggy; it
+;;; unconditionally emitted the WAIT instruction.  It turns out that
+;;; this is the right thing to do anyway; omitting them can lead to
+;;; system corruption on conforming code.  -- CSR
 (defun maybe-fp-wait (node &optional note-next-instruction)
+  (declare (ignore node))
+  #+nil
   (when (policy node (or (= debug 3) (> safety speed))))
-    (when note-next-instruction
-      (note-next-instruction note-next-instruction :internal-error))
-    (inst wait))
+  (when note-next-instruction
+    (note-next-instruction note-next-instruction :internal-error))
+  (inst wait))
 
 ;;; complex float stack EAs
 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
@@ -177,26 +184,30 @@
 ;;; 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.
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format*
+	#!+long-float 'long-float #!-long-float 'double-float))
 (define-move-fun (load-fp-constant 2) (vop x y)
   ((fp-constant) (single-reg double-reg #!+long-float long-reg))
   (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
     (with-empty-tn@fp-top(y)
       (cond ((zerop value)
 	     (inst fldz))
-	    ((= value 1l0)
+	    ((= value 1e0)
 	     (inst fld1))
-	    ((= value pi)
+	    ((= value (coerce pi *read-default-float-format*))
 	     (inst fldpi))
-	    ((= value (log 10l0 2l0))
+	    ((= value (log 10e0 2e0))
 	     (inst fldl2t))
-	    ((= value (log 2.718281828459045235360287471352662L0 2l0))
+	    ((= value (log 2.718281828459045235360287471352662e0 2e0))
 	     (inst fldl2e))
-	    ((= value (log 2l0 10l0))
+	    ((= value (log 2e0 10e0))
 	     (inst fldlg2))
-	    ((= value (log 2l0 2.718281828459045235360287471352662L0))
+	    ((= value (log 2e0 2.718281828459045235360287471352662e0))
 	     (inst fldln2))
 	    (t (warn "ignoring bogus i387 constant ~A" value))))))
-
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
 
 ;;;; complex float move functions
 
@@ -734,16 +745,16 @@
 ;;; 22-Jul-97: descriptor args lose in some simple cases when
 ;;; a function result computed in a loop. Then Python insists
 ;;; on consing the intermediate values! For example
-#|
-(defun test(a n)
-  (declare (type (simple-array double-float (*)) a)
-	   (fixnum n))
-  (let ((sum 0d0))
-    (declare (type double-float sum))
-  (dotimes (i n)
-    (incf sum (* (aref a i)(aref a i))))
-    sum))
-|#
+;;;
+;;; (defun test(a n)
+;;;   (declare (type (simple-array double-float (*)) a)
+;;; 	   (fixnum n))
+;;;   (let ((sum 0d0))
+;;;     (declare (type double-float sum))
+;;;   (dotimes (i n)
+;;;     (incf sum (* (aref a i)(aref a i))))
+;;;     sum))
+;;;
 ;;; So, disabling descriptor args until this can be fixed elsewhere.
 (macrolet
     ((frob (op fop-sti fopr-sti
@@ -1528,79 +1539,52 @@
 (define-vop (=0/single-float float-test)
   (:translate =)
   (:args (x :scs (single-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x40))
 (define-vop (=0/double-float float-test)
   (:translate =)
   (:args (x :scs (double-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x40))
 #!+long-float
 (define-vop (=0/long-float float-test)
   (:translate =)
   (:args (x :scs (long-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types long-float (:constant (long-float 0l0 0l0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types long-float (:constant (long-float -0l0 0l0)))
   (:variant #x40))
 
 (define-vop (<0/single-float float-test)
   (:translate <)
   (:args (x :scs (single-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x01))
 (define-vop (<0/double-float float-test)
   (:translate <)
   (:args (x :scs (double-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x01))
 #!+long-float
 (define-vop (<0/long-float float-test)
   (:translate <)
   (:args (x :scs (long-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types long-float (:constant (long-float 0l0 0l0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types long-float (:constant (long-float -0l0 0l0)))
   (:variant #x01))
 
 (define-vop (>0/single-float float-test)
   (:translate >)
   (:args (x :scs (single-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x00))
 (define-vop (>0/double-float float-test)
   (:translate >)
   (:args (x :scs (double-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x00))
 #!+long-float
 (define-vop (>0/long-float float-test)
   (:translate >)
   (:args (x :scs (long-reg)))
-  #!-negative-zero-is-not-zero
   (:arg-types long-float (:constant (long-float 0l0 0l0)))
-  #!+negative-zero-is-not-zero
-  (:arg-types long-float (:constant (long-float -0l0 0l0)))
   (:variant #x00))
 
 #!+long-float
@@ -2046,9 +2030,9 @@
 (defknown ((setf floating-point-modes)) (float-modes)
   float-modes)
 
-(defconstant npx-env-size (* 7 n-word-bytes))
-(defconstant npx-cw-offset 0)
-(defconstant npx-sw-offset 4)
+(def!constant npx-env-size (* 7 n-word-bytes))
+(def!constant npx-cw-offset 0)
+(def!constant npx-sw-offset 4)
 
 (define-vop (floating-point-modes)
   (:results (res :scs (unsigned-reg)))
@@ -2172,114 +2156,9 @@
 	(inst fxch fr1)
 	(inst fstd y)))))
 
-;;; These versions of fsin, fcos, and ftan try to use argument
-;;; reduction but to do this accurately requires greater precision and
-;;; it is hopelessly inaccurate.
-#+nil
-(macrolet ((frob (func trans op)
-	     `(define-vop (,func)
-		(:translate ,trans)
-		(:args (x :scs (double-reg) :target fr0))
-		(:temporary (:sc unsigned-reg :offset eax-offset
-				 :from :eval :to :result) eax)
-		(:temporary (:sc unsigned-reg :offset fr0-offset
-				 :from :argument :to :result) fr0)
-		(:temporary (:sc unsigned-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)
-		(:ignore eax)
-		(: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 ax
-		  (inst and ah-tn #x04)		 ; C2
-		  (inst jmp :z DONE)
-		  ;; Else x was out of range so reduce it; ST0 is unchanged.
-		  (inst fstp fr1) 		; Load 2*PI
-		  (inst fldpi)
-		  (inst fadd fr0)
-		  (inst fxch fr1)
-		  LOOP
-		  (inst fprem1)
-		  (inst fnstsw)		; status word to ax
-		  (inst and ah-tn #x04)	; C2
-		  (inst jmp :nz LOOP)
-		  (inst ,op)
-		  DONE
-		  (unless (zerop (tn-offset y))
-			  (inst fstd y))))))
-	  (frob fsin  %sin fsin)
-	  (frob fcos  %cos fcos))
-
-#+nil
-(define-vop (ftan)
-  (:translate %tan)
-  (:args (x :scs (double-reg) :target fr0))
-  (:temporary (:sc unsigned-reg :offset eax-offset
-		   :from :argument :to :result) eax)
-  (: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)
-  (:ignore eax)
-  (: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 ax
-    (inst and ah-tn #x04)		 ; C2
-    (inst jmp :z DONE)
-    ;; Else x was out of range so reduce it; ST0 is unchanged.
-    (inst fldpi)			 ; Load 2*PI
-    (inst fadd fr0)
-    (inst fxch fr1)
-    LOOP
-    (inst fprem1)
-    (inst fnstsw)			 ; status word to ax
-    (inst and ah-tn #x04)		 ; C2
-    (inst jmp :nz LOOP)
-    (inst fstp fr1)
-    (inst fptan)
-    DONE
-    ;; Result is in fr1
-    (case (tn-offset y)
-       (0
-	(inst fxch fr1))
-       (1)
-       (t
-	(inst fxch fr1)
-	(inst fstd y)))))
-
-;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
-;;; the argument is out of range 2^63 and would thus be hopelessly
-;;; inaccurate.
+;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
+;;; result if the argument is out of range 2^63 and would thus be
+;;; hopelessly inaccurate.
 (macrolet ((frob (func trans op)
 	     `(define-vop (,func)
 		(:translate ,trans)
@@ -2350,8 +2229,7 @@
     (inst fnstsw)			 ; status word to ax
     (inst and ah-tn #x04)		 ; C2
     (inst jmp :z DONE)
-    ;; Else x was out of range so reduce it; ST0 is unchanged.
-    (inst fldz)			 ; Load 0.0
+    ;; Else x was out of range so load 0.0
     (inst fxch fr1)
     DONE
     ;; Result is in fr1
@@ -2363,59 +2241,8 @@
 	(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.
+;;; %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))
@@ -3149,6 +2976,10 @@
 	  (descriptor-reg
 	   (inst fstp fr0)
 	   (inst fldd (ea-for-df-desc y)))))
+      ((and (sc-is x double-reg) (zerop (tn-offset x))
+	    (sc-is y double-reg) (zerop (tn-offset x)))
+       ;; copy x to fr1
+       (inst fst fr1))
       ;; y in fr0; x not in fr1
       ((and (sc-is y double-reg) (zerop (tn-offset y)))
        (inst fxch fr1)
@@ -3302,111 +3133,6 @@
 	(inst fxch fr1)
 	(inst fstd y)))))
 
-;;; These versions of fsin, fcos, and ftan try to use argument
-;;; reduction but to do this accurately requires greater precision and
-;;; it is hopelessly inaccurate.
-#+nil
-(macrolet ((frob (func trans op)
-	     `(define-vop (,func)
-		(:translate ,trans)
-		(:args (x :scs (long-reg) :target fr0))
-		(:temporary (:sc unsigned-reg :offset eax-offset
-				 :from :eval :to :result) eax)
-		(:temporary (:sc long-reg :offset fr0-offset
-				 :from :argument :to :result) fr0)
-		(:temporary (:sc long-reg :offset fr1-offset
-				 :from :argument :to :result) fr1)
-		(:results (y :scs (long-reg)))
-		(:arg-types long-float)
-		(:result-types long-float)
-		(:policy :fast-safe)
-		(:note "inline sin/cos function")
-		(:vop-var vop)
-		(:save-p :compute-only)
-		(:ignore eax)
-		(: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 ax
-		  (inst and ah-tn #x04)		 ; C2
-		  (inst jmp :z DONE)
-		  ;; Else x was out of range so reduce it; ST0 is unchanged.
-		  (inst fstp fr1) 		; Load 2*PI
-		  (inst fldpi)
-		  (inst fadd fr0)
-		  (inst fxch fr1)
-		  LOOP
-		  (inst fprem1)
-		  (inst fnstsw)		; status word to ax
-		  (inst and ah-tn #x04)	; C2
-		  (inst jmp :nz LOOP)
-		  (inst ,op)
-		  DONE
-		  (unless (zerop (tn-offset y))
-			  (inst fstd y))))))
-	  (frob fsin  %sin fsin)
-	  (frob fcos  %cos fcos))
-
-#+nil
-(define-vop (ftan)
-  (:translate %tan)
-  (:args (x :scs (long-reg) :target fr0))
-  (:temporary (:sc unsigned-reg :offset eax-offset
-		   :from :argument :to :result) eax)
-  (:temporary (:sc long-reg :offset fr0-offset
-		   :from :argument :to :result) fr0)
-  (:temporary (:sc long-reg :offset fr1-offset
-		   :from :argument :to :result) fr1)
-  (:results (y :scs (long-reg)))
-  (:arg-types long-float)
-  (:result-types long-float)
-  (:policy :fast-safe)
-  (:note "inline tan function")
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:ignore eax)
-  (: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 ax
-    (inst and ah-tn #x04)		 ; C2
-    (inst jmp :z DONE)
-    ;; Else x was out of range so reduce it; ST0 is unchanged.
-    (inst fldpi)			 ; Load 2*PI
-    (inst fadd fr0)
-    (inst fxch fr1)
-    LOOP
-    (inst fprem1)
-    (inst fnstsw)			 ; status word to ax
-    (inst and ah-tn #x04)		 ; C2
-    (inst jmp :nz LOOP)
-    (inst fstp fr1)
-    (inst fptan)
-    DONE
-    ;; Result is in fr1
-    (case (tn-offset y)
-       (0
-	(inst fxch fr1))
-       (1)
-       (t
-	(inst fxch fr1)
-	(inst fstd y)))))
-
 ;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
 ;;; the argument is out of range 2^63 and would thus be hopelessly
 ;;; inaccurate.