X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=695b27a494f4d82a82e5c6387926582d00f513ac;hb=22de9286aa239843ab7bc2cb772009fba6bcd080;hp=007950a4e5f06f8f070d29a2e2464428b013fe5e;hpb=b2f0204834bd0c314d44942dd92475c15ffa8c89;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 007950a..695b27a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -369,6 +369,36 @@ ;;;; 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))) + (defun type-single-value-p (type) (and (values-type-p type) (not (values-type-rest type)) @@ -1319,7 +1349,15 @@ (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (invoke-complex-subtypep-arg1-method 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)) @@ -1501,11 +1539,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) @@ -1882,8 +1935,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 @@ -2312,21 +2366,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) @@ -2340,9 +2404,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)) @@ -2528,39 +2593,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) @@ -2571,13 +2625,23 @@ used for a COMPLEX component.~:@>" (t `(member ,@members))))) (!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 @@ -2589,46 +2653,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) @@ -3281,14 +3347,20 @@ used for a COMPLEX component.~:@>" (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))))) + (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)) @@ -3297,13 +3369,14 @@ used for a COMPLEX component.~:@>" (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))))))))) + (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 '*)