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

@@ -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
-
- (+ <single> <integer>) ; uses double-precision
- (+ <single> (FLOAT <integer> <single>)) ; 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

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

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"

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

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))

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 <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this is that
+ ;; on some platforms like x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> '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

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))))

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"