More constraint propagation in the presence of assignment

 When SPEED = 3 > COMPILATION-SPEED, propagate type in code
 like (cond ((eql (the fixnum x) y) (setf x 42) y) ...).

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 79f19c1..88a8252 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -941,6 +941,12 @@
        (binding* ((var (set-var node))
                   (nil (lambda-var-p var) :exit-if-null)
                   (nil (lambda-var-constraints var) :exit-if-null))
+         (when (policy node (and (= speed 3) (> speed compilation-speed)))
+           (let ((type (lambda-var-type var)))
+             (unless (eql *universal-type* type)
+               (do-eql-vars (other (var gen))
+                 (unless (eql other var)
+                   (conset-add-constraint gen 'typep other type nil))))))
          (conset-clear-lambda-var gen var)
          (let ((type (single-value-type (node-derived-type node))))
            (unless (eq type *universal-type*)