1.0.36.14: better differences of numeric types

 Handle differences of numeric types accurately in TYPE-DIFFERENCE (no
 change unless both arguments are number-types.)

 Fixes Launchpad bug #309124.

diff --git a/NEWS b/NEWS
index 52952f6..05ae255 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -22,6 +22,7 @@ changes relative to sbcl-1.0.36:
   * bug fix: Breakpoints now work when using ud2 instead of int3 as trap
     instruction (tested on x86oid linux with ud2-breakpoints).
   * bug fix: slam.sh now works on win32.
+  * bug fix: better differences of numeric types (lp#309124)
 
 changes in sbcl-1.0.36 relative to sbcl-1.0.35:
   * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 190c42b..bf4630a 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -3375,42 +3375,45 @@ used for a COMPLEX component.~:@>"
 ;;; type without that particular element. This seems too hairy to be
 ;;; worthwhile, given its low utility.
 (defun type-difference (x y)
-  (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
-        (y-types (if (union-type-p y) (union-type-types y) (list y))))
-    (collect ((res))
-      (dolist (x-type x-types)
-        (if (member-type-p x-type)
-            (let ((xset (alloc-xset))
-                  (fp-zeroes nil))
-              (mapc-member-type-members
-               (lambda (elt)
-                 (multiple-value-bind (ok sure) (ctypep elt y)
-                   (unless sure
-                     (return-from type-difference nil))
-                   (unless ok
-                     (if (fp-zero-p elt)
-                         (pushnew elt fp-zeroes)
-                         (add-to-xset elt xset)))))
-               x-type)
-              (unless (and (xset-empty-p xset) (not fp-zeroes))
-                (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
-            (dolist (y-type y-types (res x-type))
-              (multiple-value-bind (val win) (csubtypep x-type y-type)
-                (unless win (return-from type-difference nil))
-                (when val (return))
-                (when (types-equal-or-intersect x-type y-type)
-                  (return-from type-difference nil))))))
-      (let ((y-mem (find-if #'member-type-p y-types)))
-        (when y-mem
+  (if (and (numeric-type-p x) (numeric-type-p y))
+      ;; Numeric types are easy. Are there any others we should handle like this?
+      (type-intersection x (type-negation y))
+      (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
+            (y-types (if (union-type-p y) (union-type-types y) (list y))))
+        (collect ((res))
           (dolist (x-type x-types)
-            (unless (member-type-p x-type)
-              (mapc-member-type-members
-               (lambda (member)
-                 (multiple-value-bind (ok sure) (ctypep member x-type)
-                   (when (or (not sure) ok)
-                     (return-from type-difference nil))))
-               y-mem)))))
-      (apply #'type-union (res)))))
+            (if (member-type-p x-type)
+                (let ((xset (alloc-xset))
+                      (fp-zeroes nil))
+                  (mapc-member-type-members
+                   (lambda (elt)
+                     (multiple-value-bind (ok sure) (ctypep elt y)
+                       (unless sure
+                         (return-from type-difference nil))
+                       (unless ok
+                         (if (fp-zero-p elt)
+                             (pushnew elt fp-zeroes)
+                             (add-to-xset elt xset)))))
+                   x-type)
+                  (unless (and (xset-empty-p xset) (not fp-zeroes))
+                    (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
+                (dolist (y-type y-types (res x-type))
+                  (multiple-value-bind (val win) (csubtypep x-type y-type)
+                    (unless win (return-from type-difference nil))
+                    (when val (return))
+                    (when (types-equal-or-intersect x-type y-type)
+                      (return-from type-difference nil))))))
+          (let ((y-mem (find-if #'member-type-p y-types)))
+            (when y-mem
+              (dolist (x-type x-types)
+                (unless (member-type-p x-type)
+                  (mapc-member-type-members
+                   (lambda (member)
+                     (multiple-value-bind (ok sure) (ctypep member x-type)
+                       (when (or (not sure) ok)
+                         (return-from type-difference nil))))
+                   y-mem)))))
+          (apply #'type-union (res))))))
 \f
 (!def-type-translator array (&optional (element-type '*)
                                        (dimensions '*))

diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp
index 66685b9..25a6ed4 100644 (file)
--- a/tests/compiler-test-util.lisp
+++ b/tests/compiler-test-util.lisp
@@ -18,6 +18,7 @@
            #:assert-no-consing
            #:compiler-derived-type
            #:find-value-cell-values
+           #:find-code-constants
            #:find-named-callees))
 
 (cl:in-package :ctu)
@@ -49,6 +50,13 @@
                                (equal name (sb-impl::fdefn-name c))))))
           collect (sb-impl::fdefn-fun c))))
 
+(defun find-code-constants (fun &key (type t))
+  (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
+    (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+          for c = (sb-kernel:code-header-ref code i)
+          when (typep c type)
+          collect c)))
+
 (defmacro assert-no-consing (form &optional times)
   `(%assert-no-consing (lambda () ,form) ,times))
 (defun %assert-no-consing (thunk &optional times)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 28d6191..2cf1207 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3455,3 +3455,21 @@
                      (let ((env nil))
                        (typep x 'fixnum env))))))
     (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-309124)
+  (let ((fun
+         (compile nil
+                  `(lambda (x)
+                     (declare (integer x))
+                     (declare (optimize speed))
+                     (cond ((typep x 'fixnum)
+                            "hala")
+                           ((typep x 'fixnum)
+                            "buba")
+                           ((typep x 'bignum)
+                            "hip")
+                           (t
+                            "zuz"))))))
+    (assert (equal (list "hala" "hip")
+                   (sort (ctu:find-code-constants fun :type 'string)
+                         #'string<)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index ad5eda1..c3ce326 100644 (file)
--- 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.36.13"
+"1.0.36.14"