From: Nikodemus Siivola Date: Wed, 23 Aug 2006 12:46:26 +0000 (+0000) Subject: 0.9.15.48: more precice unions of array types X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=98c725660502dc1a761e60ac935f95ed60143021;p=sbcl.git 0.9.15.48: more precice unions of array types * implement ARRAY :SIMPLE-UNION2, and don't use CSUBTYPEP to shortcut unions where both types are array types -- fixes bug #306a. (Move to tests.) * move comments in UNION-COMPLEX-SUBTYPEP-ARG2 slightly for clarity. * bug #367 went with #368. * bug #387 is fixed nowadays. --- diff --git a/BUGS b/BUGS index 98e54ac..7f7a373 100644 --- a/BUGS +++ b/BUGS @@ -988,13 +988,8 @@ WORKAROUND: The problem is that both EVALs sequentially write to the same LVAR. 306: "Imprecise unions of array types" - a.(defun foo (x) - (declare (optimize speed) - (type (or (array cons) (array vector)) x)) - (elt (aref x 0) 0)) - (foo #((0))) => TYPE-ERROR - relatedly, + a. fixed in SBCL 0.9.15.48 b.(subtypep 'array @@ -1409,42 +1404,6 @@ WORKAROUND: Expected: ERROR Got: # -367: TYPE-ERROR at compile time, undetected TYPE-ERROR at runtime - This test program - (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1))) - (defstruct e367) - (defstruct i367) - (defstruct g367 - (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null))) - (defstruct s367 - (g367 (error "missing :G367") :type g367 :read-only t)) - ;;; In sbcl-0.8.18, commenting out this (DECLAIM (FTYPE ... R367)) - ;;; gives an internal error at compile time: - ;;; The value # is not of - ;;; type SB-KERNEL:VALUES-TYPE. - (declaim (ftype (function ((vector i367) e367) (or s367 null)) r367)) - (declaim (ftype (function ((vector e367)) (values)) h367)) - (defun frob (v w) - (let ((x (g367-i367s (make-g367)))) - (let* ((y (or (r367 x w) - (h367 x))) - (z (s367-g367 y))) - (format t "~&Y=~S Z=~S~%" y z) - (g367-i367s z)))) - (defun r367 (x y) (declare (ignore x y)) nil) - (defun h367 (x) (declare (ignore x)) (values)) - ;;; In sbcl-0.8.18, executing this form causes an low-level error - ;;; segmentation violation at #X9B0E1F4 - ;;; (instead of the TYPE-ERROR that one might like). - (frob 0 (make-e367)) - can be made to cause two different problems, as noted in the comments: - bug 367a: Compile and load the file. No TYPE-ERROR is signalled at - run time (in the (S367-G367 Y) form of FROB, when Y is NIL - instead of an instance of S367). Instead (on x86/Linux at least) - we end up with a segfault. - bug 367b: Comment out the (DECLAIM (FTYPE ... R367)), and compile - the file. The compiler fails with TYPE-ERROR at compile time. - 369: unlike-an-intersection behavior of VALUES-TYPE-INTERSECTION In sbcl-0.8.18.2, the identity $(x \cap y \cap y)=(x \cap y)$ does not hold for VALUES-TYPE-INTERSECTION, even for types which @@ -1582,16 +1541,6 @@ WORKAROUND: stack exhaustion checking (implemented with a write-protected guard page) does not work on SunOS/x86. -387: - 12:10 < jsnell> the package-lock test is basically due to a change in the test - behaviour when you install a handler for error around it. I - thought I'd disabled the test for now, but apparently that was - my imagination - 12:19 < Xophe> jsnell: ah, I see the problem in the package-locks stuff - 12:19 < Xophe> it's the same problem as we had with compiler-error conditions - 12:19 < Xophe> the thing that's signalled up and down the stack is a subtype of - ERROR, where it probably shouldn't be - 388: (found by Dmitry Bogomolov) diff --git a/NEWS b/NEWS index 671d259..95aa1e6 100644 --- a/NEWS +++ b/NEWS @@ -58,6 +58,7 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: for win32. (thanks to Mike Thomas and Yaroslav Kavenchuk) * bug fix: #368: incorrect use of expressed vs. upgraded array element type. + * bug fix: #306a: more precise unions of array types. * thread-safety improvements: ** CONDITION-WAIT could return early on Linux, if the thread was interrupted and subsequently continued with SIGCONT. diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index a5788bd..1c5b8ea 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -792,19 +792,25 @@ ;; e.g. fading away in favor of some CLOS solution) the shared logic ;; should probably become shared code. -- WHN 2001-03-16 (declare (type ctype type1 type2)) - (cond ((eq type1 type2) - type1) - ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - ((or (union-type-p type1) - (union-type-p type2)) - ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES - ;; values broken out and united separately. The full TYPE-UNION - ;; function knows how to do this, so let it handle it. - (type-union type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-union2 type1 type2)))) + (let ((t2 nil)) + (cond ((eq type1 type2) + type1) + ;; CSUBTYPEP for array-types answers questions about the + ;; specialized type, yet for union we want to take the + ;; expressed type in account too. + ((and (not (and (array-type-p type1) (array-type-p type2))) + (or (setf t2 (csubtypep type1 type2)) + (csubtypep type2 type1))) + (if t2 type2 type1)) + ((or (union-type-p type1) + (union-type-p type2)) + ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES + ;; values broken out and united separately. The full TYPE-UNION + ;; function knows how to do this, so let it handle it. + (type-union type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-union2 type1 type2))))) ;;; the type method dispatch case of TYPE-INTERSECTION2 (defun %type-intersection2 (type1 type2) @@ -2400,6 +2406,41 @@ used for a COMPLEX component.~:@>" (t (values nil t))))) +(!define-type-method (array :simple-union2) (type1 type2) + (let* ((dims1 (array-type-dimensions type1)) + (dims2 (array-type-dimensions type2)) + (complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2)) + (eltype1 (array-type-element-type type1)) + (eltype2 (array-type-element-type type2)) + (stype1 (array-type-specialized-element-type type1)) + (stype2 (array-type-specialized-element-type type2)) + (wild1 (eq eltype1 *wild-type*)) + (wild2 (eq eltype2 *wild-type*)) + (e2 nil)) + ;; This is possibly a bit more conservative then it needs to be: + ;; it seems that wild eltype in either should lead to wild eltype + ;; in result, but the rest of the type-system doesn't seem too + ;; happy about that. --NS 2006-08-23 + (when (and (or (and wild1 wild2) + (and (not (or wild1 wild2)) + (or (setf e2 (csubtypep eltype1 eltype2)) + (csubtypep eltype2 eltype1)))) + (type= stype1 stype2)) + (make-array-type + :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*)) + '*) + ((equal dims1 dims2) + dims1) + ((= (length dims1) (length dims2)) + (mapcar (lambda (x y) (if (eq x y) x '*)) + dims1 dims2)) + (t + '*)) + :complexp (if (eq complexp1 complexp2) complexp1 :maybe) + :element-type (if (or wild2 e2) eltype2 eltype1) + :specialized-element-type stype1)))) + (!define-type-method (array :simple-intersection2) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) @@ -2815,40 +2856,40 @@ used for a COMPLEX component.~:@>" (union-complex-subtypep-arg1 type1 type2)) (defun union-complex-subtypep-arg2 (type1 type2) + ;; At this stage, we know that type2 is a union type and type1 + ;; isn't. We might as well check this, though: + (aver (union-type-p type2)) + (aver (not (union-type-p type1))) + ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which + ;; turns out to be too restrictive, causing bug 91. + ;; + ;; the following reimplementation might look dodgy. It is dodgy. It + ;; depends on the union :complex-= method not doing very much work + ;; -- certainly, not using subtypep. Reasoning: + ;; + ;; A is a subset of (B1 u B2) + ;; <=> A n (B1 u B2) = A + ;; <=> (A n B1) u (A n B2) = A + ;; + ;; But, we have to be careful not to delegate this type= to + ;; something that could invoke subtypep, which might get us back + ;; here -> stack explosion. We therefore ensure that the second type + ;; (which is the one that's dispatched on) is either a union type + ;; (where we've ensured that the complex-= method will not call + ;; subtypep) or something with no union types involved, in which + ;; case we'll never come back here. + ;; + ;; If we don't do this, then e.g. + ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; would loop infinitely, as the member :complex-= method is + ;; implemented in terms of subtypep. + ;; + ;; Ouch. - CSR, 2002-04-10 (multiple-value-bind (sub-value sub-certain?) - ;; was: (any/type #'csubtypep type1 (union-type-types type2)), - ;; which turns out to be too restrictive, causing bug 91. - ;; - ;; the following reimplementation might look dodgy. It is - ;; dodgy. It depends on the union :complex-= method not doing - ;; very much work -- certainly, not using subtypep. Reasoning: - (progn - ;; At this stage, we know that type2 is a union type and type1 - ;; isn't. We might as well check this, though: - (aver (union-type-p type2)) - (aver (not (union-type-p type1))) - ;; A is a subset of (B1 u B2) - ;; <=> A n (B1 u B2) = A - ;; <=> (A n B1) u (A n B2) = A - ;; - ;; But, we have to be careful not to delegate this type= to - ;; something that could invoke subtypep, which might get us - ;; back here -> stack explosion. We therefore ensure that the - ;; second type (which is the one that's dispatched on) is - ;; either a union type (where we've ensured that the complex-= - ;; method will not call subtypep) or something with no union - ;; types involved, in which case we'll never come back here. - ;; - ;; If we don't do this, then e.g. - ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) - ;; would loop infinitely, as the member :complex-= method is - ;; implemented in terms of subtypep. - ;; - ;; Ouch. - CSR, 2002-04-10 - (type= type1 - (apply #'type-union - (mapcar (lambda (x) (type-intersection type1 x)) - (union-type-types type2))))) + (type= type1 + (apply #'type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-type-types type2)))) (if sub-certain? (values sub-value sub-certain?) ;; The ANY/TYPE expression above is a sufficient condition for diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 48b2028..78d6416 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1361,4 +1361,26 @@ (assert (s368-p nsu)) (assert *h368-was-called-p*)) +;;; bug 367: array type intersections in the compiler +(defstruct e367) +(defstruct i367) +(defstruct g367 + (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null))) +(defstruct s367 + (g367 (error "missing :G367") :type g367 :read-only t)) +(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367)) +(declaim (ftype (function ((vector e367)) (values)) h367)) +(defun frob-367 (v w) + (let ((x (g367-i367s (make-g367)))) + (let* ((y (or (r367 x w) + (h367 x))) + (z (s367-g367 y))) + (format t "~&Y=~S Z=~S~%" y z) + (g367-i367s z)))) +(defun r367 (x y) (declare (ignore x y)) nil) +(defun h367 (x) (declare (ignore x)) (values)) +(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367))) + (assert (not res)) + (assert (typep err 'type-error))) + ;;; success diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index f8ab6d2..e9891c9 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -523,4 +523,12 @@ (sb-kernel:specifier-type '(cons goldbach2 single-float))) (assert (not ok)) (assert (not win))) + +;;; precice unions of array types (was bug 306a) +(defun bug-306-a (x) + (declare (optimize speed) + (type (or (array cons) (array vector)) x)) + (elt (aref x 0) 0)) +(assert (= 0 (bug-306-a #((0))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 0ddf1d4..b8daa3f 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".) -"0.9.15.47" +"0.9.15.48"