From 672b2f6cb751566526c7f3bb3de6b7d8424760e2 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 30 Jun 2008 09:00:37 +0000 Subject: [PATCH] 1.0.18.2: more conservative interval artihmetic * In SAFELY-BINOP, when the other argument must be coerced to single float, punt if it is an integer that cannot be exactly represented as a single float. * Fixes bug 420, and a whole slew of MISC failures in ansi-tests -- including the ones that used to cause a hard crash or a hang: cvs up -dPC your ansi-test trees, and should huzzah! --- BUGS | 47 ----------- NEWS | 3 + package-data-list.lisp-expr | 7 +- src/code/numbers.lisp | 9 --- src/compiler/generic/early-vm.lisp | 9 +++ src/compiler/srctran.lisp | 59 ++++++++++---- tests/compiler.pure.lisp | 154 ++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 217 insertions(+), 73 deletions(-) diff --git a/BUGS b/BUGS index 7f62d6c..e467f8b 100644 --- a/BUGS +++ b/BUGS @@ -1827,53 +1827,6 @@ WORKAROUND: storing the relevant LAMBDA-VARs in a :DYNAMIC-EXTENT cleanup, and teaching stack analysis how to deal with them. -420: The MISC.556 test from gcl/ansi-tests/misc.lsp fails hard. - -In sbcl-1.0.13 on Linux/x86, executing - (FUNCALL - (COMPILE NIL - '(LAMBDA (P1 P2) - (DECLARE - (OPTIMIZE (SPEED 1) (SAFETY 0) (DEBUG 0) (SPACE 0)) - (TYPE (MEMBER 8174.8604) P1) (TYPE (MEMBER -95195347) P2)) - (FLOOR P1 P2))) - 8174.8604 -95195347) -interactively causes - SB-SYS:MEMORY-FAULT-ERROR: Unhandled memory fault at #x8. -The gcl/ansi-tests/doit.lisp program terminates prematurely shortly after -MISC.556 by falling into gdb with - fatal error encountered in SBCL pid 2827: Unhandled SIGILL -unless the MISC.556 test is commented out. - -Analysis: + and a number of other arithmetic functions exhibit the -same behaviour. Here's the underlying problem: On x86 we perform -single-float + integer normally using double-precision, and then -coerce the result back to single-float. (The FILD instruction always -gives us a double-float, and unless we do MOVE-FROM-SINGLE it remains -one. Or so it seems to me, and that would also explain the observed -behaviour below.) - -During IR1 we derive the types for both - - (+ ) ; uses double-precision - (+ (FLOAT )) ; uses single-precision - -and get a mismatch for a number of unlucky arguments. This leads to -derived result type NIL, and ends up flushing the whole whole -operation -- and finally we generate code without a return sequence, -and fall through to whatever. - -The use of double-precision in the first case appears to be an -(un)happy accident -- interval arithmetic gives us the -double-precision result because that's what the backend does. - - (+ 8172.0 (coerce -95195347 'single-float)) ; => -9.518717e7 - (+ 8172.0 -95195347) ; => -9.5187176e7 - (coerce (+ 8172.0 (coerce -95195347 'double-float)) 'single-float) - ; => -9.5187176e7 - -Which should be fixed, the IR1, or the backend? - 421: READ-CHAR-NO-HANG misbehaviour on Windows Console: It seems that on Windows READ-CHAR-NO-HANG hangs if the user diff --git a/NEWS b/NEWS index 48e1ed6..d62029c 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,9 @@ changes in sbcl-1.0.19 relative to 1.0.18: * bug fix: compiler no longer makes erronous assumptions in the presense of non-foldable SATISFIES types. + * fixed some bugs revealed by Paul Dietz' test suite: + ** interval arithmetic during type derivation used inexact integer + to single-float coercions. changes in sbcl-1.0.18 relative to 1.0.17: * minor incompatible change: SB-SPROF:WITH-PROFILING now by default diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 90079cc..7143b05 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1403,7 +1403,12 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MEMBER-TYPE-SIZE" "MERGE-BITS" - "MODIFIED-NUMERIC-TYPE" "MUTATOR-SELF" "NAMED-TYPE" + "MODIFIED-NUMERIC-TYPE" + "MOST-NEGATIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" + "MOST-NEGATIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" + "MOST-POSITIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" + "MOST-POSITIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" + "MUTATOR-SELF" "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P" "NATIVE-BYTE-ORDER" "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" "NEVER-SUBTYPEP" "NIL-ARRAY-ACCESSED-ERROR" diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 19e6be9..6de67f2 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -827,15 +827,6 @@ the first." (declare (type real number result)) (if (< (car nlist) result) (setq result (car nlist))))) -(defconstant most-positive-exactly-single-float-fixnum - (min #xffffff most-positive-fixnum)) -(defconstant most-negative-exactly-single-float-fixnum - (max #x-ffffff most-negative-fixnum)) -(defconstant most-positive-exactly-double-float-fixnum - (min #x1fffffffffffff most-positive-fixnum)) -(defconstant most-negative-exactly-double-float-fixnum - (max #x-1fffffffffffff most-negative-fixnum)) - (eval-when (:compile-toplevel :execute) ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp index 670e0ad..57c2d9d 100644 --- a/src/compiler/generic/early-vm.lisp +++ b/src/compiler/generic/early-vm.lisp @@ -45,3 +45,12 @@ (ash -1 (- n-word-bits n-lowtag-bits)) #!+sb-doc "the fixnum closest in value to negative infinity") + +(def!constant most-positive-exactly-single-float-fixnum + (min #xffffff most-positive-fixnum)) +(def!constant most-negative-exactly-single-float-fixnum + (max #x-ffffff most-negative-fixnum)) +(def!constant most-positive-exactly-double-float-fixnum + (min #x1fffffffffffff most-positive-fixnum)) +(def!constant most-negative-exactly-double-float-fixnum + (max #x-1fffffffffffff most-negative-fixnum)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 5ae92be..764e617 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -342,6 +342,37 @@ nil (set-bound y (consp x))))))) +(defun safe-double-coercion-p (x) + (or (typep x 'double-float) + (<= most-negative-double-float x most-positive-double-float))) + +(defun safe-single-coercion-p (x) + (or (typep x 'single-float) + ;; Fix for bug 420, and related issues: during type derivation we often + ;; end up deriving types for both + ;; + ;; (some-op ) + ;; and + ;; (some-op (coerce 'single-float) ) + ;; + ;; or other equivalent transformed forms. The problem with this is that + ;; on some platforms like x86 (+ ) is on the machine level + ;; equivalent of + ;; + ;; (coerce (+ (coerce 'double-float) + ;; (coerce 'double-float)) + ;; 'single-float) + ;; + ;; so if the result of (coerce 'single-float) is not exact, the + ;; derived types for the transformed forms will have an empty + ;; intersection -- which in turn means that the compiler will conclude + ;; that the call never returns, and all hell breaks lose when it *does* + ;; return at runtime. (This affects not just +, but other operators are + ;; well.) + (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) + (integer (,most-positive-exactly-single-float-fixnum) *)))) + (<= most-negative-single-float x most-positive-single-float)))) + ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result ;;; is open if either X or Y is open. @@ -355,21 +386,19 @@ (defmacro safely-binop (op x y) `(cond - ((typep ,x 'single-float) - (if (or (typep ,y 'single-float) - (<= most-negative-single-float ,y most-positive-single-float)) - (,op ,x ,y))) - ((typep ,x 'double-float) - (if (or (typep ,y 'double-float) - (<= most-negative-double-float ,y most-positive-double-float)) - (,op ,x ,y))) - ((typep ,y 'single-float) - (if (<= most-negative-single-float ,x most-positive-single-float) - (,op ,x ,y))) - ((typep ,y 'double-float) - (if (<= most-negative-double-float ,x most-positive-double-float) - (,op ,x ,y))) - (t (,op ,x ,y)))) + ((typep ,x 'double-float) + (when (safe-double-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'double-float) + (when (safe-double-coercion-p ,x) + (,op ,x ,y))) + ((typep ,x 'single-float) + (when (safe-single-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'single-float) + (when (safe-single-coercion-p ,x) + (,op ,x ,y))) + (t (,op ,x ,y)))) (defmacro bound-binop (op x y) `(and ,x ,y diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 224fd3d..4c3eb78 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2380,3 +2380,157 @@ ;;; NIL is a legal function name (assert (eq 'a (flet ((nil () 'a)) (nil)))) +;;; misc.528 +(assert (null (let* ((x 296.3066f0) + (y 22717067) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (integer -9369756340 22717335) p2)) + (setf (aref r) (* ,x (the (eql 22717067) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (* x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) +;;; misc.529 +(assert (null (let* ((x -2367.3296f0) + (y 46790178) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (eql 46790178) p2)) + (setf (aref r) (+ ,x (the (integer 45893897) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (+ x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) + +;;; misc.556 +(assert (eql -1 + (funcall + (compile nil '(lambda (p1 p2) + (declare + (optimize (speed 1) (safety 0) + (debug 0) (space 0)) + (type (member 8174.8604) p1) + (type (member -95195347) p2)) + (floor p1 p2))) + 8174.8604 -95195347))) + +;;; misc.557 +(assert (eql -1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) + (type (member -94430.086f0) p1)) + (floor (the single-float p1) 19311235))) + -94430.086f0))) + +;;; misc.558 +(assert (eql -1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 2) + (debug 2) (space 3)) + (type (eql -39466.56f0) p1)) + (ffloor p1 305598613))) + -39466.56f0))) + +;;; misc.559 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) + (type (eql -83232.09f0) p1)) + (ceiling p1 -83381228))) + -83232.09f0))) + +;;; misc.560 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) + (debug 1) (space 0)) + (type (member -66414.414f0) p1)) + (ceiling p1 -63019173f0))) + -66414.414f0))) + +;;; misc.561 +(assert (eql 1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 0) (safety 1) + (debug 0) (space 1)) + (type (eql 20851.398f0) p1)) + (fceiling p1 80839863))) + 20851.398f0))) + +;;; misc.581 +(assert (floatp + (funcall + (compile nil '(lambda (x) + (declare (type (eql -5067.2056) x)) + (+ 213734822 x))) + -5067.2056))) + +;;; misc.581a +(assert (typep + (funcall + (compile nil '(lambda (x) (declare (type (eql -1.0) x)) + (+ #x1000001 x))) + -1.0f0) + 'single-float)) + +;;; misc.582 +(assert (plusp (funcall + (compile + nil + ' (lambda (p1) + (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) + (type (eql -39887.645) p1)) + (mod p1 382352925))) + -39887.645))) + +;;; misc.587 +(assert (let ((result (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) + (type (eql 33558541) p2)) + (- 92215.266 p2))) + 33558541))) + (typep result 'single-float))) + +;;; misc.635 +(assert (eql 1 + (let* ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 1) + (debug 2) (space 2)) + (type (member -19261719) p2)) + (ceiling -46022.094 p2)))) + (values (funcall (compile nil form) -19261719))))) + +;;; misc.636 +(assert (let* ((x 26899.875) + (form `(lambda (p2) + (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) + (type (member ,x #:g5437 char-code #:g5438) p2)) + (* 104102267 p2)))) + (floatp (funcall (compile nil form) x)))) diff --git a/version.lisp-expr b/version.lisp-expr index 1071b41..ca6ebec 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.18.1" +"1.0.18.2" -- 1.7.10.4