- 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 ((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)))
+ (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)))))
+ (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)