X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffloat.pure.lisp;h=5612a73fbcbb99ab070931236babd78825e7c247;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=bea74a83a79e55d746d6ff1e889b654f774c7522;hpb=cb2be4b6d03412e2e547a8b051e43d5446792b7c;p=sbcl.git diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index bea74a8..5612a73 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)) ;; bug 372 + :fails-on '(and :darwin :ppc)) ;; bug 372 (progn (assert (raises-error? (scale-float 1.0 most-positive-fixnum) floating-point-overflow)) @@ -125,7 +125,31 @@ (funcall (compile nil '(lambda () (tan (tan (round 0)))))) (with-test (:name (:addition-overflow :bug-372) - :fails-on '(or :ppc :darwin (and :x86 :netbsd))) + :fails-on '(or (and :ppc :openbsd) + (and :ppc :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))) + +;; This is the same test as above. Even if the above copy passes, +;; this copy will fail if SIGFPE handling ends up clearing the FPU +;; control word, which can happen if the kernel clears the FPU control +;; (a reasonable thing for it to do) and the runtime fails to +;; compensate for this (see RESTORE_FP_CONTROL_WORD in interrupt.c). +;; Note that this only works when running float.pure.lisp alone, as +;; the preceeding "pure" test files aren't as free of side effects as +;; we might like. +(with-test (:name (:addition-overflow :bug-372 :take-2) + :fails-on '(or (and :ppc :openbsd) + (and :ppc :darwin) + (and :x86 :netbsd))) (assert (typep (nth-value 1 (ignore-errors @@ -233,3 +257,137 @@ (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)))))))) + +;; 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. +;; +;; Run only on x86/x86-64m as 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." + ;; KLUDGE: SB-VM is locked, and non-x86oids don't have + ;; SB-VM::TOUCH-OBJECT. Don't even READ this body on + ;; other platforms. + #-(or x86 x86-64) + (declare (ignore count type names body)) + #+(or x86 x86-64) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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 :skipped-on '(not (or :x86 :x86-64))) + (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))))))) + +(with-test (:name :round-to-bignum) + (assert (= (round 1073741822.3d0) 1073741822)) + (assert (= (round 1073741822.5d0) 1073741822)) + (assert (= (round 1073741822.7d0) 1073741823)) + (assert (= (round 1073741823.3d0) 1073741823)) + (assert (= (round 1073741823.5d0) 1073741824)) + (assert (= (round 1073741823.7d0) 1073741824))) + +(with-test (:name :round-single-to-bignum) + (assert (= (round 1e14) 100000000376832)) + (assert (= (round 1e19) 9999999980506447872))) + +(with-test (:name :scaled-%hypot) + (assert (<= (abs (complex most-positive-double-float 1d0)) + (1+ most-positive-double-float))))