X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=e5b194249d1884ed75b43de6dcbeb8bc5c902c31;hb=02b6f6dfb38d99bcc3181035eb0681e6bb96b939;hp=a9e8fd58913b146705ecc3b79c5c3f3e1adf5cfa;hpb=feae2afb12449b318f83c0de6f4c53e5f28657c2;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index a9e8fd5..e5b1942 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -14,37 +14,37 @@ (macrolet ((ea-for-xf-desc (tn slot) `(make-ea :dword :base ,tn - :disp (- (* ,slot sb!vm:word-bytes) - sb!vm:other-pointer-lowtag)))) + :disp (- (* ,slot n-word-bytes) + other-pointer-lowtag)))) (defun ea-for-sf-desc (tn) - (ea-for-xf-desc tn sb!vm:single-float-value-slot)) + (ea-for-xf-desc tn single-float-value-slot)) (defun ea-for-df-desc (tn) - (ea-for-xf-desc tn sb!vm:double-float-value-slot)) + (ea-for-xf-desc tn double-float-value-slot)) #!+long-float (defun ea-for-lf-desc (tn) - (ea-for-xf-desc tn sb!vm:long-float-value-slot)) + (ea-for-xf-desc tn long-float-value-slot)) ;; complex floats (defun ea-for-csf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot)) + (ea-for-xf-desc tn complex-single-float-real-slot)) (defun ea-for-csf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot)) + (ea-for-xf-desc tn complex-single-float-imag-slot)) (defun ea-for-cdf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot)) + (ea-for-xf-desc tn complex-double-float-real-slot)) (defun ea-for-cdf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot)) + (ea-for-xf-desc tn complex-double-float-imag-slot)) #!+long-float (defun ea-for-clf-real-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot)) + (ea-for-xf-desc tn complex-long-float-real-slot)) #!+long-float (defun ea-for-clf-imag-desc (tn) - (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot))) + (ea-for-xf-desc tn complex-long-float-imag-slot))) (macrolet ((ea-for-xf-stack (tn kind) `(make-ea :dword :base ebp-tn :disp (- (* (+ (tn-offset ,tn) (ecase ,kind (:single 1) (:double 2) (:long 3))) - sb!vm:word-bytes))))) + n-word-bytes))))) (defun ea-for-sf-stack (tn) (ea-for-xf-stack tn :single)) (defun ea-for-df-stack (tn) @@ -78,7 +78,7 @@ (:double 2) (:long 3)) (ecase ,slot (:real 1) (:imag 2)))) - sb!vm:word-bytes))))) + n-word-bytes))))) (defun ea-for-csf-real-stack (tn &optional (base ebp-tn)) (ea-for-cxf-stack tn :single :real base)) (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn)) @@ -123,13 +123,13 @@ ;;;; move functions -;;; x is source, y is destination -(define-move-function (load-single 2) (vop x y) +;;; X is source, Y is destination. +(define-move-fun (load-single 2) (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 2) (vop x y) +(define-move-fun (store-single 2) (vop x y) ((single-reg) (single-stack)) (cond ((zerop (tn-offset x)) (inst fst (ea-for-sf-stack y))) @@ -139,12 +139,12 @@ ;; This may not be necessary as ST0 is likely invalid now. (inst fxch x)))) -(define-move-function (load-double 2) (vop x y) +(define-move-fun (load-double 2) (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 2) (vop x y) +(define-move-fun (store-double 2) (vop x y) ((double-reg) (double-stack)) (cond ((zerop (tn-offset x)) (inst fstd (ea-for-df-stack y))) @@ -155,13 +155,13 @@ (inst fxch x)))) #!+long-float -(define-move-function (load-long 2) (vop x y) +(define-move-fun (load-long 2) (vop x y) ((long-stack) (long-reg)) (with-empty-tn@fp-top(y) (inst fldl (ea-for-lf-stack x)))) #!+long-float -(define-move-function (store-long 2) (vop x y) +(define-move-fun (store-long 2) (vop x y) ((long-reg) (long-stack)) (cond ((zerop (tn-offset x)) (store-long-float (ea-for-lf-stack y))) @@ -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. -(define-move-function (load-fp-constant 2) (vop x y) +(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 @@ -223,8 +227,8 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) :offset (1+ (tn-offset x)))) -;;; x is source, y is destination. -(define-move-function (load-complex-single 2) (vop x y) +;;; X is source, Y is destination. +(define-move-fun (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) (let ((real-tn (complex-single-reg-real-tn y))) (with-empty-tn@fp-top (real-tn) @@ -233,7 +237,7 @@ (with-empty-tn@fp-top (imag-tn) (inst fld (ea-for-csf-imag-stack x))))) -(define-move-function (store-complex-single 2) (vop x y) +(define-move-fun (store-complex-single 2) (vop x y) ((complex-single-reg) (complex-single-stack)) (let ((real-tn (complex-single-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) @@ -247,7 +251,7 @@ (inst fst (ea-for-csf-imag-stack y)) (inst fxch imag-tn))) -(define-move-function (load-complex-double 2) (vop x y) +(define-move-fun (load-complex-double 2) (vop x y) ((complex-double-stack) (complex-double-reg)) (let ((real-tn (complex-double-reg-real-tn y))) (with-empty-tn@fp-top(real-tn) @@ -256,7 +260,7 @@ (with-empty-tn@fp-top(imag-tn) (inst fldd (ea-for-cdf-imag-stack x))))) -(define-move-function (store-complex-double 2) (vop x y) +(define-move-fun (store-complex-double 2) (vop x y) ((complex-double-reg) (complex-double-stack)) (let ((real-tn (complex-double-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) @@ -271,7 +275,7 @@ (inst fxch imag-tn))) #!+long-float -(define-move-function (load-complex-long 2) (vop x y) +(define-move-fun (load-complex-long 2) (vop x y) ((complex-long-stack) (complex-long-reg)) (let ((real-tn (complex-long-reg-real-tn y))) (with-empty-tn@fp-top(real-tn) @@ -281,7 +285,7 @@ (inst fldl (ea-for-clf-imag-stack x))))) #!+long-float -(define-move-function (store-complex-long 2) (vop x y) +(define-move-fun (store-complex-long 2) (vop x y) ((complex-long-reg) (complex-long-stack)) (let ((real-tn (complex-long-reg-real-tn x))) (cond ((zerop (tn-offset real-tn)) @@ -388,8 +392,8 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:single-float-type - sb!vm:single-float-size node) + single-float-widetag + single-float-size node) (with-tn@fp-top(x) (inst fst (ea-for-sf-desc y)))))) (define-move-vop move-from-single :move @@ -402,8 +406,8 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:double-float-type - sb!vm:double-float-size + double-float-widetag + double-float-size node) (with-tn@fp-top(x) (inst fstd (ea-for-df-desc y)))))) @@ -418,8 +422,8 @@ (:note "float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:long-float-type - sb!vm:long-float-size + long-float-widetag + long-float-size node) (with-tn@fp-top(x) (store-long-float (ea-for-lf-desc y)))))) @@ -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 @@ -494,8 +498,9 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-single-float-type - sb!vm:complex-single-float-size node) + complex-single-float-widetag + complex-single-float-size + node) (let ((real-tn (complex-single-reg-real-tn x))) (with-tn@fp-top(real-tn) (inst fst (ea-for-csf-real-desc y)))) @@ -512,8 +517,8 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-double-float-type - sb!vm:complex-double-float-size + complex-double-float-widetag + complex-double-float-size node) (let ((real-tn (complex-double-reg-real-tn x))) (with-tn@fp-top(real-tn) @@ -532,8 +537,8 @@ (:note "complex float to pointer coercion") (:generator 13 (with-fixed-allocation (y - sb!vm:complex-long-float-type - sb!vm:complex-long-float-size + complex-long-float-widetag + complex-long-float-size node) (let ((real-tn (complex-long-reg-real-tn x))) (with-tn@fp-top(real-tn) @@ -578,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) @@ -601,7 +606,7 @@ (inst fxch x))))) (,stack-sc (if (= (tn-offset fp) esp-offset) - (let* ((offset (* (tn-offset y) word-bytes)) + (let* ((offset (* (tn-offset y) n-word-bytes)) (ea (make-ea :dword :base fp :disp offset))) (with-tn@fp-top(x) ,@(ecase format @@ -616,21 +621,21 @@ (:single 1) (:double 2) (:long 3))) - sb!vm:word-bytes))))) + n-word-bytes))))) (with-tn@fp-top(x) ,@(ecase format (:single '((inst fst ea))) (: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) @@ -698,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)) @@ -1527,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 @@ -1850,7 +1828,7 @@ (storew lo-bits ebp-tn (- (1+ offset))) (with-empty-tn@fp-top(res) (inst fldd (make-ea :dword :base ebp-tn - :disp (- (* (1+ offset) word-bytes)))))))) + :disp (- (* (1+ offset) n-word-bytes)))))))) #!+long-float (define-vop (make-long-float) @@ -1871,7 +1849,7 @@ (storew lo-bits ebp-tn (- (+ offset 2))) (with-empty-tn@fp-top(res) (inst fldl (make-ea :dword :base ebp-tn - :disp (- (* (+ offset 2) word-bytes)))))))) + :disp (- (* (+ offset 2) n-word-bytes)))))))) (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) @@ -1895,8 +1873,8 @@ (inst mov bits float)) (descriptor-reg (loadw - bits float sb!vm:single-float-value-slot - sb!vm:other-pointer-lowtag)))) + bits float single-float-value-slot + other-pointer-lowtag)))) (signed-stack (sc-case float (single-reg @@ -1919,14 +1897,14 @@ (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn :disp (- (* (+ 2 (tn-offset temp)) - word-bytes))))) + n-word-bytes))))) (inst fstd where))) (loadw hi-bits ebp-tn (- (1+ (tn-offset temp))))) (double-stack (loadw hi-bits ebp-tn (- (1+ (tn-offset float))))) (descriptor-reg - (loadw hi-bits float (1+ sb!vm:double-float-value-slot) - sb!vm:other-pointer-lowtag))))) + (loadw hi-bits float (1+ double-float-value-slot) + other-pointer-lowtag))))) (define-vop (double-float-low-bits) (:args (float :scs (double-reg descriptor-reg) @@ -1944,14 +1922,14 @@ (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn :disp (- (* (+ 2 (tn-offset temp)) - word-bytes))))) + n-word-bytes))))) (inst fstd where))) (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp))))) (double-stack (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float))))) (descriptor-reg - (loadw lo-bits float sb!vm:double-float-value-slot - sb!vm:other-pointer-lowtag))))) + (loadw lo-bits float double-float-value-slot + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-exp-bits) @@ -1970,21 +1948,21 @@ (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn :disp (- (* (+ 3 (tn-offset temp)) - word-bytes))))) + n-word-bytes))))) (store-long-float where))) (inst movsx exp-bits (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset temp))) word-bytes)))) + :disp (* (- (1+ (tn-offset temp))) n-word-bytes)))) (long-stack (inst movsx exp-bits (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset float))) word-bytes)))) + :disp (* (- (1+ (tn-offset float))) n-word-bytes)))) (descriptor-reg (inst movsx exp-bits (make-ea :word :base float - :disp (- (* (+ 2 sb!vm:long-float-value-slot) - word-bytes) - sb!vm:other-pointer-lowtag))))))) + :disp (- (* (+ 2 long-float-value-slot) + n-word-bytes) + other-pointer-lowtag))))))) #!+long-float (define-vop (long-float-high-bits) @@ -2003,14 +1981,14 @@ (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn :disp (- (* (+ 3 (tn-offset temp)) - word-bytes))))) + n-word-bytes))))) (store-long-float where))) (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2)))) (long-stack (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2)))) (descriptor-reg - (loadw hi-bits float (1+ sb!vm:long-float-value-slot) - sb!vm:other-pointer-lowtag))))) + (loadw hi-bits float (1+ long-float-value-slot) + other-pointer-lowtag))))) #!+long-float (define-vop (long-float-low-bits) @@ -2029,14 +2007,14 @@ (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn :disp (- (* (+ 3 (tn-offset temp)) - word-bytes))))) + n-word-bytes))))) (store-long-float where))) (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3)))) (long-stack (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3)))) (descriptor-reg - (loadw lo-bits float sb!vm:long-float-value-slot - sb!vm:other-pointer-lowtag))))) + (loadw lo-bits float long-float-value-slot + other-pointer-lowtag))))) ;;;; float mode hackery @@ -2045,9 +2023,9 @@ (defknown ((setf floating-point-modes)) (float-modes) float-modes) -(defconstant npx-env-size (* 7 sb!vm: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))) @@ -3148,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) @@ -4012,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 @@ -4067,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