From 8b367c9dc077bbe307d9a59429510a6e16026a91 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 19 Feb 1990 10:48:00 +0000
Subject: [PATCH] In the NODE-ENDS-BLOCK cleanup computation, we should
 associate the cleanup with the block holding the mess-up node, rather than
 the cleanup-start continuation.

---
 compiler/ir1util.lisp | 30 ++++++++++++++++--------------
 1 file changed, 16 insertions(+), 14 deletions(-)

diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index e1cd0eff6..da35d2c6d 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -415,21 +415,23 @@
 	       (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)))
+	(let ((start-cleanup (block-start-cleanup block)))
+	  (do ((cup (find-enclosing-cleanup cleanup)
+		    (find-enclosing-cleanup (cleanup-enclosing cup))))
+	      ((null cup))
+	    (when (eq (node-block (continuation-use (cleanup-start cup)))
+		      new-block)
+	      (do ((cup (find-enclosing-cleanup (cleanup-enclosing cup))
+			(find-enclosing-cleanup (cleanup-enclosing cup))))
+		  ((null cup)
 		   (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-start-cleanup new-block) start-cleanup))
+		(let ((cb (node-block (continuation-use (cleanup-start cup)))))
+		  (unless (eq cb 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