From 94c003b32e49fc11a182d50c405ffa18183aa005 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 8 Mar 2010 17:05:41 +0000 Subject: [PATCH] 1.0.36.15: upgraded array element-type of unions and intersections * Rename EXTRACT-UPGRADED-ELEMENT-TYPE and EXTRACT-DECLARED-ELEMENT-TYPE ARRAY-TYPE-UPGRADED-ELEMENT-TYPE and ARRAY-TYPE-DECLARED-ELEMENT-TYPE, and make them work on array types instead of LVARs. * Make ARRAY-TYPE-UPGRADED-ELEMENT-TYPE able to handle general intersection and union types. Code by "Gustavo" . * Make ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP able to handle general intersection and union types. Fixes Launchpad bug #316078. --- NEWS | 2 + package-data-list.lisp-expr | 1 + src/compiler/array-tran.lisp | 170 ++++++++++++++++++++++++------------- src/compiler/generic/vm-tran.lisp | 10 ++- src/compiler/seqtran.lisp | 4 +- tests/compiler.pure.lisp | 11 +++ version.lisp-expr | 2 +- 7 files changed, 134 insertions(+), 66 deletions(-) diff --git a/NEWS b/NEWS index 05ae255..af7f21c 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,8 @@ changes relative to sbcl-1.0.36: 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) + * bug fix: arrays declared intersection and union types can have their + upgraded element type derived (lp#316078) 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/package-data-list.lisp-expr b/package-data-list.lisp-expr index 371f5e3..c74674d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1645,6 +1645,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV" "TWO-ARG-GCD" "TWO-ARG-IOR" "TWO-ARG-LCM" "TWO-ARG-XOR" + "TYPE-*-TO-T" "TYPE-DIFFERENCE" "TYPE-EXPAND" "TYPE-INTERSECTION" "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2" "TYPE-SINGLE-VALUE-P" "TYPE-SPECIFIER" "TYPE-UNION" diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 5aaf16a..91ca4c6 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -24,49 +24,91 @@ element-type-specifier))) (defun upgraded-element-type-specifier (lvar) - (type-specifier (extract-upgraded-element-type lvar))) + (type-specifier (array-type-upgraded-element-type (lvar-type lvar)))) ;;; Array access functions return an object from the array, hence its type is ;;; going to be the array upgraded element type. Secondary return value is the ;;; known supertype of the upgraded-array-element-type, if if the exact ;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good ;;; as it gets.) -(defun extract-upgraded-element-type (array) - (let ((type (lvar-type array))) - (cond - ;; Note that this IF mightn't be satisfied even if the runtime - ;; value is known to be a subtype of some specialized ARRAY, because - ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), - ;; which are represented in the compiler as INTERSECTION-TYPE, not - ;; array type. - ((array-type-p type) - (values (array-type-specialized-element-type type) nil)) - ;; fix for bug #396. This type logic corresponds to the special case for - ;; strings in HAIRY-DATA-VECTOR-REF (generic/vm-tran.lisp) - ((csubtypep type (specifier-type 'string)) - (cond - ((csubtypep type (specifier-type '(array character (*)))) - (values (specifier-type 'character) nil)) - #!+sb-unicode - ((csubtypep type (specifier-type '(array base-char (*)))) - (values (specifier-type 'base-char) nil)) - ((csubtypep type (specifier-type '(array nil (*)))) - (values *empty-type* nil)) - (t - ;; See KLUDGE below. - (values *wild-type* (specifier-type 'character))))) - (t - ;; KLUDGE: there is no good answer here, but at least - ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be - ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR, - ;; 2002-08-21 - (values *wild-type* nil))))) +(defun array-type-upgraded-element-type (type) + (typecase type + ;; Note that this IF mightn't be satisfied even if the runtime + ;; value is known to be a subtype of some specialized ARRAY, because + ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE), + ;; which are represented in the compiler as INTERSECTION-TYPE, not + ;; array type. + (array-type + (values (array-type-specialized-element-type type) nil)) + ;; Deal with intersection types (bug #316078) + (intersection-type + (let ((intersection-types (intersection-type-types type)) + (element-type *wild-type*) + (element-supertypes nil)) + (dolist (intersection-type intersection-types) + (multiple-value-bind (cur-type cur-supertype) + (array-type-upgraded-element-type intersection-type) + ;; According to ANSI, an array may have only one specialized + ;; element type - e.g. '(and (array foo) (array bar)) + ;; is not a valid type unless foo and bar upgrade to the + ;; same element type. + (cond + ((eq cur-type *wild-type*) + nil) + ((eq element-type *wild-type*) + (setf element-type cur-type)) + ((or (not (csubtypep cur-type element-type)) + (not (csubtypep element-type cur-type))) + ;; At least two different element types where given, the array + ;; is valid iff they represent the same type. + ;; + ;; FIXME: TYPE-INTERSECTION already takes care of disjoint array + ;; types, so I believe this code should be unreachable. Maybe + ;; signal a warning / error instead? + (setf element-type *empty-type*))) + (push (or cur-supertype (type-*-to-t cur-type)) + element-supertypes))) + (values element-type + (when (and (eq *wild-type* element-type) element-supertypes) + (apply #'type-intersection element-supertypes))))) + (union-type + (let ((union-types (union-type-types type)) + (element-type *empty-type*) + (element-supertypes nil)) + (dolist (union-type union-types) + (multiple-value-bind (cur-type cur-supertype) + (array-type-upgraded-element-type union-type) + (cond + ((eq element-type *wild-type*) + nil) + ((eq element-type *empty-type*) + (setf element-type cur-type)) + ((or (eq cur-type *wild-type*) + ;; If each of the two following tests fail, it is not + ;; possible to determine the element-type of the array + ;; because more than one kind of element-type was provided + ;; like in '(or (array foo) (array bar)) although a + ;; supertype (or foo bar) may be provided as the second + ;; returned value returned. See also the KLUDGE below. + (not (csubtypep cur-type element-type)) + (not (csubtypep element-type cur-type))) + (setf element-type *wild-type*))) + (push (or cur-supertype (type-*-to-t cur-type)) + element-supertypes))) + (values element-type + (when (eq *wild-type* element-type) + (apply #'type-union element-supertypes))))) + (t + ;; KLUDGE: there is no good answer here, but at least + ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be + ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR, + ;; 2002-08-21 + (values *wild-type* nil)))) -(defun extract-declared-element-type (array) - (let ((type (lvar-type array))) - (if (array-type-p type) - (array-type-element-type type) - *wild-type*))) +(defun array-type-declared-element-type (type) + (if (array-type-p type) + (array-type-element-type type) + *wild-type*)) ;;; The ``new-value'' for array setters must fit in the array, and the ;;; return type is going to be the same as the new-value for SETF @@ -107,7 +149,8 @@ (lexenv-policy (node-lexenv (lvar-dest array))))) (defun derive-aref-type (array) - (multiple-value-bind (uaet other) (extract-upgraded-element-type array) + (multiple-value-bind (uaet other) + (array-type-upgraded-element-type (lvar-type array)) (or other uaet))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) @@ -606,23 +649,32 @@ ;;; maybe this is just too sloppy for actual type logic. -- CSR, ;;; 2004-02-18 (defun array-type-dimensions-or-give-up (type) - (typecase type - (array-type (array-type-dimensions type)) - (union-type - (let ((types (union-type-types type))) - ;; there are at least two types, right? - (aver (> (length types) 1)) - (let ((result (array-type-dimensions-or-give-up (car types)))) - (dolist (type (cdr types) result) - (unless (equal (array-type-dimensions-or-give-up type) result) - (give-up-ir1-transform - "~@" - (type-specifier type))))))) - ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] - (t - (give-up-ir1-transform - "~@" - (type-specifier type))))) + (labels ((maybe-array-type-dimensions (type) + (typecase type + (array-type + (array-type-dimensions type)) + (union-type + (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions + (union-type-types type)))) + (result (car types))) + (dolist (other (cdr types) result) + (unless (equal result other) + (give-up-ir1-transform + "~@" + (type-specifier type)))))) + (intersection-type + (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions + (intersection-type-types type)))) + (result (car types))) + (dolist (other (cdr types) result) + (unless (equal result other) + (abort-ir1-transform + "~@" + (type-specifier type))))))))) + (or (maybe-array-type-dimensions type) + (give-up-ir1-transform + "~@" + (type-specifier type))))) (defun conservative-array-type-complexp (type) (typecase type @@ -995,13 +1047,13 @@ ;; with sufficient precision, skip directly to DATA-VECTOR-REF. (deftransform aref ((array index) (t t) * :node node) (let* ((type (lvar-type array)) - (element-ctype (extract-upgraded-element-type array))) + (element-ctype (array-type-upgraded-element-type type))) (cond ((and (array-type-p type) (null (array-type-complexp type)) (not (eql element-ctype *wild-type*)) (eql (length (array-type-dimensions type)) 1)) - (let* ((declared-element-ctype (extract-declared-element-type array)) + (let* ((declared-element-ctype (array-type-declared-element-type type)) (bare-form `(data-vector-ref array (%check-bound array (array-dimension array 0) index)))) @@ -1023,9 +1075,9 @@ (macrolet ((define (name transform-to extra extra-type) (declare (ignore extra-type)) `(deftransform ,name ((array index ,@extra)) - (let ((type (lvar-type array)) - (element-type (extract-upgraded-element-type array)) - (declared-type (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-type (array-type-upgraded-element-type type)) + (declared-type (array-type-declared-element-type type))) ;; If an element type has been declared, we want to ;; use that information it for type checking (even ;; if the access can't be optimized due to the array diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index cd67518..287162b 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -112,8 +112,9 @@ ;;; only made for bigger and up 1o 100% slower code. (deftransform hairy-data-vector-ref ((array index) (simple-array t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -200,8 +201,9 @@ (simple-array t t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index a4717f4..0074e14 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -518,9 +518,9 @@ (vector t &key (:start t) (:end t)) * :node node) - (let* ((element-ctype (extract-upgraded-element-type seq)) + (let* ((type (lvar-type seq)) + (element-ctype (array-type-upgraded-element-type type)) (element-type (type-specifier element-ctype)) - (type (lvar-type seq)) (saetp (unless (eq *wild-type* element-ctype) (find-saetp-by-ctype element-ctype)))) (cond ((eq *wild-type* element-ctype) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 2cf1207..b261b83 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3473,3 +3473,14 @@ (assert (equal (list "hala" "hip") (sort (ctu:find-code-constants fun :type 'string) #'string<))))) + +(with-test (:name :bug-316078) + (let ((fun + (compile nil + `(lambda (x) + (declare (type (and simple-bit-vector (satisfies bar)) x) + (optimize speed)) + (elt x 5))))) + (assert (not (ctu:find-named-callees fun))) + (assert (= 1 (funcall fun #*000001))) + (assert (= 0 (funcall fun #*000010))))) diff --git a/version.lisp-expr b/version.lisp-expr index c3ce326..6b2a19e 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.14" +"1.0.36.15" -- 1.7.10.4