X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=e5b194249d1884ed75b43de6dcbeb8bc5c902c31;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=e879b5ee4994d09810f1c1f620b2700ecc1969de;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index e879b5e..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 @@ -579,7 +583,7 @@ ;;;; Note these are also used to stuff fp numbers onto the c-call ;;;; stack so the order is different than the lisp-stack. -;;; the general move-argument vop +;;; the general MOVE-ARG VOP (macrolet ((frob (name sc stack-sc format) `(progn (define-vop (,name) @@ -624,14 +628,14 @@ (:double '((inst fstd ea))) #!+long-float (:long '((store-long-float ea))))))))))) - (define-move-vop ,name :move-argument + (define-move-vop ,name :move-arg (,sc descriptor-reg) (,sc))))) - (frob move-single-float-argument single-reg single-stack :single) - (frob move-double-float-argument double-reg double-stack :double) + (frob move-single-float-arg single-reg single-stack :single) + (frob move-double-float-arg double-reg double-stack :double) #!+long-float - (frob move-long-float-argument long-reg long-stack :long)) + (frob move-long-float-arg long-reg long-stack :long)) -;;;; complex float move-argument vop +;;;; complex float MOVE-ARG VOP (macrolet ((frob (name sc stack-sc format) `(progn (define-vop (,name) @@ -699,17 +703,17 @@ '((store-long-float (ea-for-clf-imag-stack y fp))))) (inst fxch imag-tn)))))) - (define-move-vop ,name :move-argument + (define-move-vop ,name :move-arg (,sc descriptor-reg) (,sc))))) - (frob move-complex-single-float-argument + (frob move-complex-single-float-arg complex-single-reg complex-single-stack :single) - (frob move-complex-double-float-argument + (frob move-complex-double-float-arg complex-double-reg complex-double-stack :double) #!+long-float - (frob move-complex-long-float-argument + (frob move-complex-long-float-arg complex-long-reg complex-long-stack :long)) -(define-move-vop move-argument :move-argument +(define-move-vop move-arg :move-arg (single-reg double-reg #!+long-float long-reg complex-single-reg complex-double-reg #!+long-float complex-long-reg) (descriptor-reg)) @@ -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) @@ -4013,8 +3994,6 @@ ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around ;; an enormous PROGN above. Still, it would be probably be good to ;; add some code to warn about redefining VOPs. - ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above. - (:guard #!+pentium nil #!-pentium t) (:note "inline log1p function") (:ignore temp) (:generator 5 @@ -4068,8 +4047,7 @@ (:arg-types long-float) (:result-types long-float) (:policy :fast-safe) - ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above. - (:guard #!+pentium t #!-pentium) + (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) (:note "inline log1p function") (:generator 5 (sc-case x