[Sbcl-commits] master: More constraint propagation in the presence of assignment

[Paul K. <pk...@us...>]

The branch "master" has been updated in SBCL:
       via  74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7 (commit)
      from  fb24d88c8f97f1b344addab398fc54f62d8aa4ce (commit)

- Log -----------------------------------------------------------------
commit 74a2974b2fd2fd94bd0b58d828f846a24cbdf3d7
Author: Paul Khuong <pv...@pv...>
Date:   Sun Jun 19 21:04:20 2011 -0400

    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) ...).
---
 src/compiler/constraint.lisp |    6 ++++++
 1 files changed, 6 insertions(+), 0 deletions(-)

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

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL