From: Paul Khuong <pvk@pvk.ca>
Date: Mon, 20 Jun 2011 01:04:20 +0000 (-0400)
Subject: More constraint propagation in the presence of assignment
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7;p=sbcl.git

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
--- 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*)