tweak tail merging logic

 TAIL-ANNOTATE used MERGE-TAIL-CALLS policy (which is an integer) as a
 boolean, instead of comparing it to zero. Oops. This means that we always did
 TCO when possible.

 Since adding a debug-catch-tag effectively prevents TCO, and the policy
 controlling that looks just like what we would like to have in
 MERGE-TAIL-CALLS if TAIL-ANNOTATE were to use it correctly... just deprecate
 MERGE-TAIL-CALLS instead.

diff --git a/NEWS b/NEWS
index b69cc16..8d62097 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -47,6 +47,9 @@ changes relative to sbcl-1.0.53:
        systems with getaddrinfo().
     ** GET-HOST-BY-NAME and GET-HOST-BY-ADDRESS weren't thread or interrupt
        safe outside systems with getaddrinfo().
+  * enhancement: special-case TCO prevention for functions which never return
+    extended to untrusted type, keeping one more frame's worth of debug
+    information around in many cases.
   * enhancement: debug-names of anonymous and local function are more
     descriptive. Affects backtraces and SB-SPROF results. (lp#805100)
   * enhancement: on CHENEYGC targets, SB-KERNEL:MAKE-LISP-OBJ now does

diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp
index ab1edf2..dd1760c 100644 (file)
--- a/contrib/sb-sprof/sb-sprof.lisp
+++ b/contrib/sb-sprof/sb-sprof.lisp
@@ -514,7 +514,7 @@ profiling")
   ;;; This in turn will distribute the notice to those threads we are
   ;;; interested using SIGPROF.
   (defun thread-distribution-handler ()
-    (declare (optimize sb-c::merge-tail-calls))
+    (declare (optimize speed (space 0)))
     (when *sampling*
       #+sb-thread
       (let ((lock *distribution-lock*))

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index e3ef6cf..4f433b1 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -149,6 +149,16 @@
            (t (eq (block-start (first (block-succ (node-block node))))
                   (node-prev dest))))))
 
+;;; Returns the defined (usually untrusted) type of the combination,
+;;; or NIL if we couldn't figure it out.
+(defun combination-defined-type (combination)
+  (let ((use (principal-lvar-use (basic-combination-fun combination))))
+    (or (when (ref-p use)
+          (let ((type (leaf-defined-type (ref-leaf use))))
+            (when (fun-type-p type)
+              (fun-type-returns type))))
+        *wild-type*)))
+
 ;;; Return true if LVAR destination is executed after node with only
 ;;; uninteresting nodes intervening.
 ;;;

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 9e605c1..4e18af7 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -163,9 +163,7 @@
           ,(if (policy *lexenv* (zerop verify-arg-count))
                `(declare (ignore ,n-supplied))
                `(%verify-arg-count ,n-supplied ,nargs))
-          (locally
-            (declare (optimize (merge-tail-calls 3)))
-            (%funcall ,fun ,@temps)))))
+          (%funcall ,fun ,@temps))))
     (optional-dispatch
      (let* ((min (optional-dispatch-min-args fun))
             (max (optional-dispatch-max-args fun))
@@ -190,9 +188,7 @@
                     ,(with-unique-names (n-context n-count)
                        `(multiple-value-bind (,n-context ,n-count)
                             (%more-arg-context ,n-supplied ,max)
-                          (locally
-                            (declare (optimize (merge-tail-calls 3)))
-                            (%funcall ,more ,@temps ,n-context ,n-count)))))))
+                          (%funcall ,more ,@temps ,n-context ,n-count))))))
              (t
               (%arg-count-error ,n-supplied)))))))))
 

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index a2adbcc..615239a 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -496,26 +496,24 @@
   (declare (type component component))
   (dolist (fun (component-lambdas component))
     (let ((ret (lambda-return fun)))
-      ;; Nodes whose type is NIL (i.e. don't return) such as calls to
-      ;; ERROR are never annotated as TAIL-P, in order to preserve
-      ;; debugging information.
-      ;;
-      ;; FIXME: It might be better to add another DEFKNOWN property
-      ;; (e.g. NO-TAIL-RECURSION) and use it for error-handling
-      ;; functions like ERROR, instead of spreading this special case
-      ;; net so widely. --WHN?
-      ;;
-      ;; Why is that bad? Because this non-elimination of
-      ;; non-returning tail calls causes the XEP for FOO appear in
-      ;; backtrace for (defun foo (x) (error "foo ~S" x)) wich seems
-      ;; less then optimal. --NS 2005-02-28
       (when ret
         (let ((result (return-result ret)))
           (do-uses (use result)
-            (when (and (policy use merge-tail-calls)
-                       (basic-combination-p use)
+            (when (and (basic-combination-p use)
                        (immediately-used-p result use)
-                       (or (not (eq (node-derived-type use) *empty-type*))
-                           (eq (basic-combination-kind use) :local)))
+                       (or (eq (basic-combination-kind use) :local)
+                           ;; Nodes whose type is NIL (i.e. don't return) such
+                           ;; as calls to ERROR are never annotated as TAIL-P,
+                           ;; in order to preserve debugging information, so that
+                           ;;
+                           ;; We spread this net wide enough to catch
+                           ;; untrusted NIL return types as well, so that
+                           ;; frames calling functions such as FOO-ERROR are
+                           ;; kept in backtraces:
+                           ;;
+                           ;;  (defun foo-error (x) (error "oops: ~S" x))
+                           ;;
+                           (not (or (eq *empty-type* (node-derived-type use))
+                                    (eq *empty-type* (combination-defined-type use))))))
               (setf (node-tail-p use) t)))))))
   (values))

diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp
index 18437bb..53b21e4 100644 (file)
--- a/src/compiler/policies.lisp
+++ b/src/compiler/policies.lisp
@@ -62,27 +62,18 @@ more reliable bactracing across foreign calls.")
   ("no" "maybe" "yes" "yes"))
 
 (define-optimization-quality merge-tail-calls
-    (if (or (> space debug)
-            (> speed debug))
-        3
-        0)
-  ("no" "maybe" "yes" "yes")
-  "Control whether tail-calls should reuse caller stack frame.
-Enabling this option make functions use less stack space, and make
-tail-recursive functions execute in constant stack, but debugging
-become harder, because backtraces show only part of function call
-sequence.
-
-This options has no effect when INSERT-DEBUG-CATCH is set.")
+    3
+  "Deprecated: has no effect on compiled code. (Never really did.)")
 
 (define-optimization-quality insert-debug-catch
     (if (> debug (max speed space))
         3
         0)
   ("no" "maybe" "yes" "yes")
-  "Enable possibility of returning from stack frames with the debugger.
-
-Enabling this option effectively disables MERGE-TAIL-CALLS.")
+  "Enables possibility of returning from stack frames with the debugger.
+Enabling this option causes apparent tail calls to no longer be in a tail
+position -- effectively disabling tail-merging, hence causing apparently tail
+recursive functions to no longer execute in constant stack space")
 
 (define-optimization-quality recognize-self-calls
     (if (> (max speed space) debug)