Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv12243/src/compiler
Modified Files:
ir1opt.lisp ir1util.lisp
Log Message:
0.7.3.6:
merged APD bug 147 fix (sbcl-devel 2002-04-27)
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.36
retrieving revision 1.37
diff -C2 -d -r1.36 -r1.37
*** ir1opt.lisp 17 Apr 2002 02:19:38 -0000 1.36
--- ir1opt.lisp 30 Apr 2002 01:23:23 -0000 1.37
***************
*** 240,246 ****
(cond
((or (block-delete-p block)
! (null (block-pred block))
! (eq (functional-kind (block-home-lambda block)) :deleted))
(delete-block block))
(t
(loop
--- 240,258 ----
(cond
((or (block-delete-p block)
! (null (block-pred block)))
(delete-block block))
+ ((eq (functional-kind (block-home-lambda block)) :deleted)
+ ;; Preserve the BLOCK-SUCC invariant that almost every block has
+ ;; one successor (and a block with DELETE-P set is an acceptable
+ ;; exception).
+ (labels ((mark-blocks (block)
+ (dolist (pred (block-pred block))
+ (when (and (not (block-delete-p pred))
+ (eq (functional-kind (block-home-lambda pred))
+ :deleted))
+ (setf (block-delete-p pred) t)
+ (mark-blocks pred)))))
+ (mark-blocks block)
+ (delete-block block)))
(t
(loop
***************
*** 248,252 ****
(unless (and succ (null (rest succ)))
(return)))
!
(let ((last (block-last block)))
(typecase last
--- 260,264 ----
(unless (and succ (null (rest succ)))
(return)))
!
(let ((last (block-last block)))
(typecase last
***************
*** 258,263 ****
(when (maybe-delete-exit last)
(return)))))
!
! (unless (join-successor-if-possible block)
(return)))
--- 270,275 ----
(when (maybe-delete-exit last)
(return)))))
!
! (unless (join-successor-if-possible block)
(return)))
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -C2 -d -r1.38 -r1.39
*** ir1util.lisp 7 Feb 2002 20:37:53 -0000 1.38
--- ir1util.lisp 30 Apr 2002 01:23:23 -0000 1.39
***************
*** 878,882 ****
(dolist (b (block-pred block))
! (unlink-blocks b block))
(dolist (b (block-succ block))
(unlink-blocks block b))
--- 878,889 ----
(dolist (b (block-pred block))
! (unlink-blocks b block)
! ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
! ;; broken when successors were deleted without setting the
! ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
! ;; doesn't happen again.
! (aver (not (and (null (block-succ b))
! (not (block-delete-p b))
! (not (eq b (component-head (block-component b))))))))
(dolist (b (block-succ block))
(unlink-blocks block b))
|