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