From: Juho Snellman <jsnell@iki.fi>
Date: Mon, 18 Jun 2007 16:02:55 +0000 (+0000)
Subject: 1.0.6.48: Don't instrument the internal flets from the PROGV expansion
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=abf95924deb0b9677a160c02632749d80a3c24f8;p=sbcl.git

1.0.6.48: Don't instrument the internal flets from the PROGV expansion

        * PROGV would get compiled to BINDING-STACK-POINTER -> X, ...,
          BIND-SENTINEL, UNBIND-TO-HERE X, UNBIND-SENTINEL. So the
          UNBIND-TO-HERE would also pop the sentinel from the binding stack,
          and the UNBIND-SENTINEL would then unbalance the stack.
        * Ensure that there will only be matched BIND-SENTINEL /
          UNBIND-SENTINEL pairs between taking the binding stack pointer
          and unwinding by adding some (OPTIMIZE (INSERT-DEBUG-CATCH 0))
          declarations.
	* Reported by Nikodemus
---

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a6cfd96..48bc62a 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -1051,6 +1051,7 @@ due to normal completion or a non-local exit such as THROW)."
                     (%unwind-protect (%escape-fun ,exit-tag)
                                      (%cleanup-fun ,cleanup-fun))
                   (return-from ,drop-thru-tag ,protected)))
+            (declare (optimize (insert-debug-catch 0)))
             (,cleanup-fun)
             (%continue-unwind ,next ,start ,count)))))))
 
diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index a2b7966..d882195 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -906,9 +906,11 @@
       (binding* (((*lexenv* result-type post-binding-lexenv)
                   (process-decls decls (append aux-vars vars) nil
                                  :binding-form-p t))
-                 (forms (if (and maybe-add-debug-catch
-                                 *allow-instrumenting*
-                                 (policy *lexenv* (>= insert-debug-catch 2)))
+                 (debug-catch-p (and maybe-add-debug-catch
+                                     *allow-instrumenting*
+                                     (policy *lexenv*
+                                             (>= insert-debug-catch 2))))
+                 (forms (if debug-catch-p
                             (wrap-forms-in-debug-catch forms)
                             forms))
                  (forms (if (eq result-type *wild-type*)
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 34fe388..db050bc 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1448,6 +1448,15 @@
                  (,bind ,vars ,vals))
                nil
                ,@body)
+          ;; Technically ANSI CL doesn't allow declarations at the
+          ;; start of the cleanup form. SBCL happens to allow for
+          ;; them, due to the way the UNWIND-PROTECT ir1 translation
+          ;; is implemented; the cleanup forms are directly spliced
+          ;; into an FLET definition body. And a declaration here
+          ;; actually has exactly the right scope for what we need
+          ;; (ensure that debug instrumentation is not emitted for the
+          ;; cleanup function). -- JES, 2007-06-16
+          (declare (optimize (insert-debug-catch 0)))
           (%primitive unbind-to-here ,n-save-bs))))))
 
 ;;;; non-local exit
diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp
index 302f5f9..f2a5d3d 100644
--- a/tests/compiler.impure-cload.lisp
+++ b/tests/compiler.impure-cload.lisp
@@ -499,3 +499,21 @@
       (locally
           (declare)
         2))
+
+;;; Bug in the interaction of BIND-SENTINEL and UNBIND-TO-HERE, as
+;;; used by PROGV.
+
+(defvar *foo-1* nil)
+(defvar *foo-2* nil)
+
+(defun foo ()
+  (declare (optimize (debug 2)))
+  (let ((*foo-1* nil))
+    (progv
+        (list '*foo-2*)
+        (list nil)
+      (write-line "foo-2"))
+    (write-line "foo-1"))
+  (write-line "foo-0"))
+
+(foo)
diff --git a/version.lisp-expr b/version.lisp-expr
index 57aad90..e13ff13 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.6.47"
+"1.0.6.48"