Steel Bank Common Lisp

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))