X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=e5b194249d1884ed75b43de6dcbeb8bc5c902c31;hb=3f542eedffe3acf5af2a29db99c43b4de98465da;hp=f935c1ff619970fce8bbeaacd19a84385fe4d700;hpb=816248ab4fe04775879a7e5a5ce1b4c613afe9d5;p=sbcl.git

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index f935c1f..e5b1942 100644
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -177,26 +177,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
 
@@ -432,8 +436,8 @@
   (:results (y :scs (descriptor-reg)))
   (:generator 2
      (ecase (sb!c::constant-value (sb!c::tn-leaf x))
-       (0f0 (load-symbol-value y *fp-constant-0s0*))
-       (1f0 (load-symbol-value y *fp-constant-1s0*))
+       (0f0 (load-symbol-value y *fp-constant-0f0*))
+       (1f0 (load-symbol-value y *fp-constant-1f0*))
        (0d0 (load-symbol-value y *fp-constant-0d0*))
        (1d0 (load-symbol-value y *fp-constant-1d0*))
        #!+long-float
@@ -1528,79 +1532,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 +2023,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)))
@@ -3149,6 +3126,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)