1.0.44.18: physenvanal: When checking closure-DXness, handle XEPs reasonably.

[sbcl.git] / src / compiler / physenvanal.lisp

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index ee3874e..d067c27 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -41,6 +41,7 @@
   (recheck-dynamic-extent-lvars component)
   (find-cleanup-points component)
   (tail-annotate component)
+  (analyze-indirect-lambda-vars component)
 
   (dolist (fun (component-lambdas component))
     (when (null (leaf-refs fun))
@@ -207,6 +208,35 @@
                                 (flood (get-node-physenv ref))))))))))
       (flood ref-physenv)))
   (values))
+
+;;; Find LAMBDA-VARs that are marked as needing to support indirect
+;;; access (SET at some point after initial creation) that are present
+;;; in CLAMBDAs not marked as being DYNAMIC-EXTENT (meaning that the
+;;; value-cell involved must be able to survive past the extent of the
+;;; allocating frame), and mark them (the LAMBDA-VARs) as needing
+;;; explicit value-cells.  Because they are already closed-over, the
+;;; LAMBDA-VARs already appear in the closures of all of the CLAMBDAs
+;;; that need checking.
+(defun analyze-indirect-lambda-vars (component)
+  (dolist (fun (component-lambdas component))
+    (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)
+                  (and 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))))))))
 \f
 ;;;; non-local exit
 
@@ -334,16 +364,19 @@
                  (loop for what in (cleanup-info cleanup)
                        do (etypecase what
                             (cons
-                             (let ((lvar (cdr what)))
-                               (cond ((lvar-good-for-dx-p lvar (car what) component)
-                                      (let ((real (principal-lvar lvar)))
-                                        (setf (lvar-dynamic-extent real) cleanup)
-                                        (real-dx-lvars real)))
+                             (let ((dx (car what))
+                                   (lvar (cdr what)))
+                               (cond ((lvar-good-for-dx-p lvar dx component)
+                                      ;; Since the above check does deep
+                                      ;; checks. we need to deal with the deep
+                                      ;; results in here as well.
+                                      (dolist (cell (handle-nested-dynamic-extent-lvars
+                                                     dx lvar component))
+                                        (let ((real (principal-lvar (cdr cell))))
+                                          (setf (lvar-dynamic-extent real) cleanup)
+                                          (real-dx-lvars real))))
                                      (t
-                                      (do-uses (use lvar)
-                                        (unless (ref-p use)
-                                          (compiler-notify "could not stack allocate the result of ~S"
-                                                           (find-original-source (node-source-path use)))))
+                                      (note-no-stack-allocation lvar)
                                       (setf (lvar-dynamic-extent lvar) nil)))))
                             (node       ; DX closure
                              (let* ((call what)