(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))
(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
(setf (nlx-info-target info) new-block)
(setf (nlx-info-safe-p info) (exit-should-check-tag-p exit))
(push info (physenv-nlx-info env))
- (push info (cleanup-nlx-info cleanup))
+ (push info (cleanup-info cleanup))
(when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
(setf (node-lexenv (block-last new-block))
(node-lexenv entry))))
(declare (type component component))
(dolist (lambda (component-lambdas component))
(loop for entry in (lambda-entries lambda)
- for cleanup = (entry-cleanup entry)
- do (when (eq (cleanup-kind cleanup) :dynamic-extent)
- (collect ((real-dx-lvars))
- (loop for what in (cleanup-info cleanup)
- do (etypecase what
- (lvar
- (if (let ((uses (lvar-uses what)))
- (if (listp uses)
- (every #'use-good-for-dx-p uses)
- (use-good-for-dx-p uses)))
- (real-dx-lvars what)
- (setf (lvar-dynamic-extent what) nil)))
- (node ; DX closure
- (let* ((call what)
- (arg (first (basic-combination-args call)))
- (funs (lvar-value arg))
- (dx nil))
- (dolist (fun funs)
- (binding* ((() (leaf-dynamic-extent fun)
- :exit-if-null)
- (xep (functional-entry-fun fun)
- :exit-if-null)
- (closure (physenv-closure
- (get-lambda-physenv xep))))
- (cond (closure
- (setq dx t))
- (t
- (setf (leaf-dynamic-extent fun) nil)))))
- (when dx
- (setf (lvar-dynamic-extent arg) cleanup)
- (real-dx-lvars arg))))))
- (setf (cleanup-info cleanup) (real-dx-lvars))
+ for cleanup = (entry-cleanup entry)
+ do (when (eq (cleanup-kind cleanup) :dynamic-extent)
+ (collect ((real-dx-lvars))
+ (loop for what in (cleanup-info cleanup)
+ do (etypecase what
+ (cons
+ (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
+ (note-no-stack-allocation lvar)
+ (setf (lvar-dynamic-extent lvar) nil)))))
+ (node ; DX closure
+ (let* ((call what)
+ (arg (first (basic-combination-args call)))
+ (funs (lvar-value arg))
+ (dx nil))
+ (dolist (fun funs)
+ (binding* ((() (leaf-dynamic-extent fun)
+ :exit-if-null)
+ (xep (functional-entry-fun fun)
+ :exit-if-null)
+ (closure (physenv-closure
+ (get-lambda-physenv xep))))
+ (cond (closure
+ (setq dx t))
+ (t
+ (setf (leaf-dynamic-extent fun) nil)))))
+ (when dx
+ (setf (lvar-dynamic-extent arg) cleanup)
+ (real-dx-lvars arg))))))
+ (let ((real-dx-lvars (delete-duplicates (real-dx-lvars))))
+ (setf (cleanup-info cleanup) real-dx-lvars)
(setf (component-dx-lvars component)
- (append (real-dx-lvars) (component-dx-lvars component)))))))
+ (append real-dx-lvars (component-dx-lvars component))))))))
(values))
\f
;;;; cleanup emission
(reanalyze-funs fun)
(code `(%funcall ,fun))))
((:block :tagbody)
- (dolist (nlx (cleanup-nlx-info cleanup))
+ (dolist (nlx (cleanup-info cleanup))
(code `(%lexical-exit-breakup ',nlx))))
(:dynamic-extent
(when (not (null (cleanup-info cleanup)))