From 773ca4afcc241595a739a52472c9ef6c07d28c36 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 15 Feb 1990 13:07:11 +0000 Subject: [PATCH] I think I finally have the cleanup computation in NODE-ENDS-BLOCK right. We can't just always make the cleanup at the split the old end cleanup. Instead, we must see if the split moves any of the old cleanups to the new block. In that case, we must scan up the the cleanup-enclosing thread to find the innermost cleanup that wasn't moved into the new block. --- compiler/ir1util.lisp | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index 7e0309cca..b86ca541d 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -374,6 +374,14 @@ ;;; ;;; Makes Node the Last node in its block, splitting the block if necessary. ;;; +;;; If the mess-up for one of Block's End-Cleanups is moved into the new +;;; block, then we must adjust the end/start cleanups of the new and old blocks +;;; to reflect the movement of the mess-up. If any of the old end cleanups +;;; were in the new block, then we scan up from that cleanup trying to find one +;;; that isn't. When we do, that becomes the new start/end cleanup of the +;;; old/new block. We set the start/end as a pair, since we don't want anyone +;;; to think that a cleanup is necessary. +;;; (defun node-ends-block (node) (declare (type node node)) (let* ((block (node-block node)) @@ -407,6 +415,22 @@ (setf (continuation-block last-cont) new-block))) (setf (continuation-block cont) new-block)) + (do ((cup (find-enclosing-cleanup cleanup) + (find-enclosing-cleanup (cleanup-enclosing cup)))) + ((null cup)) + (when (eq (continuation-block (cleanup-start cup)) new-block) + (do ((cup (find-enclosing-cleanup (cleanup-enclosing cup)) + (find-enclosing-cleanup (cleanup-enclosing cup)))) + ((null cup) + (let ((start-cleanup (block-start-cleanup block))) + (setf (block-end-cleanup block) start-cleanup) + (setf (block-start-cleanup new-block) start-cleanup))) + (unless (eq (continuation-block (cleanup-start cup)) new-block) + (setf (block-end-cleanup block) cup) + (setf (block-start-cleanup new-block) cup) + (return))) + (return))) + (setf (block-type-asserted block) t) (setf (block-test-modified block) t)))) -- GitLab