+#!-sb-fluid (declaim (inline node-dest))
+(defun node-dest (node)
+ (awhen (node-lvar node) (lvar-dest it)))
+
+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+ (awhen (node-lvar node)
+ (lvar-dynamic-extent it)))
+
+(defun flushable-combination-p (call)
+ (declare (type combination call))
+ (let ((kind (combination-kind call))
+ (info (combination-fun-info call)))
+ (when (and (eq kind :known) (fun-info-p info))
+ (let ((attr (fun-info-attributes info)))
+ (when (and (not (ir1-attributep attr call))
+ ;; FIXME: For now, don't consider potentially flushable
+ ;; calls flushable when they have the CALL attribute.
+ ;; Someday we should look at the functional args to
+ ;; determine if they have any side effects.
+ (if (policy call (= safety 3))
+ (ir1-attributep attr flushable)
+ (ir1-attributep attr unsafely-flushable)))
+ t)))))
+
+;;;; DYNAMIC-EXTENT related
+
+(defun note-no-stack-allocation (lvar &key flush)
+ (do-uses (use (principal-lvar lvar))
+ (unless (or
+ ;; Don't complain about not being able to stack allocate constants.
+ (and (ref-p use) (constant-p (ref-leaf use)))
+ ;; If we're flushing, don't complain if we can flush the combination.
+ (and flush (combination-p use) (flushable-combination-p use)))
+ (let ((*compiler-error-context* use))
+ (compiler-notify "could not stack allocate the result of ~S"
+ (find-original-source (node-source-path use)))))))
+
+(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component))
+ boolean) use-good-for-dx-p))
+(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component))
+ boolean) lvar-good-for-dx-p))
+(defun use-good-for-dx-p (use dx &optional component)
+ ;; FIXME: Can casts point to LVARs in other components?
+ ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the
+ ;; PRINCIPAL-LVAR is always in the same component as the original one. It
+ ;; would be either good to have an explanation of why casts don't point
+ ;; across components, or an explanation of when they do it. ...in the
+ ;; meanwhile AVER that our assumption holds true.
+ (aver (or (not component) (eq component (node-component use))))
+ (or (dx-combination-p use dx)
+ (and (cast-p use)
+ (not (cast-type-check use))
+ (lvar-good-for-dx-p (cast-value use) dx component))
+ (and (trivial-lambda-var-ref-p use)
+ (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use))))
+ (or (eq use uses)
+ (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component))))))
+
+(defun lvar-good-for-dx-p (lvar dx &optional component)
+ (let ((uses (lvar-uses lvar)))
+ (if (listp uses)
+ (when uses
+ (every (lambda (use)
+ (use-good-for-dx-p use dx component))
+ uses))
+ (use-good-for-dx-p uses dx component))))
+
+(defun known-dx-combination-p (use dx)
+ (and (eq (combination-kind use) :known)
+ (let ((info (combination-fun-info use)))
+ (or (awhen (fun-info-stack-allocate-result info)
+ (funcall it use dx))
+ (awhen (fun-info-result-arg info)
+ (let ((args (combination-args use)))
+ (lvar-good-for-dx-p (if (zerop it)
+ (car args)
+ (nth it args))
+ dx)))))))
+
+(defun dx-combination-p (use dx)
+ (and (combination-p use)
+ (or
+ ;; Known, and can do DX.
+ (known-dx-combination-p use dx)
+ ;; Possibly a not-yet-eliminated lambda which ends up returning the
+ ;; results of an actual known DX combination.
+ (let* ((fun (combination-fun use))
+ (ref (principal-lvar-use fun))
+ (clambda (when (ref-p ref)
+ (ref-leaf ref)))
+ (creturn (when (lambda-p clambda)
+ (lambda-return clambda)))
+ (result-use (when (return-p creturn)
+ (principal-lvar-use (return-result creturn)))))
+ ;; FIXME: We should be able to deal with multiple uses here as well.
+ (and (dx-combination-p result-use dx)
+ (combination-args-flow-cleanly-p use result-use dx))))))
+
+(defun combination-args-flow-cleanly-p (combination1 combination2 dx)
+ (labels ((recurse (combination)
+ (or (eq combination combination2)
+ (if (known-dx-combination-p combination dx)
+ (let ((dest (lvar-dest (combination-lvar combination))))
+ (and (combination-p dest)
+ (recurse dest)))
+ (let* ((fun1 (combination-fun combination))
+ (ref1 (principal-lvar-use fun1))
+ (clambda1 (when (ref-p ref1) (ref-leaf ref1))))
+ (when (lambda-p clambda1)
+ (dolist (var (lambda-vars clambda1) t)
+ (dolist (var-ref (lambda-var-refs var))
+ (let ((dest (lvar-dest (ref-lvar var-ref))))
+ (unless (and (combination-p dest) (recurse dest))
+ (return-from combination-args-flow-cleanly-p nil)))))))))))
+ (recurse combination1)))
+
+(defun trivial-lambda-var-ref-p (use)
+ (and (ref-p use)
+ (let ((var (ref-leaf use)))
+ ;; lambda-var, no SETS
+ (when (and (lambda-var-p var) (not (lambda-var-sets var)))
+ (let ((home (lambda-var-home var))
+ (refs (lambda-var-refs var)))
+ ;; bound by a system lambda, no other REFS
+ (when (and (lambda-system-lambda-p home)
+ (eq use (car refs)) (not (cdr refs)))
+ ;; the LAMBDA this var is bound by has only a single REF, going
+ ;; to a combination
+ (let* ((lambda-refs (lambda-refs home))
+ (primary (car lambda-refs)))
+ (and (ref-p primary)
+ (not (cdr lambda-refs))
+ (combination-p (lvar-dest (ref-lvar primary)))))))))))
+
+(defun trivial-lambda-var-ref-lvar (use)
+ (let* ((this (ref-leaf use))
+ (home (lambda-var-home this)))
+ (multiple-value-bind (fun vars)
+ (values home (lambda-vars home))
+ (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun)))))
+ (args (combination-args combination)))
+ (assert (= (length vars) (length args)))
+ (loop for var in vars
+ for arg in args
+ when (eq var this)
+ return arg)))))
+
+;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends.
+(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component)
+ (let ((uses (lvar-uses lvar)))
+ ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS.
+ ;; Uses of mupltiple-use LVARs already end their blocks, so we just need
+ ;; to process uses of single-use LVARs.
+ (when (node-p uses)
+ (node-ends-block uses))
+ ;; If this LVAR's USE is good for DX, it is either a CAST, or it
+ ;; must be a regular combination whose arguments are potentially DX as well.
+ (flet ((recurse (use)
+ (etypecase use
+ (cast
+ (handle-nested-dynamic-extent-lvars
+ dx (cast-value use) recheck-component))
+ (combination
+ (loop for arg in (combination-args use)
+ ;; deleted args show up as NIL here
+ when (and arg
+ (lvar-good-for-dx-p arg dx recheck-component))
+ append (handle-nested-dynamic-extent-lvars
+ dx arg recheck-component)))
+ (ref
+ (let* ((other (trivial-lambda-var-ref-lvar use)))
+ (unless (eq other lvar)
+ (handle-nested-dynamic-extent-lvars
+ dx other recheck-component)))))))
+ (cons (cons dx lvar)
+ (if (listp uses)
+ (loop for use in uses
+ when (use-good-for-dx-p use dx recheck-component)
+ nconc (recurse use))
+ (when (use-good-for-dx-p uses dx recheck-component)
+ (recurse uses)))))))
+
+;;;;; BLOCK UTILS
+
+(declaim (inline block-to-be-deleted-p))
+(defun block-to-be-deleted-p (block)
+ (or (block-delete-p block)
+ (eq (functional-kind (block-home-lambda block)) :deleted)))
+
+;;; Checks whether NODE is in a block to be deleted
+(declaim (inline node-to-be-deleted-p))
+(defun node-to-be-deleted-p (node)
+ (block-to-be-deleted-p (node-block node)))