From: Gabor Melis <mega@hotpop.com>
Date: Fri, 17 Mar 2006 17:31:29 +0000 (+0000)
Subject: 0.9.10.43
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a3d84edc295f60e459ec917e8bc1e3d19829381e;p=sbcl.git

0.9.10.43
  * add type constraint to variables in the consequent in situations
    similar to (IF (EQL X (LENGTH Y)) ...), where X is of type INDEX.
---

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 85c2bb8..cec6770 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -171,16 +171,10 @@
 
 ;;; Add complementary constraints to the consequent and alternative
 ;;; blocks of IF. We do nothing if X is NIL.
-(defun add-complement-constraints (if fun x y not-p constraints
-                                      consequent-constraints
-                                      alternative-constraints)
-  (when (and x
-             ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
-             ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
-             ;; that we can't guarantee that the optimization will be
-             ;; done, so we still need to avoid barfing on this case.
-             (not (eq (if-consequent if)
-                      (if-alternative if))))
+(defun 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
@@ -191,58 +185,80 @@
 ;;; the test represented by USE.
 (defun add-test-constraints (use if constraints)
   (declare (type node use) (type cif if))
-  (let ((consequent-constraints (make-sset))
-        (alternative-constraints (make-sset)))
-    (macrolet ((add (fun x y not-p)
-                 `(add-complement-constraints if ,fun ,x ,y ,not-p
-                   constraints
-                   consequent-constraints
-                   alternative-constraints)))
-      (typecase use
-        (ref
-         (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
-              (specifier-type 'null) t))
-        (combination
-         (unless (eq (combination-kind use)
-                     :error)
-           (let ((name (lvar-fun-name
-                        (basic-combination-fun use)))
-                 (args (basic-combination-args use)))
-             (case name
-               ((%typep %instance-typep)
-                (let ((type (second args)))
-                  (when (constant-lvar-p type)
-                    (let ((val (lvar-value type)))
+  ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
+  ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
+  ;; can't guarantee that the optimization will be done, so we still
+  ;; need to avoid barfing on this case.
+  (unless (eq (if-consequent if) (if-alternative if))
+    (let ((consequent-constraints (make-sset))
+          (alternative-constraints (make-sset)))
+      (macrolet ((add (fun x y not-p)
+                   `(add-complement-constraints ,fun ,x ,y ,not-p
+                     constraints
+                     consequent-constraints
+                     alternative-constraints)))
+        (typecase use
+          (ref
+           (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
+                (specifier-type 'null) t))
+          (combination
+           (unless (eq (combination-kind use)
+                       :error)
+             (let ((name (lvar-fun-name
+                          (basic-combination-fun use)))
+                   (args (basic-combination-args use)))
+               (case name
+                 ((%typep %instance-typep)
+                  (let ((type (second args)))
+                    (when (constant-lvar-p type)
+                      (let ((val (lvar-value type)))
+                        (add 'typep
+                             (ok-lvar-lambda-var (first args) constraints)
+                             (if (ctype-p val)
+                                 val
+                                 (specifier-type val))
+                             nil)))))
+                 ((eq eql)
+                  (let* ((arg1 (first args))
+                         (var1 (ok-lvar-lambda-var arg1 constraints))
+                         (arg2 (second args))
+                         (var2 (ok-lvar-lambda-var arg2 constraints)))
+                    ;; The code below assumes that the constant is the
+                    ;; second argument in case of variable to constant
+                    ;; comparision which is sometimes true (see source
+                    ;; transformations for EQ, EQL and CHAR=). Fixing
+                    ;; that would result in more constant substitutions
+                    ;; which is not a universally good thing, thus the
+                    ;; unnatural asymmetry of the tests.
+                    (cond ((not var1)
+                           (when var2
+                             (add-test-constraint 'typep var2 (lvar-type arg1)
+                                                  nil constraints
+                                                  consequent-constraints)))
+                          (var2
+                           (add 'eql var1 var2 nil))
+                          ((constant-lvar-p arg2)
+                           (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                                nil))
+                          (t
+                           (add-test-constraint 'typep var1 (lvar-type arg2)
+                                                nil constraints
+                                                consequent-constraints)))))
+                 ((< >)
+                  (let* ((arg1 (first args))
+                         (var1 (ok-lvar-lambda-var arg1 constraints))
+                         (arg2 (second args))
+                         (var2 (ok-lvar-lambda-var arg2 constraints)))
+                    (when var1
+                      (add name var1 (lvar-type arg2) nil))
+                    (when var2
+                      (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
+                 (t
+                  (let ((ptype (gethash name *backend-predicate-types*)))
+                    (when ptype
                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
-                           (if (ctype-p val)
-                               val
-                               (specifier-type val))
-                           nil)))))
-               ((eq eql)
-                (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
-                       (arg2 (second args))
-                       (var2 (ok-lvar-lambda-var arg2 constraints)))
-                  (cond ((not var1))
-                        (var2
-                         (add 'eql var1 var2 nil))
-                        ((constant-lvar-p arg2)
-                         (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
-                              nil)))))
-               ((< >)
-                (let* ((arg1 (first args))
-                       (var1 (ok-lvar-lambda-var arg1 constraints))
-                       (arg2 (second args))
-                       (var2 (ok-lvar-lambda-var arg2 constraints)))
-                  (when var1
-                    (add name var1 (lvar-type arg2) nil))
-                  (when var2
-                    (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
-               (t
-                (let ((ptype (gethash name *backend-predicate-types*)))
-                  (when ptype
-                    (add 'typep (ok-lvar-lambda-var (first args) constraints)
-                         ptype nil))))))))))
-    (values consequent-constraints alternative-constraints)))
+                           ptype nil))))))))))
+      (values consequent-constraints alternative-constraints))))
 
 ;;;; Applying constraints
 
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e0b1f61..bd1ed47 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1992,3 +1992,23 @@
 ;; aggressive constant folding (bug #400)
 (assert
  (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
+  (assert
+   (handler-case
+       (compile nil '(lambda (x y)
+                       (when (eql x (length y))
+                         (locally
+                             (declare (optimize (speed 3)))
+                           (1+ x)))))
+     (compiler-note () (error "The code is not optimized.")))))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
+  (assert
+   (handler-case
+       (compile nil '(lambda (x y)
+                       (when (eql (length y) x)
+                         (locally
+                             (declare (optimize (speed 3)))
+                           (1+ x)))))
+     (compiler-note () (error "The code is not optimized.")))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 975c30f..cdd1baa 100644
--- 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".)
-"0.9.10.42"
+"0.9.10.43"