From b2b5fc7797a2c34d904e2a6e25d9ff357d915ac6 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 2 Sep 2010 14:33:05 +0000
Subject: [PATCH] 1.0.42.25: check parent-lambdas in defined-fun-functional

 * Fixes lp#308951.

 * REFERENCE-LEAF could gain access to a functional in a strange
   lexenv using DEFINED-FUN-FUNCTIONAL, messing up access to bindings.

   Don't return a functional if the current lexenvs parent-lambda chain
   does not hold the parent of the functional.

   Also provides a more elegant fix for MISC.320.
---
 NEWS                       |    5 ++++-
 src/compiler/ir1tran.lisp  |   10 +---------
 src/compiler/ir1util.lisp  |   29 +++++++++++++++++++++++++----
 tests/compiler.impure.lisp |   12 ++++++++++++
 version.lisp-expr          |    2 +-
 5 files changed, 43 insertions(+), 15 deletions(-)

diff --git a/NEWS b/NEWS
index c802acd..2c12e6b 100644
--- a/NEWS
+++ b/NEWS
@@ -31,9 +31,12 @@ changes relative to sbcl-1.0.42
   * bug fix: inline-expansion creating references to dead lambda-variables
     (lp#454681, thanks to Alexey Dejneka)
   * bug fix: better error message for bogus numerical arguments to RANDOM.
-    (lp#598986, thanks to Stas Boukarev)  
+    (lp#598986, thanks to Stas Boukarev)
+  * bug fix: the compiler occasionally inlined references from incompatible
+    environments occurs. (lp#308951)
 
 changes in sbcl-1.0.42 relative to sbcl-1.0.41
+
   * build changes
     ** Cross-compilation host is now specified to make.sh using
        command-line argument --xc-host=<command> instead of a positional
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index a18ca2a..7810dae 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -600,15 +600,7 @@
                         (not (eq (defined-fun-inlinep leaf)
                                  :notinline))
                         (let ((functional (defined-fun-functional leaf)))
-                          (when (and functional
-                                     (not (functional-kind functional))
-                                     ;; Bug MISC.320: ir1-transform
-                                     ;; can create a reference to a
-                                     ;; inline-expanded function,
-                                     ;; defined in another component.
-                                     (not (and (lambda-p functional)
-                                               (neq (lambda-component functional)
-                                                    *current-component*))))
+                          (when (and functional (not (functional-kind functional)))
                             (maybe-reanalyze-functional functional))))
                    (when (and (lambda-p leaf)
                               (memq (functional-kind leaf)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index aeb2566..2532768 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1259,11 +1259,32 @@
 
 ;;; Return functional for DEFINED-FUN which has been converted in policy
 ;;; corresponding to the current one, or NIL if no such functional exists.
+;;;
+;;; Also check that the parent of the functional is visible in the current
+;;; environment.
 (defun defined-fun-functional (defined-fun)
-  (let ((policy (lexenv-%policy *lexenv*)))
-    (dolist (functional (defined-fun-functionals defined-fun))
-      (when (equal policy (lexenv-%policy (functional-lexenv functional)))
-        (return functional)))))
+  (let ((functionals (defined-fun-functionals defined-fun)))
+    (when functionals
+      (let* ((sample (car functionals))
+             (there (lambda-parent (if (lambda-p sample)
+                                       sample
+                                       (optional-dispatch-main-entry sample)))))
+        (when there
+          (labels ((lookup (here)
+                     (unless (eq here there)
+                       (if here
+                           (lookup (lambda-parent here))
+                           ;; We looked up all the way up, and didn't find the parent
+                           ;; of the functional -- therefore it is nested in a lambda
+                           ;; we don't see, so return nil.
+                           (return-from defined-fun-functional nil)))))
+            (lookup (lexenv-lambda *lexenv*)))))
+      ;; Now find a functional whose policy matches the current one, if we already
+      ;; have one.
+      (let ((policy (lexenv-%policy *lexenv*)))
+        (dolist (functional functionals)
+          (when (equal policy (lexenv-%policy (functional-lexenv functional)))
+            (return functional)))))))
 
 ;;; Do stuff to delete the semantic attachments of a REF node. When
 ;;; this leaves zero or one reference, we do a type dispatch off of
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 513ca2c..73f224b 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1197,6 +1197,18 @@
 (with-test (:name :defmacro-not-list-lambda-list)
   (assert (raises-error? (eval `(defmacro ,(gensym) "foo"))
                          type-error)))
+
+(with-test (:name :bug-308951)
+  (let ((x 1))
+    (dotimes (y 10)
+      (let ((y y))
+        (when (funcall (eval #'(lambda (x) (eql x 2))) y)
+          (defun bug-308951-foo (z)
+            (incf x (incf y z))))))
+    (defun bug-308951-bar (z)
+      (bug-308951-foo z)
+      (values x)))
+  (assert (= 4 (bug-308951-bar 1))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
diff --git a/version.lisp-expr b/version.lisp-expr
index eda5465..36b238e 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".)
-"1.0.42.24"
+"1.0.42.25"
-- 
1.7.10.4