From: Alexey Dejneka <adejneka@comail.ru>
Date: Sat, 2 Oct 2004 07:48:32 +0000 (+0000)
Subject: 0.8.15.6:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=28dcf682ef2a3c80b7bcdda00787dbb5e3893abe;p=sbcl.git

0.8.15.6:
        * Fix bug from the Debian report #273606 by Gabor Melis:
          special variable *ALLOW-INSTRUMENTING* controls insertion of
          debug CATCH and stepper forms; is is enabled during IR1
          conversion (initial and inline expansion) and disabled
          otherwise (e.g. for IR1 transforms).
---

diff --git a/NEWS b/NEWS
index aa8b1eb..eec6df0 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,8 @@ changes in sbcl-0.8.16 relative to sbcl-0.8.15:
   * bug fix: DEFGENERIC now works even when there's a function of the
     same name in an enclosing lexical environment.  (thanks to Zach
     Beane)
+  * fixed compiler failure, caused by instrumenting code during
+    IR1-optimization.  (Debian bug report #273606 by Gabor Melis)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** POSITION on displaced vectors with non-zero displacement
        returns the right answer.
diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp
index 43d22da..b51bf8b 100644
--- a/src/compiler/early-c.lisp
+++ b/src/compiler/early-c.lisp
@@ -86,6 +86,12 @@
 (defvar *constants*)
 (declaim (type hash-table *constants*))
 
+;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
+;;; insertion of instrumenting code (like a (CATCH ...)) around code
+;;; to allow the debugger RETURN and STEP commands to function (we
+;;; disallow it for internal stuff).
+(defvar *allow-instrumenting*)
+
 ;;; miscellaneous forward declarations
 (defvar *code-segment*)
 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp
index 2ca4af6..8f852fe 100644
--- a/src/compiler/ir1-step.lisp
+++ b/src/compiler/ir1-step.lisp
@@ -64,7 +64,8 @@
                     `(locally (declare (optimize (insert-step-conditions 0)))
                       (step-variable ,form-string ,form))))
       (list
-       (let* ((*step-arguments-p* (policy *lexenv* (= insert-step-conditions 3)))
+       (let* ((*step-arguments-p* (and *allow-instrumenting*
+                                       (policy *lexenv* (= insert-step-conditions 3))))
               (step-form `(step-form ,form-string
                                      ',(source-path-original-source *current-path*)
                                      *compile-file-pathname*))
@@ -88,7 +89,8 @@
                          ;; KLUDGE: packages we're not interested in stepping.
                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
     (let ((lexenv *lexenv*))
-      (and (policy lexenv (>= insert-step-conditions 2))
+      (and *allow-instrumenting*
+           (policy lexenv (>= insert-step-conditions 2))
            (cond ((consp form)
                   (let ((op (car form)))
                     (or (and (consp op) (eq 'lambda (car op)))
@@ -99,6 +101,7 @@
                              (step-symbol-p op)))))
                  ((symbolp form)
                   (and *step-arguments-p*
+                       *allow-instrumenting*
                        (policy lexenv (= insert-step-conditions 3))
                        (not (consp (lexenv-find form vars)))
                        (not (constantp form))
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index d954575..0588565 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -439,8 +439,7 @@
 		 '(lambda named-lambda instance-lambda lambda-with-lexenv))
 	 (ir1-convert-lambdalike
 			  thing
-			  :debug-name (debug-namify "#'" thing)
-			  :allow-debug-catch-tag t))
+			  :debug-name (debug-namify "#'" thing)))
 	((legal-fun-name-p thing)
 	 (find-lexically-apparent-fun
 		     thing "as the argument to FUNCTION"))
@@ -645,8 +644,7 @@
                              (ir1-convert-lambda d
                                                  :source-name n
                                                  :debug-name (debug-namify
-                                                              "FLET " n)
-                                                 :allow-debug-catch-tag t))
+                                                              "FLET " n)))
                            names defs)))
         (processing-decls (decls nil fvars next result)
           (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
@@ -683,8 +681,7 @@
                           (ir1-convert-lambda def
                                               :source-name name
                                               :debug-name (debug-namify
-                                                           "LABELS " name)
-                                              :allow-debug-catch-tag t))
+                                                           "LABELS " name)))
                         names defs))))
         
         ;; Modify all the references to the dummy function leaves so
@@ -857,10 +854,11 @@
 ;;; Note that environment analysis replaces references to escape
 ;;; functions with references to the corresponding NLX-INFO structure.
 (def-ir1-translator %escape-fun ((tag) start next result)
-  (let ((fun (ir1-convert-lambda
-	      `(lambda ()
-		 (return-from ,tag (%unknown-values)))
-	      :debug-name (debug-namify "escape function for " tag))))
+  (let ((fun (let ((*allow-instrumenting* nil))
+               (ir1-convert-lambda
+                `(lambda ()
+                   (return-from ,tag (%unknown-values)))
+                :debug-name (debug-namify "escape function for " tag)))))
     (setf (functional-kind fun) :escape)
     (reference-leaf start next result fun)))
 
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 55c8829..909cd1f 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -822,10 +822,11 @@
 	     ;; called semi-inlining? A more descriptive name would
 	     ;; be nice. -- WHN 2002-01-07
 	     (frob ()
-	       (let ((res (ir1-convert-lambda-for-defun
-			   (defined-fun-inline-expansion leaf)
-			   leaf t
-			   #'ir1-convert-inline-lambda)))
+	       (let ((res (let ((*allow-instrumenting* t))
+                            (ir1-convert-lambda-for-defun
+                             (defined-fun-inline-expansion leaf)
+                             leaf t
+                             #'ir1-convert-inline-lambda))))
 		 (setf (defined-fun-functional leaf) res)
 		 (change-ref-leaf ref res))))
 	(if ir1-converting-not-optimizing-p
@@ -1088,8 +1089,8 @@
                                 (block-next (node-block call)))
       (let ((new-fun (ir1-convert-inline-lambda
 		      res
-		      :debug-name (debug-namify "LAMBDA-inlined " 
-						source-name 
+		      :debug-name (debug-namify "LAMBDA-inlined "
+						source-name
 						"<unknown function>")))
 	    (ref (lvar-use (combination-fun call))))
 	(change-ref-leaf ref new-fun)
diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 632d189..4094431 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -840,8 +840,7 @@
 
 ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
 (defun ir1-convert-lambda (form &key (source-name '.anonymous.)
-                           debug-name
-                           allow-debug-catch-tag)
+                           debug-name)
 
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"
@@ -857,35 +856,34 @@
      "The lambda expression has a missing or non-list lambda list:~%  ~S"
      form))
 
-  (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
-    (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
-	(make-lambda-vars (cadr form))
-      (multiple-value-bind (forms decls) (parse-body (cddr form))
-	(binding* (((*lexenv* result-type)
-                    (process-decls decls (append aux-vars vars) nil))
-                   (forms (if (and *allow-debug-catch-tag*
-                                   (policy *lexenv* (>= insert-debug-catch 2)))
-                              `((catch (locally (declare (optimize (insert-step-conditions 0)))
-                                         (make-symbol "SB-DEBUG-CATCH-TAG"))
-                                  ,@forms))
-                              forms))
-                   (forms (if (eq result-type *wild-type*)
-                              forms
-                              `((the ,result-type (progn ,@forms)))))
-                   (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-                            (ir1-convert-hairy-lambda forms vars keyp
-                                                      allow-other-keys
-                                                      aux-vars aux-vals
-                                                      :source-name source-name
-                                                      :debug-name debug-name)
-                            (ir1-convert-lambda-body forms vars
-                                                     :aux-vars aux-vars
-                                                     :aux-vals aux-vals
-                                                     :source-name source-name
-                                                     :debug-name debug-name))))
-	  (setf (functional-inline-expansion res) form)
-	  (setf (functional-arg-documentation res) (cadr form))
-	  res)))))
+  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+      (make-lambda-vars (cadr form))
+    (multiple-value-bind (forms decls) (parse-body (cddr form))
+      (binding* (((*lexenv* result-type)
+                  (process-decls decls (append aux-vars vars) nil))
+                 (forms (if (and *allow-instrumenting*
+                                 (policy *lexenv* (>= insert-debug-catch 2)))
+                            `((catch (locally (declare (optimize (insert-step-conditions 0)))
+                                       (make-symbol "SB-DEBUG-CATCH-TAG"))
+                                ,@forms))
+                            forms))
+                 (forms (if (eq result-type *wild-type*)
+                            forms
+                            `((the ,result-type (progn ,@forms)))))
+                 (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+                          (ir1-convert-hairy-lambda forms vars keyp
+                                                    allow-other-keys
+                                                    aux-vars aux-vals
+                                                    :source-name source-name
+                                                    :debug-name debug-name)
+                          (ir1-convert-lambda-body forms vars
+                                                   :aux-vars aux-vars
+                                                   :aux-vals aux-vals
+                                                   :source-name source-name
+                                                   :debug-name debug-name))))
+        (setf (functional-inline-expansion res) form)
+        (setf (functional-arg-documentation res) (cadr form))
+        res))))
 
 ;;; helper for LAMBDA-like things, to massage them into a form
 ;;; suitable for IR1-CONVERT-LAMBDA.
@@ -897,8 +895,8 @@
 ;;; 2003-01-25
 (defun ir1-convert-lambdalike (thing &rest args
 			       &key (source-name '.anonymous.)
-			       debug-name allow-debug-catch-tag)
-  (declare (ignorable source-name debug-name allow-debug-catch-tag))
+			       debug-name)
+  (declare (ignorable source-name debug-name))
   (ecase (car thing)
     ((lambda) (apply #'ir1-convert-lambda thing args))
     ((instance-lambda)
@@ -935,9 +933,7 @@
 ;;; reflect the state at the definition site.
 (defun ir1-convert-inline-lambda (fun &key
 				      (source-name '.anonymous.)
-				      debug-name
-				      allow-debug-catch-tag)
-  (declare (ignore allow-debug-catch-tag))
+				      debug-name)
   (destructuring-bind (decls macros symbol-macros &rest body)
 		      (if (eq (car fun) 'lambda-with-lexenv)
 			  (cdr fun)
@@ -953,8 +949,7 @@
 		     :policy (lexenv-policy *lexenv*))))
       (ir1-convert-lambda `(lambda ,@body)
 			  :source-name source-name
-			  :debug-name debug-name
-			  :allow-debug-catch-tag nil))))
+			  :debug-name debug-name))))
 
 ;;; Get a DEFINED-FUN object for a function we are about to define. If
 ;;; the function has been forward referenced, then substitute for the
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 07e2ce2..9f4a5e3 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -50,11 +50,6 @@
   the efficiency of stable code.")
 
 (defvar *fun-names-in-this-file* nil)
-
-;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
-;;; insertion a (CATCH ...) around code to allow the debugger RETURN
-;;; command to function.
-(defvar *allow-debug-catch-tag* t)
 
 ;;;; namespace management utilities
 
@@ -390,7 +385,8 @@
   (declare (list path))
   (let* ((*current-path* path)
 	 (component (make-empty-component))
-	 (*current-component* component))
+	 (*current-component* component)
+         (*allow-instrumenting* t))
     (setf (component-name component) "initial component")
     (setf (component-kind component) :initial)
     (let* ((forms (if for-value `(,form) `(,form nil)))
@@ -521,8 +517,7 @@
                                                   opname
                                                   :debug-name (debug-namify
                                                                "LAMBDA CAR "
-                                                               opname)
-                                                  :allow-debug-catch-tag t)))))))))
+                                                               opname))))))))))
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 1914d04..4e4b031 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -276,8 +276,7 @@
         (dolist (block (block-pred old-block))
           (change-block-successor block old-block new-block))
 
-        (ir1-convert new-start ctran filtered-lvar
-                     `(locally (declare (optimize (insert-step-conditions 0))) ,form))
+        (ir1-convert new-start ctran filtered-lvar form)
 
         ;; KLUDGE: Comments at the head of this function in CMU CL
         ;; said that somewhere in here we
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index b1e49c1..01d9c6f 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -28,7 +28,8 @@
 		  #!+sb-show *compiler-trace-output*
 		  *last-source-context* *last-original-source*
 		  *last-source-form* *last-format-string* *last-format-args*
-		  *last-message-count* *lexenv* *fun-names-in-this-file*))
+		  *last-message-count* *lexenv* *fun-names-in-this-file*
+                  *allow-instrumenting*))
 
 ;;; Whether call of a function which cannot be defined causes a full
 ;;; warning.
@@ -914,14 +915,11 @@
     (setf (component-name component)
 	  (debug-namify "~S initial component" name))
     (setf (component-kind component) :initial)
-    (let* ((locall-fun (ir1-convert-lambdalike
-                        definition
-                        :debug-name (debug-namify "top level local call "
-						  name)
-			;; KLUDGE: we do this so that we get to have
-			;; nice debug returnness in functions defined
-			;; from the REPL
-			:allow-debug-catch-tag t))
+    (let* ((locall-fun (let ((*allow-instrumenting* t))
+                         (ir1-convert-lambdalike
+                          definition
+                          :debug-name (debug-namify "top level local call "
+                                                    name))))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
 				    :source-name (or name '.anonymous.)
 				    :debug-name (unless name
@@ -955,7 +953,8 @@
 		  '(original-source-start 0 0)))
   (when name
     (legal-fun-name-or-type-error name))
-  (let* ((*lexenv* (make-lexenv :policy *policy*
+  (let* (
+         (*lexenv* (make-lexenv :policy *policy*
 				:handled-conditions *handled-conditions*
 				:disabled-package-locks *disabled-package-locks*))
          (fun (make-functional-from-toplevel-lambda lambda-expression
@@ -1403,6 +1402,7 @@
         (*source-info* info)
         (*toplevel-lambdas* ())
         (*fun-names-in-this-file* ())
+        (*allow-instrumenting* nil)
         (*compiler-error-bailout*
          (lambda ()
            (compiler-mumble "~2&; fatal error, aborting compilation~%")
diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp
index 3217c38..5d81a45 100644
--- a/src/compiler/target-main.lisp
+++ b/src/compiler/target-main.lisp
@@ -48,6 +48,7 @@
 	     (*source-info* (make-lisp-source-info form))
 	     (*toplevel-lambdas* ())
 	     (*block-compile* nil)
+             (*allow-instrumenting* nil)
 	     (*compiler-error-bailout*
 	      (lambda (&optional error)
                 (declare (ignore error))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index adafaf8..d3c6731 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1461,6 +1461,14 @@
        (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
        B))))
 
+(compile nil
+  '(lambda (buffer i end)
+    (declare (optimize (debug 3)))
+    (loop (when (not (eql 0 end)) (return)))
+    (let ((s (make-string end)))
+      (setf (schar s i) (schar buffer i))
+      s)))
+
 ;;; check that constant string prefix and suffix don't cause the
 ;;; compiler to emit code deletion notes.
 (handler-bind ((sb-ext:code-deletion-note #'error))
diff --git a/version.lisp-expr b/version.lisp-expr
index cf3bcc3..2b325b1 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.8.15.5"
+"0.8.15.6"