[Sbcl-commits] CVS: sbcl/src/compiler dfo.lisp,1.17,1.18 ir1opt.lisp,1.83,1.84 ir1util.lisp,1.82,1.83 node.lisp,1.47,1.48

[Alexey D. <ade...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv21573/src/compiler

Modified Files:
	dfo.lisp ir1opt.lisp ir1util.lisp node.lisp 
Log Message:
0.8.5.42:
        * IR1-OPTIMIZE: whenever possible, delete all marked blocks.


Index: dfo.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dfo.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- dfo.lisp	15 Nov 2003 18:34:34 -0000	1.17
+++ dfo.lisp	16 Nov 2003 10:19:13 -0000	1.18
@@ -30,10 +30,8 @@
     (do-blocks-backwards (block component :both)
       (if (block-flag block)
 	  (setf (block-number block) (incf num))
-	  (setf (block-delete-p block) t)))
-    (do-blocks (block component)
-      (when (block-delete-p block)
-	(delete-block block))))
+	  (delete-block-lazily block)))
+    (clean-component component (component-head component)))
   (values))
 
 ;;; Move all the code and entry points from OLD to NEW. The code in

Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.83
retrieving revision 1.84
diff -u -d -r1.83 -r1.84
--- ir1opt.lisp	15 Nov 2003 18:34:34 -0000	1.83
+++ ir1opt.lisp	16 Nov 2003 10:19:13 -0000	1.84
@@ -216,49 +216,55 @@
 (defun ir1-optimize (component)
   (declare (type component component))
   (setf (component-reoptimize component) nil)
-  (do-blocks (block component)
-    (cond
-      ;; We delete blocks when there is either no predecessor or the
-      ;; block is in a lambda that has been deleted. These blocks
-      ;; would eventually be deleted by DFO recomputation, but doing
-      ;; it here immediately makes the effect available to IR1
-      ;; optimization.
-      ((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).
-       (mark-for-deletion block)
-       (delete-block block))
-      (t
-       (loop
-          (let ((succ (block-succ block)))
-            (unless (singleton-p succ)
-              (return)))
+  (loop with block = (block-next (component-head component))
+        with tail = (component-tail component)
+        for last-block = block
+        until (eq block tail)
+        do (cond
+             ;; We delete blocks when there is either no predecessor or the
+             ;; block is in a lambda that has been deleted. These blocks
+             ;; would eventually be deleted by DFO recomputation, but doing
+             ;; it here immediately makes the effect available to IR1
+             ;; optimization.
+             ((or (block-delete-p block)
+                  (null (block-pred block)))
+              (delete-block-lazily block)
+              (setq block (clean-component component 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).
+              (mark-for-deletion block)
+              (setq block (clean-component component block)))
+             (t
+              (loop
+                 (let ((succ (block-succ block)))
+                   (unless (singleton-p succ)
+                     (return)))
 
-          (let ((last (block-last block)))
-            (typecase last
-              (cif
-               (flush-dest (if-test last))
-               (when (unlink-node last)
-                 (return)))
-              (exit
-               (when (maybe-delete-exit last)
-                 (return)))))
+                 (let ((last (block-last block)))
+                   (typecase last
+                     (cif
+                      (flush-dest (if-test last))
+                      (when (unlink-node last)
+                        (return)))
+                     (exit
+                      (when (maybe-delete-exit last)
+                        (return)))))
 
-          (unless (join-successor-if-possible block)
-            (return)))
+                 (unless (join-successor-if-possible block)
+                   (return)))
 
-       (when (and (block-reoptimize block) (block-component block))
-         (aver (not (block-delete-p block)))
-         (ir1-optimize-block block))
+              (when (and (block-reoptimize block) (block-component block))
+                (aver (not (block-delete-p block)))
+                (ir1-optimize-block block))
 
-       (cond ((and (block-delete-p block) (block-component block))
-              (delete-block block))
-             ((and (block-flush-p block) (block-component block))
-              (flush-dead-code block))))))
+              (cond ((and (block-delete-p block) (block-component block))
+                     (setq block (clean-component component block)))
+                    ((and (block-flush-p block) (block-component block))
+                     (flush-dead-code block)))))
+        do (when (eq block last-block)
+             (setq block (block-next block))))
 
   (values))
 
@@ -1746,7 +1752,7 @@
           (maybe-terminate-block (lvar-uses value) nil)
           ;; FIXME: Is it necessary?
           (aver (null (block-pred (node-block cast))))
-          (setf (block-delete-p (node-block cast)) t)
+          (delete-block-lazily (node-block cast))
           (return-from ir1-optimize-cast)))
       (when (eq (node-derived-type cast) *empty-type*)
         (maybe-terminate-block cast nil))

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -d -r1.82 -r1.83
--- ir1util.lisp	26 Oct 2003 15:34:38 -0000	1.82
+++ ir1util.lisp	16 Nov 2003 10:19:14 -0000	1.83
@@ -971,6 +971,13 @@
         (unless (block-delete-p block)
           (mark-for-deletion block))))))
 
+;;; Queue the block for deletion
+(defun delete-block-lazily (block)
+  (declare (type cblock block))
+  (unless (block-delete-p block)
+    (setf (block-delete-p block) t)
+    (push block (component-delete-blocks (block-component block)))))
+
 ;;; Do a graph walk backward from BLOCK, marking all predecessor
 ;;; blocks with the DELETE-P flag.
 (defun mark-for-deletion (block)
@@ -978,7 +985,7 @@
   (let* ((component (block-component block))
          (head (component-head component)))
     (labels ((helper (block)
-               (setf (block-delete-p block) t)
+               (delete-block-lazily block)
                (dolist (pred (block-pred block))
                  (unless (or (block-delete-p pred)
                              (eq pred head))
@@ -991,10 +998,12 @@
 ;;; This function does what is necessary to eliminate the code in it
 ;;; from the IR1 representation. This involves unlinking it from its
 ;;; predecessors and successors and deleting various node-specific
-;;; semantic information.
+;;; semantic information. BLOCK must be already removed from
+;;; COMPONENT-DELETE-BLOCKS.
 (defun delete-block (block &optional silent)
   (declare (type cblock block))
   (aver (block-component block))      ; else block is already deleted!
+  #!+high-security (aver (not (memq block (component-delete-blocks (block-component block)))))
   (unless silent
     (note-block-deletion block))
   (setf (block-delete-p block) t)
@@ -1225,7 +1234,11 @@
 	       (unlink-blocks block next)
 	       (dolist (pred (block-pred block))
 		 (change-block-successor pred block next))
-	       (remove-from-dfo block)
+	       (when (block-delete-p block)
+                 (let ((component (block-component block)))
+                   (setf (component-delete-blocks component)
+                         (delq block (component-delete-blocks component)))))
+               (remove-from-dfo block)
                (setf (block-delete-p block) t)
 	       (setf (node-prev node) nil)
 	       t)))))))
@@ -1248,16 +1261,26 @@
   (aver (null (component-new-functionals component)))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)
-    (setf (block-delete-p block) t))
+    (delete-block-lazily block))
   (dolist (fun (component-lambdas component))
     (unless (eq (functional-kind fun) :deleted)
       (setf (functional-kind fun) nil)
       (setf (functional-entry-fun fun) nil)
       (setf (leaf-refs fun) nil)
       (delete-functional fun)))
-  (do-blocks (block component)
-    (delete-block block))
+  (clean-component component)
   (values))
+
+;;; Remove all pending blocks to be deleted. Return the nearest live
+;;; block after or equal to BLOCK.
+(defun clean-component (component &optional block)
+  (loop while (component-delete-blocks component)
+        ;; actual deletion of a block may queue new blocks
+        do (let ((current (pop (component-delete-blocks component))))
+             (when (eq block current)
+               (setq block (block-next block)))
+             (delete-block current)))
+  block)
 
 ;;; Convert code of the form
 ;;;   (FOO ... (FUN ...) ...)

Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- node.lisp	3 Oct 2003 02:51:56 -0000	1.47
+++ node.lisp	16 Nov 2003 10:19:14 -0000	1.48
@@ -372,7 +372,8 @@
   ;; has already been analyzed, but new references have been added by
   ;; inline expansion. Unlike NEW-FUNCTIONALS, this is not disjoint
   ;; from COMPONENT-LAMBDAS.
-  (reanalyze-functionals nil :type list))
+  (reanalyze-functionals nil :type list)
+  (delete-blocks nil :type list))
 (defprinter (component :identity t)
   name
   #!+sb-show id