From: Nikodemus Siivola Date: Mon, 8 Mar 2010 13:44:58 +0000 (+0000) Subject: 1.0.36.14: better differences of numeric types X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=751e312b3f7cf6a1134f25e3f760c4599e5c4b39;p=sbcl.git 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 --- 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 --- 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)))))) (!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 --- 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 --- 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 --- 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"