From e470d15075046b67add2863185514c47b578e22c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 21 Aug 2006 17:54:38 +0000 Subject: [PATCH] 0.9.15.44: fix bug 368: intersection of array types * TYPE-INTERSECTION of arrays preserves the specialized type when appropriate -- even if the intersection of the expressed types is empty. * Delete bug 217 -- has been fixed, is in the test-suite. * Note about bug 235. * Not more *USE-IMPLEMENTATION-TYPES*, behave always as if it was T. --- BUGS | 67 +++---------------------------------------- NEWS | 4 +++ package-data-list.lisp-expr | 1 - src/code/late-type.lisp | 67 +++++++++++++++++-------------------------- tests/compiler.impure.lisp | 28 ++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 64 insertions(+), 105 deletions(-) diff --git a/BUGS b/BUGS index 0e990ce..98e54ac 100644 --- a/BUGS +++ b/BUGS @@ -635,31 +635,6 @@ WORKAROUND: This is probably the same bug as 162 -217: "Bad type operations with FUNCTION types" - In sbcl.0.7.7: - - * (values-type-union (specifier-type '(function (base-char))) - (specifier-type '(function (integer)))) - - # - - It causes insertion of wrong type assertions into generated - code. E.g. - - (defun foo (x s) - (let ((f (etypecase x - (character #'write-char) - (integer #'write-byte)))) - (funcall f x s) - (etypecase x - (character (write-char x s)) - (integer (write-byte x s))))) - - Then (FOO #\1 *STANDARD-OUTPUT*) signals type error. - - (In 0.7.9.1 the result type is (FUNCTION * *), so Python does not - produce invalid code, but type checking is not accurate.) - 235: "type system and inline expansion" a. (declaim (ftype (function (cons) number) acc)) @@ -675,6 +650,10 @@ WORKAROUND: (foo '(nil) '(t)) => NIL, T. + As of 0.9.15.41 this seems to be due to ACC being inlined only once + inside FOO, which results in the second call reusing the FUNCTIONAL + resulting from the first -- which doesn't check the type. + 237: "Environment arguments to type functions" a. Functions SUBTYPEP, TYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, and UPGRADED-COMPLEX-PART-TYPE now have an optional environment @@ -1466,44 +1445,6 @@ WORKAROUND: bug 367b: Comment out the (DECLAIM (FTYPE ... R367)), and compile the file. The compiler fails with TYPE-ERROR at compile time. -368: miscompiled OR (perhaps related to bug 367) - Trying to relax type declarations to find a workaround for bug 367, - it turns out that even when the return type isn't declared (or - declared to be T, anyway) the system remains confused about type - inference in code similar to that for bug 367: - (in-package :cl-user) - (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1))) - (defstruct e368) - (defstruct i368) - (defstruct g368 - (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null))) - (defstruct s368 - (g368 (error "missing :G368") :type g368 :read-only t)) - (declaim (ftype (function (fixnum (vector i368) e368) t) r368)) - (declaim (ftype (function (fixnum (vector e368)) t) h368)) - (defparameter *h368-was-called-p* nil) - (defun nsu (vertices e368) - (let ((i368s (g368-i368s (make-g368)))) - (let ((fuis (r368 0 i368s e368))) - (format t "~&FUIS=~S~%" fuis) - (or fuis (h368 0 i368s))))) - (defun r368 (w x y) - (declare (ignore w x y)) - nil) - (defun h368 (w x) - (declare (ignore w x)) - (setf *h368-was-called-p* t) - (make-s368 :g368 (make-g368))) - (trace r368 h368) - (format t "~&calling NSU~%") - (let ((nsu (nsu #() (make-e368)))) - (format t "~&NSU returned ~S~%" nsu) - (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*) - (assert (s368-p nsu)) - (assert *h368-was-called-p*)) - In sbcl-0.8.18, both ASSERTs fail, and (DISASSEMBLE 'NSU) shows - that no call to H368 is compiled. - 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 diff --git a/NEWS b/NEWS index de2eb1f..d87c5ec 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: * feature: implemented the READER-METHOD-CLASS and WRITER-METHOD-CLASS portion of the Class Initialization Protocol as specified by AMOP. + * incompatible change: variable SB-EXT:*USE-IMPLEMENTATION-TYPES* + no longer exists. * optimization: faster LOGCOUNT implementation on x86 and x86-64 (thanks to Lutz Euler) * optimization: hashing of general arrays and vectors has been @@ -54,6 +56,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: types in some cases. * bug fix: fixed input, output and error redirection in RUN-PROGRAM for win32. (thanks to Mike Thomas and Yaroslav Kavenchuk) + * bug fix: #368: incorrect use of expressed vs. upgraded array + element type. * thread-safety improvements: ** CONDITION-WAIT could return early on Linux, if the thread was interrupted and subsequently continued with SIGCONT. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 53148b3..f60e23f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -654,7 +654,6 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; ..and variables to control compiler policy "*INLINE-EXPANSION-LIMIT*" - "*USE-IMPLEMENTATION-TYPES*" "*DERIVE-FUNCTION-TYPES*" ;; ..and inspector of compiler policy diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index aaf4213..a5788bd 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -30,18 +30,6 @@ (define-condition parse-unknown-type (condition) ((specifier :reader parse-unknown-type-specifier :initarg :specifier))) -;;; FIXME: This really should go away. Alas, it doesn't seem to be so -;;; simple to make it go away.. (See bug 123 in BUGS file.) -(defvar *use-implementation-types* t ; actually initialized in cold init - #!+sb-doc - "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how - restrictive we are in determining type membership. If two types are the - same in the implementation, then we will consider them them the same when - this switch is on. When it is off, we try to be as restrictive as the - language allows, allowing us to detect more errors. Currently, this only - affects array types.") -(!cold-init-forms (setq *use-implementation-types* t)) - ;;; These functions are used as method for types which need a complex ;;; subtypep method to handle some superclasses, but cover a subtree ;;; of the type graph (i.e. there is no simple way for any other type @@ -2250,15 +2238,6 @@ used for a COMPLEX component.~:@>" (!define-type-class array) -;;; What this does depends on the setting of the -;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized -;;; element type, otherwise return the original element type. -(defun specialized-element-type-maybe (type) - (declare (type array-type type)) - (if *use-implementation-types* - (array-type-specialized-element-type type) - (array-type-element-type type))) - (!define-type-method (array :simple-=) (type1 type2) (cond ((not (and (equal (array-type-dimensions type1) (array-type-dimensions type2)) @@ -2276,8 +2255,8 @@ used for a COMPLEX component.~:@>" (aver (not (and (not equalp) certainp))) (values equalp certainp))) (t - (values (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2)) + (values (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2)) t)))) (!define-type-method (array :negate) (type) @@ -2363,8 +2342,8 @@ used for a COMPLEX component.~:@>" ;; types are equal, and they're equal iff the specialized ;; element types are identical. t - (values (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2)) + (values (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2)) t))))) ;;; FIXME: is this dead? @@ -2414,8 +2393,8 @@ used for a COMPLEX component.~:@>" ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 ((or (eq (array-type-specialized-element-type type1) *wild-type*) (eq (array-type-specialized-element-type type2) *wild-type*) - (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2))) + (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2))) (values t t)) (t @@ -2429,19 +2408,27 @@ used for a COMPLEX component.~:@>" (complexp1 (array-type-complexp type1)) (complexp2 (array-type-complexp type2)) (eltype1 (array-type-element-type type1)) - (eltype2 (array-type-element-type type2))) - (specialize-array-type - (make-array-type - :dimensions (cond ((eq dims1 '*) dims2) - ((eq dims2 '*) dims1) - (t - (mapcar (lambda (x y) (if (eq x '*) y x)) - dims1 dims2))) - :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (cond - ((eq eltype1 *wild-type*) eltype2) - ((eq eltype2 *wild-type*) eltype1) - (t (type-intersection eltype1 eltype2)))))) + (eltype2 (array-type-element-type type2)) + (stype1 (array-type-specialized-element-type type1)) + (stype2 (array-type-specialized-element-type type2))) + (flet ((intersect () + (make-array-type + :dimensions (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar (lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) + (if (or (eq stype1 *wild-type*) (eq stype2 *wild-type*)) + (specialize-array-type (intersect)) + (let ((type (intersect))) + (aver (type= stype1 stype2)) + (setf (array-type-specialized-element-type type) stype1) + type)))) *empty-type*)) ;;; Check a supplied dimension list to determine whether it is legal, diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index caf24e7..86018e2 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1327,4 +1327,32 @@ (funcall x)))) nil (constantly 42))))) +;;; bug 368: array type intersections in the compiler +(defstruct e368) +(defstruct i368) +(defstruct g368 + (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null))) +(defstruct s368 + (g368 (error "missing :G368") :type g368 :read-only t)) +(declaim (ftype (function (fixnum (vector i368) e368) t) r368)) +(declaim (ftype (function (fixnum (vector e368)) t) h368)) +(defparameter *h368-was-called-p* nil) +(defun nsu (vertices e368) + (let ((i368s (g368-i368s (make-g368)))) + (let ((fuis (r368 0 i368s e368))) + (format t "~&FUIS=~S~%" fuis) + (or fuis (h368 0 i368s))))) +(defun r368 (w x y) + (declare (ignore w x y)) + nil) +(defun h368 (w x) + (declare (ignore w x)) + (setf *h368-was-called-p* t) + (make-s368 :g368 (make-g368))) +(let ((nsu (nsu #() (make-e368)))) + (format t "~&NSU returned ~S~%" nsu) + (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*) + (assert (s368-p nsu)) + (assert *h368-was-called-p*)) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 47792c6..0d6302a 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.43" +"0.9.15.44" -- 1.7.10.4