X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=04a93f2a4e44f94232e83c7914c4e3f6b6311b0a;hb=4f0bd9304dfa5010e2c7f17d7cecde0bba6c578e;hp=0e284b08757796f1c4ef681d7ccd46ebf9241595;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 0e284b0..04a93f2 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -358,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))))
@@ -387,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
@@ -590,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)))
@@ -604,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
@@ -915,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.)
 
@@ -1051,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*)))
@@ -1155,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)
@@ -1192,6 +1294,21 @@
   ;; 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*)
      (typecase type1
        (structure-classoid type1)
@@ -1232,6 +1349,15 @@
   ;; 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*
@@ -1260,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))))
 
@@ -1280,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)
@@ -1466,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)
@@ -1590,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
@@ -1738,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)
@@ -1757,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
@@ -1779,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
@@ -1798,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
@@ -1847,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
@@ -2252,14 +2418,8 @@ 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= (array-type-specialized-element-type type1)
                         (array-type-specialized-element-type type2))
@@ -2277,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)
@@ -2305,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))
@@ -2493,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)
@@ -2535,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
@@ -2554,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)
@@ -2741,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)))
@@ -3133,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))
@@ -3241,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 '*))
@@ -3289,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