0.8.6.35:

	At the request of the type system's most heavy user...
	... refactor NEGATION-TYPEs

	... make NEGATE an operation in TYPE-CLASS
	... define type methods for :NEGATE, replacing one god-awful
		NOT type translator
	... define a (cached) TYPE-NEGATION function
	... replace too many uses of
		(specifier-type `(not ,(type-specifier foo)))
		with (type-negation foo)

	We pass as many tests as we used to (both here and in PFD's suite)
	and we now go faster than we did before 0.8.6 on PFD's random
	tester.  Sounds good to me.

	(This was initially part I of a two part refactor.  This stage
	turns out to be enough for now; if it hadn't been, it should be
	possible to achieve even greater speed by changing the representation
	of CONS types to include not just CAR and CDR types but also
	their negations; then operations on CONS types such as UNION and NEGATE
	would be much much faster, at a slight cost in initialization).

diff --git a/NEWS b/NEWS
index c10435b..0362e29 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2207,6 +2207,9 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6:
     now works correctly.  (reported by Paul Dietz)
   * optimization: performance of string output streams is now less
     poor for multiple small sequence writes.
+  * optimization: performance of CSUBTYPEP in the presence of complex
+    expressions involving CONS and NOT many times has been improved.
+    (reported by Paul Dietz)
   * ASDF-INSTALL bug fix: now parses *PROXY* properly.  (thanks to
     Sean Ross)
   * SB-SIMPLE-STREAMS enhancement: simple-streams can now be used as

diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp
index 86b7121..5aed5cd 100644 (file)
--- a/src/code/alien-type.lisp
+++ b/src/code/alien-type.lisp
@@ -26,6 +26,9 @@
 
 (!define-type-class alien)
 
+(!define-type-method (alien :negate) (type)
+  (make-negation-type :type type))
+
 (!define-type-method (alien :unparse) (type)
   `(alien ,(unparse-alien-type (alien-type-type-alien-type type))))
 

diff --git a/src/code/class.lisp b/src/code/class.lisp
index fd432d4..392ccfa 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -871,6 +871,9 @@
       (values nil nil)
       (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
 
+(!define-type-method (classoid :negate) (type)
+  (make-negation-type :type type))
+
 (!define-type-method (classoid :unparse) (type)
   (classoid-proper-name type))
 \f

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index c1a29d9..799d6e9 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -154,6 +154,9 @@
   (declare (ignore type1))
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
+(!define-type-method (values :negate) (type)
+  (error "NOT VALUES too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (values :unparse) (type)
   (cons 'values
         (let ((unparsed (unparse-args-types type)))
@@ -192,6 +195,9 @@
 (defvar *unparse-fun-type-simplify*)
 (!cold-init-forms (setq *unparse-fun-type-simplify* nil))
 
+(!define-type-method (function :negate) (type)
+  (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (function :unparse) (type)
   (if *unparse-fun-type-simplify*
       'function
@@ -318,6 +324,9 @@
 
 (!define-type-class constant :inherits values)
 
+(!define-type-method (constant :negate) (type)
+  (error "NOT CONSTANT too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (constant :unparse) (type)
   `(constant-arg ,(type-specifier (constant-type-type type))))
 
@@ -898,6 +907,17 @@
   (declare (type ctype type))
   (funcall (type-class-unparse (type-class-info type)) type))
 
+(defun-cached (type-negation :hash-function (lambda (type)
+                                             (logand (type-hash-value type)
+                                                     #xff))
+                            :hash-bits 8
+                            :values 1
+                            :default nil
+                            :init-wrapper !cold-init-forms)
+              ((type eq))
+  (declare (type ctype type))
+  (funcall (type-class-negate (type-class-info type)) type))
+
 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 ;;; early-type.lisp by WHN ca. 19990201.)
 
@@ -1119,11 +1139,21 @@
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (hierarchical-union2 type1 type2))
 
+(!define-type-method (named :negate) (x)
+  (aver (not (eq x *wild-type*)))
+  (cond
+    ((eq x *universal-type*) *empty-type*)
+    ((eq x *empty-type*) *universal-type*)
+    (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+
 (!define-type-method (named :unparse) (x)
   (named-type-name x))
 \f
 ;;;; hairy and unknown types
 
+(!define-type-method (hairy :negate) (x)
+  (make-negation-type :type x))
+
 (!define-type-method (hairy :unparse) (x)
   (hairy-type-specifier x))
 
@@ -1189,6 +1219,9 @@
 \f
 ;;;; negation types
 
+(!define-type-method (negation :negate) (x)
+  (negation-type-type x))
+
 (!define-type-method (negation :unparse) (x)
   `(not ,(type-specifier (negation-type-type x))))
 
@@ -1341,123 +1374,7 @@
   (type= (negation-type-type type1) (negation-type-type type2)))
 
 (!def-type-translator not (typespec)
-  (let* ((not-type (specifier-type typespec))
-        (spec (type-specifier not-type)))
-    (cond
-      ;; canonicalize (NOT (NOT FOO))
-      ((and (listp spec) (eq (car spec) 'not))
-       (specifier-type (cadr spec)))
-      ;; canonicalize (NOT NIL) and (NOT T)
-      ((eq not-type *empty-type*) *universal-type*)
-      ((eq not-type *universal-type*) *empty-type*)
-      ((and (numeric-type-p not-type)
-           (null (numeric-type-low not-type))
-           (null (numeric-type-high not-type)))
-       (make-negation-type :type not-type))
-      ((numeric-type-p not-type)
-       (type-union
-       (make-negation-type
-        :type (modified-numeric-type not-type :low nil :high nil))
-       (cond
-         ((null (numeric-type-low not-type))
-          (modified-numeric-type
-           not-type
-           :low (let ((h (numeric-type-high not-type)))
-                  (if (consp h) (car h) (list h)))
-           :high nil))
-         ((null (numeric-type-high not-type))
-          (modified-numeric-type
-           not-type
-           :low nil
-           :high (let ((l (numeric-type-low not-type)))
-                   (if (consp l) (car l) (list l)))))
-         (t (type-union
-             (modified-numeric-type
-              not-type
-              :low nil
-              :high (let ((l (numeric-type-low not-type)))
-                      (if (consp l) (car l) (list l))))
-             (modified-numeric-type
-              not-type
-              :low (let ((h (numeric-type-high not-type)))
-                     (if (consp h) (car h) (list h)))
-              :high nil))))))
-      ((intersection-type-p not-type)
-       (apply #'type-union
-             (mapcar #'(lambda (x)
-                         (specifier-type `(not ,(type-specifier x))))
-                     (intersection-type-types not-type))))
-      ((union-type-p not-type)
-       (apply #'type-intersection
-             (mapcar #'(lambda (x)
-                         (specifier-type `(not ,(type-specifier x))))
-                     (union-type-types not-type))))
-      ((member-type-p not-type)
-       (let ((members (member-type-members not-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*
-                         (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)))
-            (make-negation-type :type not-type))))
-      ((and (cons-type-p not-type)
-           (eq (cons-type-car-type not-type) *universal-type*)
-           (eq (cons-type-cdr-type not-type) *universal-type*))
-       (make-negation-type :type not-type))
-      ((cons-type-p not-type)
-       (type-union
-       (make-negation-type :type (specifier-type 'cons))
-       (cond
-         ((and (not (eq (cons-type-car-type not-type) *universal-type*))
-               (not (eq (cons-type-cdr-type not-type) *universal-type*)))
-          (type-union
-           (make-cons-type
-            (specifier-type `(not ,(type-specifier
-                                    (cons-type-car-type not-type))))
-            *universal-type*)
-           (make-cons-type
-            *universal-type*
-            (specifier-type `(not ,(type-specifier
-                                    (cons-type-cdr-type not-type)))))))
-         ((not (eq (cons-type-car-type not-type) *universal-type*))
-          (make-cons-type
-           (specifier-type `(not ,(type-specifier
-                                   (cons-type-car-type not-type))))
-           *universal-type*))
-         ((not (eq (cons-type-cdr-type not-type) *universal-type*))
-          (make-cons-type
-           *universal-type*
-           (specifier-type `(not ,(type-specifier
-                                   (cons-type-cdr-type not-type))))))
-         (t (bug "Weird CONS type ~S" not-type)))))
-      (t (make-negation-type :type not-type)))))
+  (type-negation (specifier-type typespec)))
 \f
 ;;;; numeric types
 
@@ -1476,6 +1393,37 @@
        (equalp (numeric-type-high type1) (numeric-type-high type2)))
    t))
 
+(!define-type-method (number :negate) (type)
+  (if (and (null (numeric-type-low type)) (null (numeric-type-high type)))
+      (make-negation-type :type type)
+      (type-union
+       (make-negation-type
+       :type (modified-numeric-type type :low nil :high nil))
+       (cond
+        ((null (numeric-type-low type))
+         (modified-numeric-type
+          type
+          :low (let ((h (numeric-type-high type)))
+                 (if (consp h) (car h) (list h)))
+          :high nil))
+        ((null (numeric-type-high type))
+         (modified-numeric-type
+          type
+          :low nil
+          :high (let ((l (numeric-type-low type)))
+                  (if (consp l) (car l) (list l)))))
+        (t (type-union
+            (modified-numeric-type
+             type
+             :low nil
+             :high (let ((l (numeric-type-low type)))
+                     (if (consp l) (car l) (list l))))
+            (modified-numeric-type
+             type
+             :low (let ((h (numeric-type-high type)))
+                    (if (consp h) (car h) (list h)))
+             :high nil)))))))
+
 (!define-type-method (number :unparse) (type)
   (let* ((complexp (numeric-type-complexp type))
         (low (numeric-type-low type))
@@ -2157,6 +2105,12 @@
                          (specialized-element-type-maybe type2)))
              t)))
 
+(!define-type-method (array :negate) (type)
+  ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
+  ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
+  ;; NIL) (ARRAY CHAR) ...) equivalent?  -- CSR, 2003-12-10
+  (make-negation-type :type type))
+
 (!define-type-method (array :unparse) (type)
   (let ((dims (array-type-dimensions type))
        (eltype (type-specifier (array-type-element-type type)))
@@ -2338,6 +2292,42 @@
 
 (!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*
+                    (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)))
+       (make-negation-type :type type))))
+
 (!define-type-method (member :unparse) (type)
   (let ((members (member-type-members type)))
     (cond
@@ -2452,6 +2442,10 @@
 
 (!define-type-class intersection)
 
+(!define-type-method (intersection :negate) (type)
+  (apply #'type-union
+        (mapcar #'type-negation (intersection-type-types type))))
+
 ;;; A few intersection types have special names. The others just get
 ;;; mechanically unparsed.
 (!define-type-method (intersection :unparse) (type)
@@ -2572,13 +2566,17 @@
 
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
-        (mapcar #'specifier-type
-                type-specifiers)))
+        (mapcar #'specifier-type type-specifiers)))
 \f
 ;;;; union types
 
 (!define-type-class union)
 
+(!define-type-method (union :negate) (type)
+  (declare (type ctype type))
+  (apply #'type-intersection
+        (mapcar #'type-negation (union-type-types type))))
+
 ;;; The LIST, FLOAT and REAL types have special names.  Other union
 ;;; types just get mechanically unparsed.
 (!define-type-method (union :unparse) (type)
@@ -2747,7 +2745,33 @@
   (let ((car-type (single-value-specifier-type car-type-spec))
        (cdr-type (single-value-specifier-type cdr-type-spec)))
     (make-cons-type car-type cdr-type)))
- 
+
+(!define-type-method (cons :negate) (type)
+  (if (and (eq (cons-type-car-type type) *universal-type*)
+          (eq (cons-type-cdr-type type) *universal-type*))
+      (make-negation-type :type type)
+      (type-union
+       (make-negation-type :type (specifier-type 'cons))
+       (cond
+        ((and (not (eq (cons-type-car-type type) *universal-type*))
+              (not (eq (cons-type-cdr-type type) *universal-type*)))
+         (type-union
+          (make-cons-type
+           (type-negation (cons-type-car-type type))
+           *universal-type*)
+          (make-cons-type
+           *universal-type*
+           (type-negation (cons-type-cdr-type type)))))
+        ((not (eq (cons-type-car-type type) *universal-type*))
+         (make-cons-type
+          (type-negation (cons-type-car-type type))
+          *universal-type*))
+        ((not (eq (cons-type-cdr-type type) *universal-type*))
+         (make-cons-type
+          *universal-type*
+          (type-negation (cons-type-cdr-type type))))
+        (t (bug "Weird CONS type ~S" type))))))
+
 (!define-type-method (cons :unparse) (type)
   (let ((car-eltype (type-specifier (cons-type-car-type type)))
        (cdr-eltype (type-specifier (cons-type-cdr-type type))))
@@ -2790,8 +2814,7 @@
                    (type-intersection ,car2
                     ,(if not1p
                          not1
-                         `(specifier-type
-                           `(not ,(type-specifier ,car1)))))
+                         `(type-negation ,car1)))
                    ,cdr2))))
       (cond ((type= car-type1 car-type2)
             (make-cons-type car-type1
@@ -2805,13 +2828,11 @@
             (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
            ;; more general case of the above, but harder to compute
            ((progn
-              (setf car-not1 (specifier-type
-                              `(not ,(type-specifier car-type1))))
+              (setf car-not1 (type-negation car-type1))
               (not (csubtypep car-type2 car-not1)))
             (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
            ((progn
-              (setf car-not2 (specifier-type
-                              `(not ,(type-specifier car-type2))))
+              (setf car-not2 (type-negation car-type2))
               (not (csubtypep car-type1 car-not2)))
             (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
            ;; Don't put these in -- consider the effect of taking the

diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index d493d41..fcd4706 100644 (file)
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -85,6 +85,8 @@
   (complex-intersection2 nil :type (or function null))
   (simple-= #'must-supply-this :type function)
   (complex-= nil :type (or function null))
+  ;; monadic functions
+  (negate #'must-supply-this :type function)
   ;; a function which returns a Common Lisp type specifier
   ;; representing this type
   (unparse #'must-supply-this :type function)
@@ -120,6 +122,7 @@
       (:complex-intersection2 . type-class-complex-intersection2)
       (:simple-= . type-class-simple-=)
       (:complex-= . type-class-complex-=)
+      (:negate . type-class-negate)
       (:unparse . type-class-unparse))))
 
 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))

diff --git a/version.lisp-expr b/version.lisp-expr
index 3ae3ac7..1b6b972 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.6.34"
+"0.8.6.35"