X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=04a93f2a4e44f94232e83c7914c4e3f6b6311b0a;hb=4f0bd9304dfa5010e2c7f17d7cecde0bba6c578e;hp=b2717e413da2e0d642e4f5a63aa8fc278b9240de;hpb=23ce012234d40a8d9ad34644d20496d062713352;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index b2717e4..04a93f2 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 @@ -370,19 +358,83 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (make-fun-type :args args - :returns (coerce-to-values (values-specifier-type result)))) + (let ((result (coerce-to-values (values-specifier-type result)))) + (if (eq args '*) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (multiple-value-bind (required optional rest keyp keywords allowp) + (parse-args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (make-fun-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp + :returns result)))))) (!def-type-translator values (&rest values) - (make-values-type :args values)) + (if (eq values '*) + *wild-type* + (multiple-value-bind (required optional rest keyp keywords allowp llk-p) + (parse-args-types values) + (declare (ignore keywords)) + (cond (keyp + (error "&KEY appeared in a VALUES type specifier ~S." + `(values ,@values))) + (llk-p + (make-values-type :required required + :optional optional + :rest rest + :allowp allowp)) + (t + (make-short-values-type required)))))) ;;;; VALUES types interfaces ;;;; ;;;; We provide a few special operations that can be meaningfully used ;;;; on VALUES types (as well as on any other type). +;;; Return the minimum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-min-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) 0) + ((nil) 0))) + (values-type + (length (values-type-required type))))) + +;;; Return the maximum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-max-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) call-arguments-limit) + ((nil) 0))) + (values-type + (if (values-type-rest type) + call-arguments-limit + (+ (length (values-type-optional type)) + (length (values-type-required type))))))) + +(defun values-type-may-be-single-value-p (type) + (<= (values-type-min-value-count type) + 1 + (values-type-max-value-count type))) + +;;; VALUES type with a single value. (defun type-single-value-p (type) - (and (values-type-p type) + (and (%values-type-p type) (not (values-type-rest type)) (null (values-type-optional type)) (singleton-p (values-type-required type)))) @@ -399,10 +451,11 @@ *empty-type*) ((not (values-type-p type)) type) - (t (or (car (args-type-required type)) - (car (args-type-optional type)) - (args-type-rest type) - (specifier-type 'null))))) + ((car (args-type-required type))) + (t (type-union (specifier-type 'null) + (or (car (args-type-optional type)) + (args-type-rest type) + (specifier-type 'null)))))) ;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function @@ -602,6 +655,19 @@ :rest rest) exactp))) +(defun compare-key-args (type1 type2) + (let ((keys1 (args-type-keywords type1)) + (keys2 (args-type-keywords type2))) + (and (= (length keys1) (length keys2)) + (eq (args-type-allowp type1) + (args-type-allowp type2)) + (loop for key1 in keys1 + for match = (find (key-info-name key1) + keys2 :key #'key-info-name) + always (and match + (type= (key-info-type key1) + (key-info-type match))))))) + (defun type=-args (type1 type2) (macrolet ((compare (comparator field) (let ((reader (symbolicate '#:args-type- field))) @@ -616,7 +682,7 @@ (and/type (and/type (compare type=-list required) (compare type=-list optional)) (if (or (args-type-keyp type1) (args-type-keyp type2)) - (values nil nil) + (values (compare-key-args type1 type2) t) (values t t)))))) ;;; Do a union or intersection operation on types that might be values @@ -804,19 +870,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) @@ -921,6 +993,20 @@ (declare (type ctype type)) (funcall (type-class-negate (type-class-info type)) type)) +(defun-cached (type-singleton-p :hash-function (lambda (type) + (logand (type-hash-value type) + #xff)) + :hash-bits 8 + :values 2 + :default (values nil t) + :init-wrapper !cold-init-forms) + ((type eq)) + (declare (type ctype type)) + (let ((function (type-class-singleton-p (type-class-info type)))) + (if function + (funcall function type) + (values nil nil)))) + ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to ;;; early-type.lisp by WHN ca. 19990201.) @@ -1057,7 +1143,11 @@ ;; required to be a subclass of STANDARD-OBJECT. -- CSR, ;; 2005-09-09 (frob instance *instance-type*) - (frob funcallable-instance *funcallable-instance-type*)) + (frob funcallable-instance *funcallable-instance-type*) + ;; new in sbcl-1.0.3.3: necessary to act as a join point for the + ;; extended sequence hierarchy. (Might be removed later if we use + ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.) + (frob extended-sequence *extended-sequence-type*)) (setf *universal-fun-type* (make-fun-type :wild-args t :returns *wild-type*))) @@ -1148,10 +1238,10 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((or (type-might-contain-other-types-p type1) - ;; some CONS types can conceal danger - (and (cons-type-p type1) - (cons-type-might-be-empty-type type1))) + ;; some CONS types can conceal danger + ((and (cons-type-p type1) (cons-type-might-be-empty-type type1)) + (values nil nil)) + ((type-might-contain-other-types-p type1) ;; those types can be other types in disguise. So we'd ;; better delegate. (invoke-complex-subtypep-arg1-method type1 type2)) @@ -1161,6 +1251,12 @@ ;; member types can be subtypep INSTANCE and ;; FUNCALLABLE-INSTANCE in surprising ways. (invoke-complex-subtypep-arg1-method type1 type2)) + ((and (eq type2 *extended-sequence-type*) (classoid-p type1)) + (let* ((layout (classoid-layout type1)) + (inherits (layout-inherits layout)) + (sequencep (find (classoid-layout (find-classoid 'sequence)) + inherits))) + (values (if sequencep t nil) t))) ((and (eq type2 *instance-type*) (classoid-p type1)) (if (member type1 *non-instance-classoid-types* :key #'find-classoid) (values nil t) @@ -1198,46 +1294,70 @@ ;; Perhaps when bug 85 is fixed it can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond + ((eq type2 *extended-sequence-type*) + (typecase type1 + (structure-classoid *empty-type*) + (classoid + (if (member type1 *non-instance-classoid-types* :key #'find-classoid) + *empty-type* + (if (find (classoid-layout (find-classoid 'sequence)) + (layout-inherits (classoid-layout type1))) + type1 + nil))) + (t + (if (or (type-might-contain-other-types-p type1) + (member-type-p type1)) + nil + *empty-type*)))) ((eq type2 *instance-type*) - (if (classoid-p type1) - (if (and (not (member type1 *non-instance-classoid-types* - :key #'find-classoid)) - (not (eq type1 (find-classoid 'function))) - (not (find (classoid-layout (find-classoid 'function)) - (layout-inherits (classoid-layout type1))))) - (if (or (structure-classoid-p type1) - (and (not (eq type1 (find-classoid 'stream))) - (not (find (classoid-layout (find-classoid 'stream)) - (layout-inherits (classoid-layout type1)))))) - type1 - nil) - *empty-type*) - (if (or (type-might-contain-other-types-p type1) - (member-type-p type1)) - nil - *empty-type*))) + (typecase type1 + (structure-classoid type1) + (classoid + (if (and (not (member type1 *non-instance-classoid-types* + :key #'find-classoid)) + (not (eq type1 (find-classoid 'function))) + (not (find (classoid-layout (find-classoid 'function)) + (layout-inherits (classoid-layout type1))))) + nil + *empty-type*)) + (t + (if (or (type-might-contain-other-types-p type1) + (member-type-p type1)) + nil + *empty-type*)))) ((eq type2 *funcallable-instance-type*) - (if (classoid-p type1) - (if (and (not (member type1 *non-instance-classoid-types* - :key #'find-classoid)) - (find (classoid-layout (find-classoid 'function)) - (layout-inherits (classoid-layout type1)))) - type1 - (if (type= type1 (find-classoid 'function)) - type2 - nil)) - (if (fun-type-p type1) - nil - (if (or (type-might-contain-other-types-p type1) - (member-type-p type1)) - nil - *empty-type*)))) + (typecase type1 + (structure-classoid *empty-type*) + (classoid + (if (member type1 *non-instance-classoid-types* :key #'find-classoid) + *empty-type* + (if (find (classoid-layout (find-classoid 'function)) + (layout-inherits (classoid-layout type1))) + type1 + (if (type= type1 (find-classoid 'function)) + type2 + nil)))) + (fun-type nil) + (t + (if (or (type-might-contain-other-types-p type1) + (member-type-p type1)) + nil + *empty-type*)))) (t (hierarchical-intersection2 type1 type2)))) (!define-type-method (named :complex-union2) (type1 type2) ;; Perhaps when bug 85 is fixed this can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond + ((eq type2 *extended-sequence-type*) + (if (classoid-p type1) + (if (or (member type1 *non-instance-classoid-types* + :key #'find-classoid) + (not (find (classoid-layout (find-classoid 'sequence)) + (layout-inherits (classoid-layout type1))))) + nil + type2) + nil)) ((eq type2 *instance-type*) (if (classoid-p type1) (if (or (member type1 *non-instance-classoid-types* @@ -1266,7 +1386,8 @@ ((eq x *universal-type*) *empty-type*) ((eq x *empty-type*) *universal-type*) ((or (eq x *instance-type*) - (eq x *funcallable-instance-type*)) + (eq x *funcallable-instance-type*) + (eq x *extended-sequence-type*)) (make-negation-type :type x)) (t (bug "NAMED type unexpected: ~S" x)))) @@ -1286,28 +1407,35 @@ (hairy-spec2 (hairy-type-specifier type2))) (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) (values t t)) + ((maybe-reparse-specifier! type1) + (csubtypep type1 type2)) + ((maybe-reparse-specifier! type2) + (csubtypep type1 type2)) (t (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (invoke-complex-subtypep-arg1-method type1 type2)) + (if (maybe-reparse-specifier! type2) + (csubtypep type1 type2) + (let ((specifier (hairy-type-specifier type2))) + (cond ((and (consp specifier) (eql (car specifier) 'satisfies)) + (case (cadr specifier) + ((keywordp) (if (type= type1 (specifier-type 'symbol)) + (values nil t) + (invoke-complex-subtypep-arg1-method type1 type2))) + (t (invoke-complex-subtypep-arg1-method type1 type2)))) + (t + (invoke-complex-subtypep-arg1-method type1 type2)))))) (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) - (declare (ignore type1 type2)) - (values nil nil)) + (if (maybe-reparse-specifier! type1) + (csubtypep type1 type2) + (values nil nil))) (!define-type-method (hairy :complex-=) (type1 type2) - (if (and (unknown-type-p type2) - (let* ((specifier2 (unknown-type-specifier type2)) - (name2 (if (consp specifier2) - (car specifier2) - specifier2))) - (info :type :kind name2))) - (let ((type2 (specifier-type (unknown-type-specifier type2)))) - (if (unknown-type-p type2) - (values nil nil) - (type= type1 type2))) - (values nil nil))) + (if (maybe-reparse-specifier! type2) + (type= type1 type2) + (values nil nil))) (!define-type-method (hairy :simple-intersection2 :complex-intersection2) (type1 type2) @@ -1472,11 +1600,26 @@ (aver (not (eq (type-union not1 not2) *universal-type*))) nil)))) +(defun maybe-complex-array-refinement (type1 type2) + (let* ((ntype (negation-type-type type2)) + (ndims (array-type-dimensions ntype)) + (ncomplexp (array-type-complexp ntype)) + (nseltype (array-type-specialized-element-type ntype)) + (neltype (array-type-element-type ntype))) + (if (and (eql ndims '*) (null ncomplexp) + (eql neltype *wild-type*) (eql nseltype *wild-type*)) + (make-array-type :dimensions (array-type-dimensions type1) + :complexp t + :element-type (array-type-element-type type1) + :specialized-element-type (array-type-specialized-element-type type1))))) + (!define-type-method (negation :complex-intersection2) (type1 type2) (cond ((csubtypep type1 (negation-type-type type2)) *empty-type*) ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) type1) + ((and (array-type-p type1) (array-type-p (negation-type-type type2))) + (maybe-complex-array-refinement type1 type2)) (t nil))) (!define-type-method (negation :simple-union2) (type1 type2) @@ -1596,6 +1739,17 @@ (aver (eq base+bounds 'real)) 'number))))) +(!define-type-method (number :singleton-p) (type) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (if (and low + (eql low high) + (eql (numeric-type-complexp type) :real) + (member (numeric-type-class type) '(integer rational + #-sb-xc-host float))) + (values t (numeric-type-low type)) + (values nil nil)))) + ;;; Return true if X is "less than or equal" to Y, taking open bounds ;;; into consideration. CLOSED is the predicate used to test the bound ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on @@ -1744,10 +1898,12 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; Old comment, probably no longer applicable: -;;; -;;; ### Note: we give up early to keep from dropping lots of -;;; information on the floor by returning overly general types. +;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent +;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128), +;;; the compiler does this occasionally during type-derivation to avoid +;;; creating absurdly complex unions of numeric types. +(defvar *approximate-numeric-unions* nil) + (!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) @@ -1763,7 +1919,8 @@ ((and (eq class1 class2) (eq format1 format2) (eq complexp1 complexp2) - (or (numeric-types-intersect type1 type2) + (or *approximate-numeric-unions* + (numeric-types-intersect type1 type2) (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type @@ -1785,7 +1942,8 @@ (integerp (numeric-type-low type2)) (integerp (numeric-type-high type2)) (= (numeric-type-low type2) (numeric-type-high type2)) - (or (numeric-types-adjacent type1 type2) + (or *approximate-numeric-unions* + (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type :class 'rational @@ -1804,7 +1962,8 @@ (integerp (numeric-type-low type1)) (integerp (numeric-type-high type1)) (= (numeric-type-low type1) (numeric-type-high type1)) - (or (numeric-types-adjacent type1 type2) + (or *approximate-numeric-unions* + (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type :class 'rational @@ -1853,8 +2012,9 @@ (mapcar #'do-complex (union-type-types ctype)))) ((typep ctype 'member-type) (apply #'type-union - (mapcar (lambda (x) (do-complex (ctype-of x))) - (member-type-members ctype)))) + (mapcar-member-type-members + (lambda (x) (do-complex (ctype-of x))) + ctype))) ((and (typep ctype 'intersection-type) ;; FIXME: This is very much a ;; not-quite-worst-effort, but we are required to do @@ -2250,15 +2410,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)) @@ -2267,17 +2418,11 @@ used for a COMPLEX component.~:@>" (values nil t)) ((or (unknown-type-p (array-type-element-type type1)) (unknown-type-p (array-type-element-type type2))) - (multiple-value-bind (equalp certainp) - (type= (array-type-element-type type1) - (array-type-element-type type2)) - ;; By its nature, the call to TYPE= should never return - ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow - ;; up to be. -- CSR, 2002-08-19 - (aver (not (and (not equalp) certainp))) - (values equalp certainp))) + (type= (array-type-element-type type1) + (array-type-element-type type2))) (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) @@ -2292,21 +2437,31 @@ used for a COMPLEX component.~:@>" (complexp (array-type-complexp type))) (cond ((eq dims '*) (if (eq eltype '*) - (if complexp 'array 'simple-array) - (if complexp `(array ,eltype) `(simple-array ,eltype)))) + (ecase complexp + ((t) '(and array (not simple-array))) + ((:maybe) 'array) + ((nil) 'simple-array)) + (ecase complexp + ((t) `(and (array ,eltype) (not simple-array))) + ((:maybe) `(array ,eltype)) + ((nil) `(simple-array ,eltype))))) ((= (length dims) 1) (if complexp - (if (eq (car dims) '*) - (case eltype - (bit 'bit-vector) - ((base-char #!-sb-unicode character) 'base-string) - (* 'vector) - (t `(vector ,eltype))) - (case eltype - (bit `(bit-vector ,(car dims))) - ((base-char #!-sb-unicode character) - `(base-string ,(car dims))) - (t `(vector ,eltype ,(car dims))))) + (let ((answer + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((base-char #!-sb-unicode character) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((base-char #!-sb-unicode character) + `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))))) + (if (eql complexp :maybe) + answer + `(and ,answer (not simple-array)))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) @@ -2320,9 +2475,10 @@ used for a COMPLEX component.~:@>" ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t - (if complexp - `(array ,eltype ,dims) - `(simple-array ,eltype ,dims)))))) + (ecase complexp + ((t) `(and (array ,eltype ,dims) (not simple-array))) + ((:maybe) `(array ,eltype ,dims)) + ((nil) `(simple-array ,eltype ,dims))))))) (!define-type-method (array :simple-subtypep) (type1 type2) (let ((dims1 (array-type-dimensions type1)) @@ -2363,15 +2519,12 @@ 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? (!define-superclasses array - ((base-string base-string) - (vector vector) - (array)) + ((vector vector) (array)) !cold-init-forms) (defun array-types-intersect (type1 type2) @@ -2414,13 +2567,43 @@ 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 (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)) + (when (or wild1 wild2 + (and (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 (if wild2 stype2 stype1))))) + (!define-type-method (array :simple-intersection2) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) @@ -2429,19 +2612,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, @@ -2473,39 +2664,28 @@ used for a COMPLEX component.~:@>" (!define-type-class member) (!define-type-method (member :negate) (type) - (let ((members (member-type-members type))) - (if (some #'floatp members) - (let (floats) - (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) - (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) - (when (member (car pair) members) - (aver (not (member (cdr pair) members))) - (push (cdr pair) floats) - (setf members (remove (car pair) members))) - (when (member (cdr pair) members) - (aver (not (member (car pair) members))) - (push (car pair) floats) - (setf members (remove (cdr pair) members)))) - (apply #'type-intersection - (if (null members) - *universal-type* + (let ((xset (member-type-xset type)) + (fp-zeroes (member-type-fp-zeroes type))) + (if fp-zeroes + ;; Hairy case, which needs to do a bit of float type + ;; canonicalization. + (apply #'type-intersection + (if (xset-empty-p xset) + *universal-type* + (make-negation-type + :type (make-member-type :xset xset))) + (mapcar + (lambda (x) + (let* ((opposite (neg-fp-zero x)) + (type (ctype-of opposite))) + (type-union (make-negation-type - :type (make-member-type :members members))) - (mapcar - (lambda (x) - (let ((type (ctype-of x))) - (type-union - (make-negation-type - :type (modified-numeric-type type - :low nil :high nil)) - (modified-numeric-type type - :low nil :high (list x)) - (make-member-type :members (list x)) - (modified-numeric-type type - :low (list x) :high nil)))) - floats))) + :type (modified-numeric-type type :low nil :high nil)) + (modified-numeric-type type :low nil :high (list opposite)) + (make-member-type :members (list opposite)) + (modified-numeric-type type :low (list opposite) :high nil)))) + fp-zeroes)) + ;; Easy case (make-negation-type :type type)))) (!define-type-method (member :unparse) (type) @@ -2515,14 +2695,29 @@ used for a COMPLEX component.~:@>" ((type= type (specifier-type 'standard-char)) 'standard-char) (t `(member ,@members))))) +(!define-type-method (member :singleton-p) (type) + (if (eql 1 (member-type-size type)) + (values t (first (member-type-members type))) + (values nil nil))) + (!define-type-method (member :simple-subtypep) (type1 type2) - (values (subsetp (member-type-members type1) (member-type-members type2)) - t)) + (values (and (xset-subset-p (member-type-xset type1) + (member-type-xset type2)) + (subsetp (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2))) + t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (every/type (swapped-args-fun #'ctypep) - type2 - (member-type-members type1))) + (block punt + (mapc-member-type-members + (lambda (elt) + (multiple-value-bind (ok surep) (ctypep elt type2) + (unless surep + (return-from punt (values nil nil))) + (unless ok + (return-from punt (values nil t))))) + type1) + (values t t))) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a @@ -2534,46 +2729,48 @@ used for a COMPLEX component.~:@>" (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (cond ((subsetp mem1 mem2) type1) - ((subsetp mem2 mem1) type2) - (t - (let ((res (intersection mem1 mem2))) - (if res - (make-member-type :members res) - *empty-type*)))))) + (make-member-type :xset (xset-intersection (member-type-xset type1) + (member-type-xset type2)) + :fp-zeroes (intersection (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) (!define-type-method (member :complex-intersection2) (type1 type2) (block punt - (collect ((members)) - (let ((mem2 (member-type-members type2))) - (dolist (member mem2) - (multiple-value-bind (val win) (ctypep member type1) - (unless win - (return-from punt nil)) - (when val (members member)))) - (cond ((subsetp mem2 (members)) type2) - ((null (members)) *empty-type*) - (t - (make-member-type :members (members)))))))) + (let ((xset (alloc-xset)) + (fp-zeroes nil)) + (mapc-member-type-members + (lambda (member) + (multiple-value-bind (ok sure) (ctypep member type1) + (unless sure + (return-from punt nil)) + (when ok + (if (fp-zero-p member) + (pushnew member fp-zeroes) + (add-to-xset member xset))))) + type2) + (if (and (xset-empty-p xset) (not fp-zeroes)) + *empty-type* + (make-member-type :xset xset :fp-zeroes fp-zeroes))))) ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the ;;; union type method. (!define-type-method (member :simple-union2) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (cond ((subsetp mem1 mem2) type2) - ((subsetp mem2 mem1) type1) - (t - (make-member-type :members (union mem1 mem2)))))) + (make-member-type :xset (xset-union (member-type-xset type1) + (member-type-xset type2)) + :fp-zeroes (union (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) (!define-type-method (member :simple-=) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (values (and (subsetp mem1 mem2) - (subsetp mem2 mem1)) + (let ((xset1 (member-type-xset type1)) + (xset2 (member-type-xset type2)) + (l1 (member-type-fp-zeroes type1)) + (l2 (member-type-fp-zeroes type2))) + (values (and (eql (xset-count xset1) (xset-count xset2)) + (xset-subset-p xset1 xset2) + (xset-subset-p xset2 xset1) + (subsetp l1 l2) + (subsetp l2 l1)) t))) (!define-type-method (member :complex-=) (type1 type2) @@ -2636,7 +2833,7 @@ used for a COMPLEX component.~:@>" ;;; mechanically unparsed. (!define-type-method (intersection :unparse) (type) (declare (type ctype type)) - (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) + (or (find type '(ratio keyword compiled-function) :key #'specifier-type :test #'type=) `(and ,@(mapcar #'type-specifier (intersection-type-types type))))) ;;; shared machinery for type equality: true if every type in the set @@ -2721,11 +2918,12 @@ used for a COMPLEX component.~:@>" :high (if (null (numeric-type-high type1)) nil (list (1+ (numeric-type-high type1))))))) - (type-union type1 - (apply #'type-intersection - (remove (specifier-type '(not integer)) - (intersection-type-types type2) - :test #'type=)))) + (let* ((intersected (intersection-type-types type2)) + (remaining (remove (specifier-type '(not integer)) + intersected + :test #'type=))) + (and (not (equal intersected remaining)) + (type-union type1 (apply #'type-intersection remaining))))) (t (let ((accumulator *universal-type*)) (do ((t2s (intersection-type-types type2) (cdr t2s))) @@ -2828,40 +3026,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 @@ -2970,8 +3168,23 @@ used for a COMPLEX component.~:@>" (!define-type-method (cons :simple-=) (type1 type2) (declare (type cons-type type1 type2)) - (and (type= (cons-type-car-type type1) (cons-type-car-type type2)) - (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)))) + (multiple-value-bind (car-match car-win) + (type= (cons-type-car-type type1) (cons-type-car-type type2)) + (multiple-value-bind (cdr-match cdr-win) + (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)) + (cond ((and car-match cdr-match) + (aver (and car-win cdr-win)) + (values t t)) + (t + (values nil + ;; FIXME: Ideally we would like to detect and handle + ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T + ;; but just returning a secondary true on (and car-win cdr-win) + ;; unfortunately breaks other things. --NS 2006-08-16 + (and (or (and (not car-match) car-win) + (and (not cdr-match) cdr-win)) + (not (and (cons-type-might-be-empty-type type1) + (cons-type-might-be-empty-type type2)))))))))) (!define-type-method (cons :simple-subtypep) (type1 type2) (declare (type cons-type type1 type2)) @@ -3054,6 +3267,8 @@ used for a COMPLEX component.~:@>" (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) cdr-int2))))) + +(!define-superclasses cons ((cons)) !cold-init-forms) ;;;; CHARACTER-SET types @@ -3066,29 +3281,29 @@ used for a COMPLEX component.~:@>" (!define-type-method (character-set :negate) (type) (let ((pairs (character-set-type-pairs type))) (if (and (= (length pairs) 1) - (= (caar pairs) 0) - (= (cdar pairs) (1- sb!xc:char-code-limit))) - (make-negation-type :type type) - (let ((not-character - (make-negation-type - :type (make-character-set-type - :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) - (type-union - not-character - (make-character-set-type - :pairs (let (not-pairs) - (when (> (caar pairs) 0) - (push (cons 0 (1- (caar pairs))) not-pairs)) - (do* ((tail pairs (cdr tail)) - (high1 (cdar tail)) - (low2 (caadr tail))) - ((null (cdr tail)) - (when (< (cdar tail) (1- sb!xc:char-code-limit)) - (push (cons (1+ (cdar tail)) - (1- sb!xc:char-code-limit)) - not-pairs)) - (nreverse not-pairs)) - (push (cons (1+ high1) (1- low2)) not-pairs))))))))) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (make-negation-type :type type) + (let ((not-character + (make-negation-type + :type (make-character-set-type + :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) + (type-union + not-character + (make-character-set-type + :pairs (let (not-pairs) + (when (> (caar pairs) 0) + (push (cons 0 (1- (caar pairs))) not-pairs)) + (do* ((tail pairs (cdr tail)) + (high1 (cdar tail) (cdar tail)) + (low2 (caadr tail) (caadr tail))) + ((null (cdr tail)) + (when (< (cdar tail) (1- sb!xc:char-code-limit)) + (push (cons (1+ (cdar tail)) + (1- sb!xc:char-code-limit)) + not-pairs)) + (nreverse not-pairs)) + (push (cons (1+ high1) (1- low2)) not-pairs))))))))) (!define-type-method (character-set :unparse) (type) (cond @@ -3096,10 +3311,28 @@ used for a COMPLEX component.~:@>" ((type= type (specifier-type 'base-char)) 'base-char) ((type= type (specifier-type 'extended-char)) 'extended-char) ((type= type (specifier-type 'standard-char)) 'standard-char) - (t (let ((pairs (character-set-type-pairs type))) - `(member ,@(loop for (low . high) in pairs + (t + ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there + ;; are at most as many characters than there are character code ranges. + (let* ((pairs (character-set-type-pairs type)) + (count (length pairs)) + (chars (loop named outer + for (low . high) in pairs nconc (loop for code from low upto high - collect (sb!xc:code-char code)))))))) + collect (sb!xc:code-char code) + when (minusp (decf count)) + do (return-from outer t))))) + (if (eq chars t) + `(character-set ,pairs) + `(member ,@chars)))))) + +(!define-type-method (character-set :singleton-p) (type) + (let* ((pairs (character-set-type-pairs type)) + (pair (first pairs))) + (if (and (typep pairs '(cons t null)) + (eql (car pair) (cdr pair))) + (values t (code-char (car pair))) + (values nil nil)))) (!define-type-method (character-set :simple-=) (type1 type2) (let ((pairs1 (character-set-type-pairs type1)) @@ -3204,35 +3437,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) - (collect ((members)) - (dolist (mem (member-type-members x-type)) - (multiple-value-bind (val win) (ctypep mem y) - (unless win (return-from type-difference nil)) - (unless val - (members mem)))) - (when (members) - (res (make-member-type :members (members))))) - (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 - (let ((members (member-type-members y-mem))) - (dolist (x-type x-types) - (unless (member-type-p x-type) - (dolist (member members) - (multiple-value-bind (val win) (ctypep member x-type) - (when (or (not win) val) - (return-from type-difference nil))))))))) - (apply #'type-union (res))))) + (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) + (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 '*)) @@ -3252,6 +3495,60 @@ used for a COMPLEX component.~:@>" *wild-type* (specifier-type element-type))))) +;;;; SIMD-PACK types +#!+sb-simd-pack +(progn + (!define-type-class simd-pack) + + (!def-type-translator simd-pack (&optional (element-type-spec '*)) + (if (eql element-type-spec '*) + (%make-simd-pack-type *simd-pack-element-types*) + (make-simd-pack-type (single-value-specifier-type element-type-spec)))) + + (!define-type-method (simd-pack :negate) (type) + (let ((remaining (set-difference *simd-pack-element-types* + (simd-pack-type-element-type type))) + (not-simd-pack (make-negation-type :type (specifier-type 'simd-pack)))) + (if remaining + (type-union not-simd-pack (%make-simd-pack-type remaining)) + not-simd-pack))) + + (!define-type-method (simd-pack :unparse) (type) + (let ((eltypes (simd-pack-type-element-type type))) + (cond ((equal eltypes *simd-pack-element-types*) + 'simd-pack) + ((= 1 (length eltypes)) + `(simd-pack ,(first eltypes))) + (t + `(or ,@(mapcar (lambda (eltype) + `(simd-pack ,eltype)) + eltypes)))))) + + (!define-type-method (simd-pack :simple-=) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (null (set-exclusive-or (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + + (!define-type-method (simd-pack :simple-subtypep) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (subsetp (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2))) + + (!define-type-method (simd-pack :simple-union2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (%make-simd-pack-type (union (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + + (!define-type-method (simd-pack :simple-intersection2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (let ((intersection (intersection (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + (if intersection + (%make-simd-pack-type intersection) + *empty-type*))) + + (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms)) + ;;;; utilities shared between cross-compiler and target system ;;; Does the type derived from compilation of an actual function