X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=91ca4c68bc650e4ffc8d5929f0b5398b9e0502ff;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=5aaf16ae5fd6f55067dcd436cb589507bab0e24e;hpb=70b392926636cc0d870a6e4e7dd8b574f998633d;p=sbcl.git 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