0.8.3.45.modular2:

[sbcl.git] / src / compiler / x86 / float.lisp

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index f935c1f..e5b1942 100644 (file)
--- 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))
 \f
 ;;;; 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)