Less constraint propagation when COMPILATION-SPEED > SPEED

 Propagate much fewer EQL constraints, and propagate fewer constraints
 to EQL variables.  Can results in a few orders of magnitude speed ups
 in compilation times.

diff --git a/NEWS b/NEWS
index 48cc671..f73e8fb 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,8 @@ changes relative to sbcl-1.0.49:
     and SB-EXT:*SYSINIT-PATHNAME-FUNCTION*.
   * enhancement: SB-EXT:MAKE-THREAD accepts an argument list designator for
     the thunk, as a keyword argument, :arguments.
+  * enhancement: constraint propagation is simplified (and sped up) when
+    COMPILATION-SPEED > SPEED.
   * optimization: extracting bits of a single-float on x86-64 has been
     optimized. (lp#555201)
   * meta-optimization: improved compilation speed, especially for large

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index d14a982..79f19c1 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -563,25 +563,49 @@
 ;;; Add the indicated test constraint to BLOCK. We don't add the
 ;;; constraint if the block has multiple predecessors, since it only
 ;;; holds on this particular path.
-(defun add-test-constraint (fun x y not-p constraints target)
-  (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
-         (add-eql-var-var-constraint x y constraints target))
-        (t
-         (conset-add-constraint-to-eql constraints fun x y not-p target)))
+(defun precise-add-test-constraint (fun x y not-p constraints target)
+  (if (and (eq 'eql fun) (lambda-var-p y) (not not-p))
+      (add-eql-var-var-constraint x y constraints target)
+      (conset-add-constraint-to-eql constraints fun x y not-p target))
   (values))
 
+(defun add-test-constraint (quick-p fun x y not-p constraints target)
+  (cond (quick-p
+         (conset-add-constraint target fun x y not-p))
+        (t
+         (precise-add-test-constraint fun x y not-p constraints target))))
 ;;; Add complementary constraints to the consequent and alternative
 ;;; blocks of IF. We do nothing if X is NIL.
-(defun add-complement-constraints (fun x y not-p constraints
-                                   consequent-constraints
-                                   alternative-constraints)
+(declaim (inline precise-add-test-constraint quick-add-complement-constraints))
+(defun precise-add-complement-constraints (fun x y not-p constraints
+                                           consequent-constraints
+                                           alternative-constraints)
   (when x
-    (add-test-constraint fun x y not-p constraints
-                         consequent-constraints)
-    (add-test-constraint fun x y (not not-p) constraints
+    (precise-add-test-constraint fun x y not-p constraints
+                                consequent-constraints)
+    (precise-add-test-constraint fun x y (not not-p) constraints
                          alternative-constraints))
   (values))
 
+(defun quick-add-complement-constraints (fun x y not-p
+                                         consequent-constraints
+                                         alternative-constraints)
+  (when x
+    (conset-add-constraint consequent-constraints fun x y not-p)
+    (conset-add-constraint alternative-constraints fun x y (not not-p)))
+  (values))
+
+(defun add-complement-constraints (quick-p fun x y not-p constraints
+                                   consequent-constraints
+                                   alternative-constraints)
+  (if quick-p
+      (quick-add-complement-constraints fun x y not-p
+                                        consequent-constraints
+                                        alternative-constraints)
+      (precise-add-complement-constraints fun x y not-p constraints
+                                          consequent-constraints
+                                          alternative-constraints)))
+
 ;;; Add test constraints to the consequent and alternative blocks of
 ;;; the test represented by USE.
 (defun add-test-constraints (use if constraints)
@@ -592,9 +616,11 @@
   ;; need to avoid barfing on this case.
   (unless (eq (if-consequent if) (if-alternative if))
     (let ((consequent-constraints (make-conset))
-          (alternative-constraints (make-conset)))
+          (alternative-constraints (make-conset))
+          (quick-p (policy if (> compilation-speed speed))))
       (macrolet ((add (fun x y not-p)
-                   `(add-complement-constraints ,fun ,x ,y ,not-p
+                   `(add-complement-constraints quick-p
+                                                ,fun ,x ,y ,not-p
                                                 constraints
                                                 consequent-constraints
                                                 alternative-constraints)))
@@ -634,7 +660,8 @@
                     ;; unnatural asymmetry of the tests.
                     (cond ((not var1)
                            (when var2
-                             (add-test-constraint 'typep var2 (lvar-type arg1)
+                             (add-test-constraint quick-p
+                                                  'typep var2 (lvar-type arg1)
                                                   nil constraints
                                                   consequent-constraints)))
                           (var2
@@ -647,7 +674,8 @@
                                       (find-constant (lvar-value arg2))))
                                 nil))
                           (t
-                           (add-test-constraint 'typep var1 (lvar-type arg2)
+                           (add-test-constraint quick-p
+                                                'typep var1 (lvar-type arg2)
                                                 nil constraints
                                                 consequent-constraints)))))
                  ((< >)
@@ -917,7 +945,8 @@
          (let ((type (single-value-type (node-derived-type node))))
            (unless (eq type *universal-type*)
              (conset-add-constraint gen 'typep var type nil)))
-         (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
+         (unless (policy node (> compilation-speed speed))
+           (maybe-add-eql-var-var-constraint var (set-value node) gen))))))
   gen)
 
 (defun constraint-propagate-if (block gen)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 19f6c96..633efef 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2231,15 +2231,16 @@
                (logand most-positive-fixnum (* x most-positive-fixnum))))
 
 ;;; bug 256.b
-(assert (let (warned-p)
+(with-test (:name :propagate-type-through-error-and-binding)
+  (assert (let (warned-p)
             (handler-bind ((warning (lambda (w) (setf warned-p t))))
               (compile nil
-                         '(lambda (x)
-                           (list (let ((y (the real x)))
-                                   (unless (floatp y) (error ""))
-                                   y)
-                                 (integer-length x)))))
-            warned-p))
+                       '(lambda (x)
+                         (list (let ((y (the real x)))
+                                 (unless (floatp y) (error ""))
+                                 y)
+                          (integer-length x)))))
+            warned-p)))
 
 ;; Dead / in safe code
 (with-test (:name :safe-dead-/)