+ (setf (ir2-block-end-stack 2block) new-end)
+
+ (let ((start new-end))
+ (setq start (set-difference start (ir2-block-pushed 2block)))
+ (setq start (merge-uvl-live-sets start (ir2-block-popped 2block)))
+
+ ;; We cannot delete unused UVLs during NLX, so all UVLs live at
+ ;; ENTRY will be actually live at NLE.
+ ;;
+ ;; BUT, UNWIND-PROTECTor is called in the environment, which has
+ ;; nothing in common with the environment of its entry. So we
+ ;; fictively compute its stack from the containing cleanups, but
+ ;; do not propagate additional LVARs from the entry, thus
+ ;; preveting bogus stack cleanings.
+ ;;
+ ;; TODO: Insert a check that no values are discarded in UWP. Or,
+ ;; maybe, we just don't need to create NLX-ENTRY for UWP?
+ (when (and (eq (component-head (block-component block))
+ (first (block-pred block)))
+ (not (bind-p (block-start-node block))))
+ (let* ((nlx-info (nle-block-nlx-info block))
+ (cleanup (nlx-info-cleanup nlx-info)))
+ (unless (eq (cleanup-kind cleanup) :unwind-protect)
+ (let* ((entry-block (node-block (cleanup-mess-up cleanup)))
+ (entry-stack (ir2-block-start-stack (block-info entry-block))))
+ (setq start (merge-uvl-live-sets start entry-stack))))))
+
+ (when *check-consistency*
+ (aver (subsetp original-start start)))
+ (cond ((subsetp start original-start)
+ nil)
+ (t
+ (setf (ir2-block-start-stack 2block) start)
+ t)))))
+
+\f
+;;;; Ordering of live UVL stacks
+
+;;; Put UVLs on the start/end stacks of BLOCK in the right order. PRED
+;;; is a predecessor of BLOCK with already sorted stacks; because all
+;;; UVLs being live at the BLOCK start are live in PRED, we just need
+;;; to delete dead UVLs.
+(defun order-block-uvl-sets (block pred)
+ (let* ((2block (block-info block))
+ (pred-end-stack (ir2-block-end-stack (block-info pred)))
+ (start (ir2-block-start-stack 2block))
+ (start-stack (loop for lvar in pred-end-stack
+ when (memq lvar start)
+ collect lvar))
+ (end (ir2-block-end-stack 2block)))
+ (when *check-consistency*
+ (aver (subsetp start start-stack)))
+ (setf (ir2-block-start-stack 2block) start-stack)
+
+ (let* ((last (block-last block))
+ (tailp-lvar (if (node-tail-p last) (node-lvar last)))
+ (end-stack start-stack))
+ (dolist (pop (ir2-block-popped 2block))
+ (aver (eq pop (car end-stack)))
+ (pop end-stack))
+ (dolist (push (ir2-block-pushed 2block))
+ (aver (not (memq push end-stack)))
+ (push push end-stack))
+ (aver (subsetp end end-stack))
+ (when (and tailp-lvar
+ (eq (ir2-lvar-kind (lvar-info tailp-lvar)) :unknown))
+ (aver (eq tailp-lvar (first end-stack)))
+ (pop end-stack))
+ (setf (ir2-block-end-stack 2block) end-stack))))
+
+(defun order-uvl-sets (component)
+ (clear-flags component)
+ (loop with head = (component-head component)
+ with repeat-p do
+ (setq repeat-p nil)
+ (do-blocks (block component)
+ (unless (block-flag block)
+ (let ((pred (find-if #'block-flag (block-pred block))))
+ (when (and (eq pred head)
+ (not (bind-p (block-start-node block))))
+ (let ((entry (nle-block-entry-block block)))
+ (setq pred (if (block-flag entry) entry nil))))
+ (cond (pred
+ (setf (block-flag block) t)
+ (order-block-uvl-sets block pred))
+ (t
+ (setq repeat-p t))))))
+ while repeat-p))