X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fphysenvanal.lisp;h=615239a3f47f8246db4193cd970608a6fae6972f;hb=ca308e6377525654efb755fd30af3270a04f099a;hp=fe6769ca2de37d297b869aebda295fac98fec919;hpb=fb26039e896a6d89f86274b714f5be25b5fc8603;p=sbcl.git

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index fe6769c..615239a 100644
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -219,12 +219,32 @@
 ;;; that need checking.
 (defun analyze-indirect-lambda-vars (component)
   (dolist (fun (component-lambdas component))
-    (unless (leaf-dynamic-extent fun)
-      (let ((closure (physenv-closure (lambda-physenv fun))))
-        (dolist (var closure)
-          (when (and (lambda-var-p var)
-                     (lambda-var-indirect var))
-            (setf (lambda-var-explicit-value-cell var) t)))))))
+    (let ((entry-fun (functional-entry-fun fun)))
+      ;; We also check the ENTRY-FUN, as XEPs for LABELS or FLET
+      ;; functions aren't set to be DX even if their underlying
+      ;; CLAMBDAs are, and if we ever get LET-bound anonymous function
+      ;; DX working, it would mark the XEP as being DX but not the
+      ;; "real" CLAMBDA.  This works because a FUNCTIONAL-ENTRY-FUN is
+      ;; either NULL, a self-pointer (for :TOPLEVEL functions), a
+      ;; pointer from an XEP to its underlying function (for :EXTERNAL
+      ;; functions), or a pointer from an underlying function to its
+      ;; XEP (for non-:TOPLEVEL functions with XEPs).
+      (unless (or (leaf-dynamic-extent fun)
+                  ;; Functions without XEPs can be treated as if they
+                  ;; are DYNAMIC-EXTENT, even without being so
+                  ;; declared, as any escaping closure which /isn't/
+                  ;; DYNAMIC-EXTENT but calls one of these functions
+                  ;; will also close over the required variables, thus
+                  ;; forcing the allocation of value cells.  Since the
+                  ;; XEP is stored in the ENTRY-FUN slot, we can pick
+                  ;; off the non-XEP case here.
+                  (not entry-fun)
+                  (leaf-dynamic-extent entry-fun))
+        (let ((closure (physenv-closure (lambda-physenv fun))))
+          (dolist (var closure)
+            (when (and (lambda-var-p var)
+                       (lambda-var-indirect var))
+              (setf (lambda-var-explicit-value-cell var) t))))))))
 
 ;;;; non-local exit
 
@@ -381,7 +401,7 @@
                                    (cond (closure
                                           (setq dx t))
                                          (t
-                                          (setf (leaf-dynamic-extent fun) nil)))))
+                                          (setf (leaf-extent fun) nil)))))
                                (when dx
                                  (setf (lvar-dynamic-extent arg) cleanup)
                                  (real-dx-lvars arg))))))
@@ -476,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))