0.8.5.42:

        * IR1-OPTIMIZE: whenever possible, delete all marked blocks.

diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 18dcaec..195226d 100644 (file)
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -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

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 3c67e0f..7238730 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -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)))
-
-          (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)))
-
-       (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))))))
+  (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)))))
+
+                 (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))
+
+              (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))

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 5929a32..3b9ebc3 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -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,17 +1261,27 @@
   (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 ...) ...)
 ;;; to

diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 693b1c4..8ac629d 100644 (file)
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -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

diff --git a/version.lisp-expr b/version.lisp-expr
index 6ff5a29..8789cc0 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.5.41"
+"0.8.5.42"