X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffloat.pure.lisp;h=289360f6eb07618dc3807fd772efe2a7e4ecbce7;hb=f31bc323d5bfc205f94164b203833f35033df3cd;hp=1b983b7c9e6f51bbb55b765a6d8c8c25b3e3c2fa;hpb=fcd65db754f3a5062fccf136bc633e658e4967b3;p=sbcl.git diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 1b983b7..289360f 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -93,7 +93,7 @@ (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))) (with-test (:name (:scale-float-overflow :bug-372) - :fails-on '(or :ppc :darwin (and :x86 :openbsd))) ;; bug 372 + :fails-on :darwin) ;; bug 372 (progn (assert (raises-error? (scale-float 1.0 most-positive-fixnum) floating-point-overflow)) @@ -125,11 +125,13 @@ (funcall (compile nil '(lambda () (tan (tan (round 0)))))) (with-test (:name (:addition-overflow :bug-372) - :fails-on '(or :ppc :darwin (and :x86 (or :netbsd :openbsd)))) + :fails-on '(or (and :ppc :openbsd) :darwin (and :x86 :netbsd))) (assert (typep (nth-value 1 (ignore-errors (sb-sys:without-interrupts + (sb-int:set-floating-point-modes :current-exceptions nil + :accrued-exceptions nil) (loop repeat 2 summing most-positive-double-float) (sleep 2)))) 'floating-point-overflow))) @@ -231,3 +233,140 @@ (assert (eql 0.0d0 (funcall f 123.0d0 0.0))) (assert (eql 0.0d0 (funcall f 123.0d0 0.0d0))) (assert (eql 0.0d0 (funcall f 123.0 0.0d0))))) + +;; Bug reported by Eric Marsden on July 15 2009. The compiler +;; used not to constant fold calls with arguments of type +;; (EQL foo). +(with-test (:name :eql-type-constant-fold) + (assert (equal '(FUNCTION (T) (VALUES (MEMBER T) &OPTIONAL)) + (sb-kernel:%simple-fun-type + (compile nil `(lambda (x) + (eql #c(1.0 2.0) + (the (eql #c(1.0 2.0)) + x)))))))) + +;; The x86 port used not to reduce the arguments of transcendentals +;; correctly. On other platforms, we trust libm to DTRT. +#+x86 +(with-test (:name :range-reduction) + (flet ((almost= (x y) + (< (abs (- x y)) 1d-5))) + (macrolet ((foo (op value) + `(assert (almost= (,op (mod ,value (* 2 pi))) + (,op ,value))))) + (let ((big (* pi (expt 2d0 70))) + (mid (coerce most-positive-fixnum 'double-float)) + (odd (* pi most-positive-fixnum))) + (foo sin big) + (foo sin mid) + (foo sin odd) + (foo sin (/ odd 2d0)) + + (foo cos big) + (foo cos mid) + (foo cos odd) + (foo cos (/ odd 2d0)) + + (foo tan big) + (foo tan mid) + (foo tan odd))))) + +;; Leakage from the host could result in wrong values for truncation. +(with-test (:name :truncate) + (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 33)))) + (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 33)))) + ;; That'd be one strange host, but just in case + (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 65)))) + (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 65))))) + +;; On x86-64, we sometimes forgot to clear the higher order bits of the +;; destination register before using it with an instruction that doesn't +;; clear the (unused) high order bits. Suspect instructions are operations +;; with only one operand: for everything else, the destination has already +;; been loaded with a value, making it safe (by induction). +;; +;; The tests are extremely brittle and could be broken by any number of +;; back- or front-end optimisations. We should just keep the issue above +;; in mind at all times when working with SSE or similar instruction sets. +#+(or x86 x86-64) ;; No other platforms have SB-VM::TOUCH-OBJECT. +(macrolet ((with-pinned-floats ((count type &rest names) &body body) + "Force COUNT float values to be kept live (and hopefully in registers), + fill a temporary register with noise, and execute BODY." + (let ((dummy (loop repeat count + collect (or (pop names) + (gensym "TEMP"))))) + `(let ,(loop for i downfrom -1 + for var in dummy + for j = (coerce i type) + collect + `(,var ,(complex j j))) ; we don't actually need that, but + (declare (type (complex ,type) ,@dummy)) ; future-proofing can't hurt + ,@(loop for var in dummy + for i upfrom 0 + collect `(setf ,var ,(complex i (coerce i type)))) + (multiple-value-prog1 + (progn + (let ((x ,(complex 1d0 1d0))) + (declare (type (complex double-float) x)) + (setf x ,(complex most-positive-fixnum (float most-positive-fixnum 1d0))) + (sb-vm::touch-object x)) + (locally ,@body)) + ,@(loop for var in dummy + collect `(sb-vm::touch-object ,var))))))) + (with-test (:name :clear-sqrtsd) + (flet ((test-sqrtsd (float) + (declare (optimize speed (safety 1)) + (type (double-float (0d0)) float)) + (with-pinned-floats (14 double-float x0) + (let ((x (sqrt float))) + (values (+ x x0) float))))) + (declare (notinline test-sqrtsd)) + (assert (zerop (imagpart (test-sqrtsd 4d0)))))) + + (with-test (:name :clear-sqrtsd-single) + (flet ((test-sqrtsd-float (float) + (declare (optimize speed (safety 1)) + (type (single-float (0f0)) float)) + (with-pinned-floats (14 single-float x0) + (let ((x (sqrt float))) + (values (+ x x0) float))))) + (declare (notinline test-sqrtsd-float)) + (assert (zerop (imagpart (test-sqrtsd-float 4f0)))))) + + (with-test (:name :clear-cvtss2sd) + (flet ((test-cvtss2sd (float) + (declare (optimize speed (safety 1)) + (type single-float float)) + (with-pinned-floats (14 double-float x0) + (let ((x (float float 0d0))) + (values (+ x x0) (+ 1e0 float)))))) + (declare (notinline test-cvtss2sd)) + (assert (zerop (imagpart (test-cvtss2sd 1f0)))))) + + (with-test (:name :clear-cvtsd2ss) + (flet ((test-cvtsd2ss (float) + (declare (optimize speed (safety 1)) + (type double-float float)) + (with-pinned-floats (14 single-float x0) + (let ((x (float float 1e0))) + (values (+ x x0) (+ 1d0 float)))))) + (declare (notinline test-cvtsd2ss)) + (assert (zerop (imagpart (test-cvtsd2ss 4d0)))))) + + (with-test (:name :clear-cvtsi2sd) + (flet ((test-cvtsi2sd (int) + (declare (optimize speed (safety 0)) + (type (unsigned-byte 10) int)) + (with-pinned-floats (15 double-float x0) + (+ (float int 0d0) x0)))) + (declare (notinline test-cvtsi2sd)) + (assert (zerop (imagpart (test-cvtsi2sd 4)))))) + + (with-test (:name :clear-cvtsi2ss) + (flet ((test-cvtsi2ss (int) + (declare (optimize speed (safety 0)) + (type (unsigned-byte 10) int)) + (with-pinned-floats (15 single-float x0) + (+ (float int 0e0) x0)))) + (declare (notinline test-cvtsi2ss)) + (assert (zerop (imagpart (test-cvtsi2ss 4)))))))