From bf6b4a00b241b702ceda097bd8c5ec43aec0dbe8 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 26 Oct 2003 17:31:25 +0000 Subject: [PATCH] * src/compiler/eval-comp.lisp (compile-for-eval): Delete unreachable blocks, similar to ir1-optimize, which we don't call. This simplifies things by reducing the differences between "normal" compilation and compiling for interpretation. * src/compiler/ir1util.lisp (block-unreachable-p): New function. (delete-lambda): Mark return blocks for deletion again. * src/compiler/ir1opt.lisp (ir1-optimize): Use block-unreachable-p. Delete unreachable blocks after the loop. --- compiler/eval-comp.lisp | 11 ++++++++-- compiler/ir1opt.lisp | 47 ++++++++++++++++++++--------------------- compiler/ir1util.lisp | 12 ++++++++++- 3 files changed, 43 insertions(+), 27 deletions(-) diff --git a/compiler/eval-comp.lisp b/compiler/eval-comp.lisp index 6f838eadf..9d441f762 100644 --- a/compiler/eval-comp.lisp +++ b/compiler/eval-comp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval-comp.lisp,v 1.35 2003/08/05 15:50:28 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval-comp.lisp,v 1.36 2003/10/26 17:31:25 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -90,7 +90,7 @@ (*all-components* (list component))) (local-call-analyze component))) (multiple-value-bind (components top-components) - (find-initial-dfo lambdas) + (find-initial-dfo lambdas) (let ((*all-components* (append components top-components))) (when *check-consistency* (check-ir1-consistency *all-components*)) @@ -98,6 +98,13 @@ ;; This DOLIST body comes from the beginning of ;; COMPILE-COMPONENT. (dolist (component *all-components*) + ;; + ;; Since we don't call IR1-OPTIMIZE, delete + ;; unreachable blocks here. + (do-blocks (block component) + (when (block-unreachable-p block) + (delete-block block))) + (ir1-finalize component) (let ((*compile-component* component)) (environment-analyze component)) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index 6bbfb2d29..fa681cc40 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.81 2003/10/13 09:57:10 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.82 2003/10/26 17:31:25 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -293,9 +293,7 @@ (setf (component-reoptimize component) nil) (do-blocks (block component) (cond - ((or (block-delete-p block) - (null (block-pred block)) - (eq (functional-kind (block-home-lambda block)) :deleted)) + ((block-unreachable-p block) (delete-block block)) (t (loop @@ -306,30 +304,31 @@ (let ((last (block-last block))) (typecase last (cif - ;; - ;; Don't flush an if-test if it requires a type check. - (cond ((memq (continuation-type-check (if-test last)) - '(nil :deleted)) - (flush-dest (if-test last)) - (when (unlink-node last) (return))) - (t - (return)))) + (let ((if-test (if-test last))) + ;; Don't flush an if-test if it requires a type check. + (unless (memq (continuation-type-check if-test) '(nil :deleted)) + (return)) + (flush-dest if-test) + (when (unlink-node last) + (return)))) (exit - (when (maybe-delete-exit last) (return))))) + (when (maybe-delete-exit last) + (return))))) (unless (join-successor-if-possible block) (return))) - - (when (and (block-reoptimize block) (block-component block)) - (assert (not (block-delete-p block))) - (ir1-optimize-block block)) - - (when (and (block-flush-p block) (block-component block)) - (assert (not (block-delete-p block))) - (flush-dead-code block))))) - - (undefined-value)) - + ;; + ;; Block-Component is nil for deleted blocks. + (when (block-component block) + (cond ((block-unreachable-p block) + (delete-block block)) + (t + (when (block-reoptimize block) + (ir1-optimize-block block)) + (when (and (block-flush-p block) + (block-component block)) + (flush-dead-code block)))))))) + (values)) ;;; IR1-Optimize-Block -- Internal ;;; diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index d65c488fe..72d1fd2a0 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.99 2003/10/21 13:09:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.100 2003/10/26 17:31:25 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -336,6 +336,15 @@ (lambda-environment (node-home-lambda (block-last block)))) +;;; +;;; Value is true if Block in unreachable and thus can be deleted. +;;; +(defun block-unreachable-p (block) + (declare (type cblock block)) + (or (block-delete-p block) + (null (block-pred block)) + (eq (functional-kind (block-home-lambda block)) :deleted))) + ;;; SOURCE-PATH-TLF-NUMBER -- Interface ;;; ;;; Return the Top Level Form number of path, i.e. the ordinal number of @@ -772,6 +781,7 @@ (let ((return-block (node-block return))) (when (and return-block (not (block-delete-p return-block))) + (mark-for-deletion return-block) (unlink-blocks return-block (component-tail component))))) (setf (component-reanalyze component) t) (let ((tails (lambda-tail-set leaf))) -- GitLab