From 0b525ddd5632801f52de54a633df6a2fe2f9620c Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 16 Nov 2003 10:19:13 +0000 Subject: [PATCH] 0.8.5.42: * IR1-OPTIMIZE: whenever possible, delete all marked blocks. --- src/compiler/dfo.lisp | 6 +-- src/compiler/ir1opt.lisp | 94 ++++++++++++++++++++++++--------------------- src/compiler/ir1util.lisp | 35 ++++++++++++++--- src/compiler/node.lisp | 3 +- version.lisp-expr | 2 +- 5 files changed, 84 insertions(+), 56 deletions(-) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 18dcaec..195226d 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4