(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)
+ ;; 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))))))))
\f
;;;; non-local exit
(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
(note-no-stack-allocation lvar)
(setf (lvar-dynamic-extent lvar) nil)))))
(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))))))