From c3535bf67b82955401222bd0eb5625fb52a5fb66 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 21 Apr 1992 04:16:55 +0000
Subject: [PATCH] Changed to no longer assume it should be making ir2-blocks. 
 We now make some random subtype of block-annotation.  People who want to use
 control-analyze can :include block-annotation in their info structure, pass
 control-analyze the constructor function, and be happy campers.

---
 compiler/control.lisp | 78 ++++++++++++++++++++++++-------------------
 1 file changed, 44 insertions(+), 34 deletions(-)

diff --git a/compiler/control.lisp b/compiler/control.lisp
index f703a988b..e6023f15f 100644
--- a/compiler/control.lisp
+++ b/compiler/control.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/control.lisp,v 1.10 1991/12/11 16:48:42 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/control.lisp,v 1.11 1992/04/21 04:16:55 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -30,12 +30,12 @@
 ;;;    Insert Block in the emission order after the block After.
 ;;;
 (defun add-to-emit-order (block after)
-  (declare (type ir2-block block after))
-  (let ((next (ir2-block-next after)))
-    (setf (ir2-block-next after) block)
-    (setf (ir2-block-prev block) after)
-    (setf (ir2-block-next block) next)
-    (setf (ir2-block-prev next) block))
+  (declare (type block-annotation block after))
+  (let ((next (block-annotation-next after)))
+    (setf (block-annotation-next after) block)
+    (setf (block-annotation-prev block) after)
+    (setf (block-annotation-next block) next)
+    (setf (block-annotation-prev next) block))
   (undefined-value))
 
 
@@ -111,15 +111,16 @@
 ;;; in an error, NLX or tail full call.)  This is to discourage making error
 ;;; code the drop-through.
 ;;;
-(defun control-analyze-block (block tail)
-  (declare (type cblock block) (type ir2-block tail))
+(defun control-analyze-block (block tail block-info-constructor)
+  (declare (type cblock block) (type block-annotation tail))
   (unless (block-flag block)
     (let ((block (find-rotated-loop-head block)))
       (setf (block-flag block) t)
       (assert (and (block-component block) (not (block-delete-p block))))
       (add-to-emit-order (or (block-info block)
-			     (setf (block-info block) (make-ir2-block block)))
-			 (ir2-block-prev tail))
+			     (setf (block-info block)
+				   (funcall block-info-constructor block)))
+			 (block-annotation-prev tail))
       
       (let ((last (block-last block)))
 	(cond ((and (combination-p last) (node-tail-p last)
@@ -133,10 +134,11 @@
 		     (fun nil))
 		 (dolist (succ block-succ)
 		   (unless (eq (first (block-succ succ)) component-tail)
-		     (let ((res (control-analyze-block succ tail)))
+		     (let ((res (control-analyze-block
+				 succ tail block-info-constructor)))
 		       (when res (setq fun res)))))
 		 (dolist (succ block-succ)
-		   (control-analyze-block succ tail))
+		   (control-analyze-block succ tail block-info-constructor))
 		 fun)))))))
 
 
@@ -152,27 +154,31 @@
 ;;; start over again there to help the call drop through.  Of course, it will
 ;;; never get a drop-through if either function has NLX code.
 ;;;
-(defun control-analyze-1-fun (fun component)
+(defun control-analyze-1-fun (fun component block-info-constructor)
   (declare (type clambda fun) (type component component))
   (let* ((tail-block (block-info (component-tail component)))
-	 (prev-block (ir2-block-prev tail-block))
+	 (prev-block (block-annotation-prev tail-block))
 	 (bind-block (node-block (lambda-bind fun))))
     (unless (block-flag bind-block)
       (dolist (nlx (environment-nlx-info (lambda-environment fun)))
-	(control-analyze-block (nlx-info-target nlx) tail-block))
+	(control-analyze-block (nlx-info-target nlx) tail-block
+			       block-info-constructor))
       (cond
        ((block-flag bind-block)
-	(let* ((2block (block-info bind-block))
-	       (prev (ir2-block-prev 2block))
-	       (next (ir2-block-next 2block)))
-	  (setf (ir2-block-prev next) prev)
-	  (setf (ir2-block-next prev) next)
-	  (add-to-emit-order 2block prev-block)))
+	(let* ((block-note (block-info bind-block))
+	       (prev (block-annotation-prev block-note))
+	       (next (block-annotation-next block-note)))
+	  (setf (block-annotation-prev next) prev)
+	  (setf (block-annotation-next prev) next)
+	  (add-to-emit-order block-note prev-block)))
        (t
 	(let ((new-fun (control-analyze-block bind-block
-					      (ir2-block-next prev-block))))
+					      (block-annotation-next
+					       prev-block)
+					      block-info-constructor)))
 	  (when new-fun
-	    (control-analyze-1-fun new-fun component)))))))
+	    (control-analyze-1-fun new-fun component
+				   block-info-constructor)))))))
   (undefined-value))
 
   
@@ -187,32 +193,36 @@
 ;;; COMPONENT-REANALYZE.  We remove all deleted blocks from the IR2-COMPONENT
 ;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
 ;;;
-(defun control-analyze (component)
+(defun control-analyze (component block-info-constructor)
+  (declare (type component component)
+	   (type function block-info-constructor))
   (let* ((head (component-head component))
-	 (head-block (make-ir2-block head))
+	 (head-block (funcall block-info-constructor head))
 	 (tail (component-tail component))
-	 (tail-block (make-ir2-block tail)))
+	 (tail-block (funcall block-info-constructor tail)))
     (setf (block-info head) head-block)
     (setf (block-info tail) tail-block)
-    (setf (ir2-block-prev tail-block) head-block)
-    (setf (ir2-block-next head-block) tail-block)
+    (setf (block-annotation-prev tail-block) head-block)
+    (setf (block-annotation-next head-block) tail-block)
 
     (clear-flags component)
 
     (dolist (fun (component-lambdas component))
       (when (external-entry-point-p fun)
-	(control-analyze-1-fun fun component)))
+	(control-analyze-1-fun fun component block-info-constructor)))
 
     (dolist (fun (component-lambdas component))
-      (control-analyze-1-fun fun component))
+      (control-analyze-1-fun fun component block-info-constructor))
 
     (do-blocks (block component)
       (unless (block-flag block)
 	(delete-block block))))
 
   (let ((2comp (component-info component)))
-    (setf (ir2-component-values-receivers 2comp)
-	  (delete-if-not #'block-component
-			 (ir2-component-values-receivers 2comp))))
+    (when (ir2-component-p 2comp)
+      ;; If it's not an ir2-component, don't worry about it.
+      (setf (ir2-component-values-receivers 2comp)
+	    (delete-if-not #'block-component
+			   (ir2-component-values-receivers 2comp)))))
 
   (undefined-value))
-- 
GitLab