1.0.14.34: slightly less and slightly faster constraint propagation

 * For negated EQL constaints, don't cons up multiple MEMBER-TYPE
   instances during a single pass through CONSTRAIN-REF-TYPE:
   accumulate a single XSET, and turn it into a MEMBER-TYPE only at
   the end.

 * Don't construct (NOT (MEMBER ...TON-OF-SYMBOLS...)) types at all,
   unless SPEED > COMPILATION speed. Knowing that a variable is not
   in a set of symbols is seldom useful, and compiling large CASE
   statements with symbols as keys can end up spending huge amounts
   of time just building these sets.

 * Adjust FD-STREAMS to use an ECASE in the single place in SBCL where
   without the aforementioned constraint propagation the compiler is
   not able to determine sufficiently constrain the result type.  (Not
   needed since the build has SPEED > COMPILATION-SPEED, but keeps
   things non-brittle.)

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 8d369bd..f6eb756 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -2380,7 +2380,7 @@
 
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)
-      (case direction
+      (ecase direction
         (:input  (values   t nil sb!unix:o_rdonly))
         (:output (values nil   t sb!unix:o_wronly))
         (:io     (values   t   t sb!unix:o_rdwr))

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 7c4d623..0b9b694 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -352,57 +352,80 @@
 ;;; accordingly.
 (defun constrain-ref-type (ref constraints in)
   (declare (type ref ref) (type sset constraints in))
+  ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
+  ;; cons up endless union types when propagating large number of EQL
+  ;; constraints -- eg. from large CASE forms -- instead we just
+  ;; directly accumulate one XSET, and a set of fp zeroes, which we at
+  ;; the end turn into a MEMBER-TYPE.
+  ;;
+  ;; Since massive symbol cases are an especially atrocious pattern
+  ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
+  ;; a more useful type, don't propagate their negation except for NIL
+  ;; unless SPEED > COMPILATION-SPEED.
   (let ((res (single-value-type (node-derived-type ref)))
+        (constrain-symbols (policy ref (> speed compilation-speed)))
+        (not-set (alloc-xset))
+        (not-fpz nil)
         (not-res *empty-type*)
         (leaf (ref-leaf ref)))
-    (do-sset-elements (con constraints)
-      (when (sset-member con in)
-        (let* ((x (constraint-x con))
-               (y (constraint-y con))
-               (not-p (constraint-not-p con))
-               (other (if (eq x leaf) y x))
-               (kind (constraint-kind con)))
-          (case kind
-            (typep
-             (if not-p
-                 (setq not-res (type-union not-res other))
-                 (setq res (type-approx-intersection2 res other))))
-            (eql
-             (unless (lvar-p other)
-               (let ((other-type (leaf-type other)))
-                 (if not-p
-                     (when (and (constant-p other)
-                                (member-type-p other-type))
-                       (setq not-res (type-union not-res other-type)))
-                     (let ((leaf-type (leaf-type leaf)))
-                       (cond
-                         ((or (constant-p other)
-                              (and (leaf-refs other) ; protect from
+    (flet ((note-not (x)
+             (if (fp-zero-p x)
+                 (push x not-fpz)
+                 (when (or constrain-symbols (null x) (not (symbolp x)))
+                   (add-to-xset x not-set)))))
+      (do-sset-elements (con constraints)
+        (when (sset-member con in)
+          (let* ((x (constraint-x con))
+                 (y (constraint-y con))
+                 (not-p (constraint-not-p con))
+                 (other (if (eq x leaf) y x))
+                 (kind (constraint-kind con)))
+            (case kind
+              (typep
+               (if not-p
+                   (if (member-type-p other)
+                       (mapc-member-type-members #'note-not other)
+                       (setq not-res (type-union not-res other)))
+                   (setq res (type-approx-intersection2 res other))))
+              (eql
+               (unless (lvar-p other)
+                 (let ((other-type (leaf-type other)))
+                   (if not-p
+                       (when (and (constant-p other)
+                                  (member-type-p other-type))
+                         (note-not (constant-value other)))
+                       (let ((leaf-type (leaf-type leaf)))
+                         (cond
+                           ((or (constant-p other)
+                                (and (leaf-refs other) ; protect from
                                         ; deleted vars
-                                   (csubtypep other-type leaf-type)
-                                   (not (type= other-type leaf-type))))
-                          (change-ref-leaf ref other)
-                          (when (constant-p other) (return)))
-                         (t
-                          (setq res (type-approx-intersection2
-                                     res other-type)))))))))
-            ((< >)
-             (cond
-               ((and (integer-type-p res) (integer-type-p y))
-                (let ((greater (eq kind '>)))
-                  (let ((greater (if not-p (not greater) greater)))
-                    (setq res
-                          (constrain-integer-type res y greater not-p)))))
-               ((and (float-type-p res) (float-type-p y))
-                (let ((greater (eq kind '>)))
-                  (let ((greater (if not-p (not greater) greater)))
-                    (setq res
-                          (constrain-float-type res y greater not-p)))))))))))
+                                     (csubtypep other-type leaf-type)
+                                     (not (type= other-type leaf-type))))
+                            (change-ref-leaf ref other)
+                            (when (constant-p other) (return)))
+                           (t
+                            (setq res (type-approx-intersection2
+                                       res other-type)))))))))
+              ((< >)
+               (cond
+                 ((and (integer-type-p res) (integer-type-p y))
+                  (let ((greater (eq kind '>)))
+                    (let ((greater (if not-p (not greater) greater)))
+                      (setq res
+                            (constrain-integer-type res y greater not-p)))))
+                 ((and (float-type-p res) (float-type-p y))
+                  (let ((greater (eq kind '>)))
+                    (let ((greater (if not-p (not greater) greater)))
+                      (setq res
+                            (constrain-float-type res y greater not-p))))))))))))
     (cond ((and (if-p (node-dest ref))
-                (csubtypep (specifier-type 'null) not-res))
+                (or (xset-member-p nil not-set)
+                    (csubtypep (specifier-type 'null) not-res)))
            (setf (node-derived-type ref) *wild-type*)
            (change-ref-leaf ref (find-constant t)))
           (t
+           (setf not-res
+                 (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
            (derive-node-type ref
                              (make-single-value-type
                               (or (type-difference res not-res)

diff --git a/version.lisp-expr b/version.lisp-expr
index 86c2240..61c4a77 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".)
-"1.0.14.33"
+"1.0.14.34"