diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index 6ab1a88b3b7226e7bc4e73e8b45ef014d2983f86..10259d87ef43f74663b1d2a9b30f6926fba13a99 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -363,9 +363,9 @@ inlines ;;;; Flow/DFO/Component hackery: -;;; Link-Blocks, Unlink-Blocks -- Interface +;;; Link-Blocks -- Interface ;;; -;;; Join or separate Block1 and Block2. +;;; Join Block1 and Block2. ;;; (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) @@ -373,14 +373,26 @@ inlines (push block2 (block-succ block1)) (push block1 (block-pred block2)) (undefined-value)) + +;;; UNLINK-BLOCKS -- Interface +;;; +;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a +;;; successor with a single predecessor that ends in an IF, then set +;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be +;;; propagated to the successor. ;;; (defun unlink-blocks (block1 block2) (declare (type cblock block1 block2)) (assert (member block2 (block-succ block1))) (setf (block-succ block1) (delete block2 (block-succ block1))) - (setf (block-pred block2) - (delete block1 (block-pred block2))) + + (let ((new-pred (delete block1 (block-pred block2)))) + (setf (block-pred block2) new-pred) + (when (and new-pred (null (rest new-pred))) + (let ((pred-block (first new-pred))) + (when (if-p (block-last pred-block)) + (setf (block-test-modified pred-block) t))))) (undefined-value)) @@ -388,7 +400,9 @@ inlines ;;; ;;; Swing the succ/pred link between Block and Old to be between Block and ;;; New. If Block ends in an IF, then we have to fix up the -;;; consequent/alternative blocks to point to New. +;;; consequent/alternative blocks to point to New. We also set +;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to the new +;;; successor. ;;; (defun change-block-successor (block old new) (declare (type cblock new old block)) @@ -398,6 +412,7 @@ inlines (let ((last (block-last block))) (when (if-p last) + (setf (block-test-modified block) t) (macrolet ((frob (slot) `(when (eq (,slot last) old) (setf (,slot last) new))))