- (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
- (let* ((last (block-last block))
- (last-cont (node-cont last))
- (next-cont (block-start next)))
- (cond (;; We cannot combine with a successor block if:
- (or
- ;; The successor has more than one predecessor.
- (rest (block-pred next))
- ;; The last node's CONT is also used somewhere else.
- ;; (as in (IF <cond> (M-V-PROG1 ...) (M-V-PROG1 ...)))
- (not (eq (continuation-use last-cont) last))
- ;; The successor is the current block (infinite loop).
- (eq next block)
- ;; The next block has a different cleanup, and thus
- ;; we may want to insert cleanup code between the
- ;; two blocks at some point.
- (not (eq (block-end-cleanup block)
- (block-start-cleanup next)))
- ;; The next block has a different home lambda, and
- ;; thus the control transfer is a non-local exit.
- (not (eq (block-home-lambda block)
- (block-home-lambda next))))
- nil)
- ;; Joining is easy when the successor's START
- ;; continuation is the same from our LAST's CONT.
- ((eq last-cont next-cont)
- (join-blocks block next)
- t)
- ;; If they differ, then we can still join when the last
- ;; continuation has no next and the next continuation
- ;; has no uses.
- ((and (null (block-start-uses next))
- (eq (continuation-kind last-cont) :inside-block))
- ;; In this case, we replace the next
- ;; continuation with the last before joining the blocks.
- (let ((next-node (continuation-next next-cont)))
- ;; If NEXT-CONT does have a dest, it must be
- ;; unreachable, since there are no USES.
- ;; DELETE-CONTINUATION will mark the dest block as
- ;; DELETE-P [and also this block, unless it is no
- ;; longer backward reachable from the dest block.]
- (delete-continuation next-cont)
- (setf (node-prev next-node) last-cont)
- (setf (continuation-next last-cont) next-node)
- (setf (block-start next) last-cont)
- (join-blocks block next))
- t)
- ((and (null (block-start-uses next))
- (not (typep (continuation-dest last-cont)
- '(or exit creturn)))
- (null (continuation-lexenv-uses last-cont)))
- (assert (null (find-uses next-cont)))
- (when (continuation-dest last-cont)
- (substitute-continuation next-cont last-cont))
- (delete-continuation-use last)
- (add-continuation-use last next-cont)
- (setf (continuation-%derived-type next-cont) nil)
- (join-blocks block next)
- t)
- (t
- nil))))))
-
-;;; Join together two blocks which have the same ending/starting
-;;; continuation. The code in BLOCK2 is moved into BLOCK1 and BLOCK2
-;;; is deleted from the DFO. We combine the optimize flags for the two
-;;; blocks so that any indicated optimization gets done.
+ (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker
+ (cond ( ;; We cannot combine with a successor block if:
+ (or
+ ;; the successor has more than one predecessor;
+ (rest (block-pred next))
+ ;; the successor is the current block (infinite loop);
+ (eq next block)
+ ;; the next block has a different cleanup, and thus
+ ;; we may want to insert cleanup code between the
+ ;; two blocks at some point;
+ (not (eq (block-end-cleanup block)
+ (block-start-cleanup next)))
+ ;; the next block has a different home lambda, and
+ ;; thus the control transfer is a non-local exit.
+ (not (eq (block-home-lambda block)
+ (block-home-lambda next)))
+ ;; Stack analysis phase wants ENTRY to start a block...
+ (entry-p (block-start-node next))
+ (let ((last (block-last block)))
+ (and (valued-node-p last)
+ (awhen (node-lvar last)
+ (or
+ ;; ... and a DX-allocator to end a block.
+ (lvar-dynamic-extent it)
+ ;; FIXME: This is a partial workaround for bug 303.
+ (consp (lvar-uses it)))))))
+ nil)
+ (t
+ (join-blocks block next)
+ t)))))
+
+;;; Join together two blocks. The code in BLOCK2 is moved into BLOCK1
+;;; and BLOCK2 is deleted from the DFO. We combine the optimize flags
+;;; for the two blocks so that any indicated optimization gets done.