From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 27 Sep 2012 07:18:33 +0000 (+0300)
Subject: fix structure stack allocation for high-debug code
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d90c8a75da90925a51a587f7bd4d9c494256f68a;p=sbcl.git

fix structure stack allocation for high-debug code

  * Allow values to flow through casts in good-for-dx analysis.

  * Let-convert main-entry points for already inlined optional
    dispatches.

  * Don't preserve single-use debug vars in system-lambdas, no
    matter what the policy says.

  * Don't add INDEFINITE-EXTENT declarations to hairy entries without
    &REST arguments.

  * SB-C::REST-CONVERSION optimization declaration was pretty
    pointless, take it out.

  * Test our DX stuff in high-debug code as well.
---

diff --git a/NEWS b/NEWS
index 3b96778..f1a556d 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@ changes relative to sbcl-1.1.0:
     COMPILE-FILE still do.)
   * bug fix: SB-CLTL2:MACROEXPAND-ALL correctly handles shadowing of symbol-macros
     by lexical bindings.
+  * bug fix: stack allocation was prevented by high DEBUG declaration in several
+    cases.
 
 changes in sbcl-1.1.0 relative to sbcl-1.0.58:
   * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling
diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index fb4926c..e4e094c 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -145,7 +145,6 @@
   #!+sb-doc
   "Print a message and invoke the debugger without allowing any possibility
 of condition handling occurring."
-  (declare (optimize (sb!c::rest-conversion 0)))
   (let ((*debugger-hook* nil) ; as specifically required by ANSI
         (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
     (apply #'%break 'break datum arguments)))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 8a4d87e..7d4fdd2 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1304,7 +1304,7 @@
                               '(optimize
                                 (preserve-single-use-debug-variables 0))
                               (lexenv-policy
-                                   (combination-lexenv call)))))
+                               (combination-lexenv call)))))
   (with-ir1-environment-from-node call
     (with-component-last-block (*current-component*
                                 (block-next (node-block call)))
@@ -1715,9 +1715,7 @@
                            leaf var)))
                  t)))))
         ((and (null (rest (leaf-refs var)))
-              ;; Don't substitute single-ref variables on high-debug /
-              ;; low speed, to improve the debugging experience.
-              (policy call (< preserve-single-use-debug-variables 3))
+              (not (preserve-single-use-debug-var-p call var))
               (substitute-single-use-lvar arg var)))
         (t
          (propagate-to-refs var (lvar-type arg))))))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 731b8db..2067422 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -80,6 +80,15 @@
                    use))))
     (plu lvar)))
 
+(defun principal-lvar-dest (lvar)
+  (labels ((pld (lvar)
+             (declare (type lvar lvar))
+             (let ((dest (lvar-dest lvar)))
+               (if (cast-p dest)
+                   (pld (cast-lvar dest))
+                   dest))))
+    (pld lvar)))
+
 ;;; Update lvar use information so that NODE is no longer a use of its
 ;;; LVAR.
 ;;;
@@ -560,7 +569,7 @@
                        (when (lambda-p clambda1)
                          (dolist (var (lambda-vars clambda1) t)
                            (dolist (var-ref (lambda-var-refs var))
-                             (let ((dest (lvar-dest (ref-lvar var-ref))))
+                             (let ((dest (principal-lvar-dest (ref-lvar var-ref))))
                                (unless (and (combination-p dest) (recurse dest))
                                  (return-from combination-args-flow-cleanly-p nil)))))))))))
     (recurse combination1)))
@@ -2296,3 +2305,21 @@ is :ANY, the function name is not checked."
                (and ok (member name fun-names :test #'eq))))
          (or (not arg-count)
              (= arg-count (length (combination-args use)))))))
+
+;;; True if the optional has a rest-argument.
+(defun optional-rest-p (opt)
+  (dolist (var (optional-dispatch-arglist opt) nil)
+    (let* ((info (when (lambda-var-p var)
+                   (lambda-var-arg-info var)))
+           (kind (when info
+                   (arg-info-kind info))))
+      (when (eq :rest kind)
+        (return t)))))
+
+;;; Don't substitute single-ref variables on high-debug / low speed, to
+;;; improve the debugging experience. ...but don't bother keeping those
+;;; from system lambdas.
+(defun preserve-single-use-debug-var-p (call var)
+  (and (policy call (eql preserve-single-use-debug-variables 3))
+       (or (not (lambda-var-p var))
+           (not (lambda-system-lambda-p (lambda-var-home var))))))
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 2df985b..97372d3 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -712,7 +712,8 @@
         (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
                                  (append temps more-temps)
                                  (ignores) (call-args)
-                                 more-temps))))
+                                 (when (optional-rest-p fun)
+                                   more-temps)))))
 
   (values))
 
@@ -1028,7 +1029,13 @@
   ;; with anonymous things, and suppressing inlining
   ;; for such things can easily give Python acute indigestion, so
   ;; we don't.)
-  (when (leaf-has-source-name-p clambda)
+  ;;
+  ;; A functional that is already inline-expanded in this componsne definitely
+  ;; deserves let-conversion -- and in case of main entry points for inline
+  ;; expanded optional dispatch, the main-etry isn't explicitly marked :INLINE
+  ;; even if the function really is.
+  (when (and (leaf-has-source-name-p clambda)
+             (not (functional-inline-expanded clambda)))
     ;; ANSI requires that explicit NOTINLINE be respected.
     (or (eq (lambda-inlinep clambda) :notinline)
         ;; If (= LET-CONVERSION 0) we can guess that inlining
diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp
index 043e375..7e3aaaf 100644
--- a/src/compiler/policies.lisp
+++ b/src/compiler/policies.lisp
@@ -45,12 +45,6 @@ Enabling this option can increase heap consing of closures.")
   ("off" "maybe" "on" "on")
   "Control inline-substitution of used-once local functions.")
 
-(define-optimization-quality rest-conversion
-    (if (= debug 3) 0 3)
-  ("off" "maybe" "on" "on")
-  "Control conversion of &REST argments to &MORE arguments when
-only used as the final argument to APPLY.")
-
 (define-optimization-quality alien-funcall-saves-fp-and-pc
     (if (<= speed debug) 3 0)
   ("no" "maybe" "yes" "yes")
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 6c83f8a..6841e4d 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -21,8 +21,17 @@
       sb-ext:*stack-allocate-dynamic-extent* t)
 
 (defmacro defun-with-dx (name arglist &body body)
-  `(defun ,name ,arglist
-     ,@body))
+  (let ((debug-name (sb-int:symbolicate name "-HIGH-DEBUG"))
+        (default-name (sb-int:symbolicate name "-DEFAULT")))
+    `(progn
+       (defun ,debug-name ,arglist
+         (declare (optimize debug))
+         ,@body)
+       (defun ,default-name ,arglist
+        ,@body)
+       (defun ,name (&rest args)
+         (apply #',debug-name args)
+         (apply #',default-name args)))))
 
 (declaim (notinline opaque-identity))
 (defun opaque-identity (x)
@@ -682,7 +691,7 @@
   (bdowning-2005-iv-16))
 
 (declaim (inline my-nconc))
-(defun-with-dx my-nconc (&rest lists)
+(defun my-nconc (&rest lists)
   (declare (dynamic-extent lists))
   (apply #'nconc lists))
 (defun-with-dx my-nconc-caller (a b c)