From: Alastair Bridgewater <lisphacker@users.sourceforge.net>
Date: Fri, 11 Mar 2011 15:35:30 +0000 (+0000)
Subject: 1.0.46.33: constraint: Don't substitute REFs when replacement LEAF is not visible.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4d7b7a70cbb3cd7bf64897747d407f40803e3d72;p=sbcl.git

1.0.46.33: constraint: Don't substitute REFs when replacement LEAF is not visible.

  * Bug reported by Frank Duncan, additional diagnosis by Heka Treep,
patch review and revision by Nikodemus Siivola.

  * Introduce LEAF-VISIBLE-FROM-NODE-P, which verifies that the LEAF
about to be substituted is visible from the NODE to be modified.

  * Add LEAF-VISIBLE-FROM-NODE-P as an additional precondition to
calling CHANGE-REF-LEAF, which does the actual substitution.

  * And, for good measure, added a test to the test suite.
---

diff --git a/NEWS b/NEWS
index 741ba8a..c92f2a9 100644
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,10 @@ changes relative to sbcl-1.0.46:
   * bug fix: several foreign functions accepting string also accepted NIL and
     consequently caused a memory fault at 0 now signal a type-error instead.
     (lp#721087)
+  * bug fix: under rare circumstances, constraint propagation could rewrite a
+    variable reference to refer to a variable not in scope, causing an error
+    during physical environment analysis when attempting to close over the
+    variable. (lp#551227)
 
 changes in sbcl-1.0.46 relative to sbcl-1.0.45:
   * enhancement: largefile support on Solaris.
diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index a32c5a9..812976e 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -604,6 +604,24 @@
           (modified-numeric-type x :low new-bound)
           (modified-numeric-type x :high new-bound)))))
 
+;;; Return true if LEAF is "visible" from NODE.
+(defun leaf-visible-from-node-p (leaf node)
+  (cond
+   ((lambda-var-p leaf)
+    ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
+    ;; ancestor for NODE.
+    (let ((leaf-lambda (lambda-var-home leaf)))
+      (loop for lambda = (node-home-lambda node)
+            then (lambda-parent lambda)
+            while lambda
+            when (eq lambda leaf-lambda)
+            return t)))
+   ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
+   ;; not just LAMBDA-VARs.
+   (t
+    ;; Assume everything else is globally visible.
+    t)))
+
 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 ;;; restrictions from flow analysis IN, set the type for REF
 ;;; accordingly.
@@ -659,7 +677,9 @@
                               (and (leaf-refs other) ; protect from
                                         ; deleted vars
                                    (csubtypep other-type leaf-type)
-                                   (not (type= other-type leaf-type))))
+                                   (not (type= other-type leaf-type))
+                                   ;; Don't change to a LEAF not visible here.
+                                   (leaf-visible-from-node-p other ref)))
                           (change-ref-leaf ref other)
                           (when (constant-p other) (return)))
                          (t
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index a41b164..051be59 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3770,3 +3770,20 @@
   (handler-bind ((warning #'error))
     (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
     (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
+
+(with-test (:name :bug-551227)
+  ;; This function causes constraint analysis to perform a
+  ;; ref-substitution that alters the A referred to in (G A) at in the
+  ;; consequent of the IF to refer to be NUMBER, from the
+  ;; LET-converted inline-expansion of MOD.  This leads to attempting
+  ;; to CLOSE-OVER a variable that simply isn't in scope when it is
+  ;; referenced.
+  (compile nil '(lambda (a)
+                  (if (let ((s a))
+                        (block :block
+                          (map nil
+                               (lambda (e)
+                                 (return-from :block
+                                   (f (mod a e))))
+                               s)))
+                      (g a)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 966bc09..d69ed47 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,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".)
-"1.0.46.32"
+"1.0.46.33"