From 4f4b53d5ecf67d2b1aeb3eeb27241d1bcae8336c Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 8 Nov 1991 15:28:35 +0000
Subject: [PATCH] Added loop rotation optimization.

---
 compiler/control.lisp | 96 ++++++++++++++++++++++++++++++++-----------
 1 file changed, 71 insertions(+), 25 deletions(-)

diff --git a/compiler/control.lisp b/compiler/control.lisp
index 12a15fb3f..5bc2f7efa 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.5 1991/02/20 14:56:54 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/control.lisp,v 1.6 1991/11/08 15:28:35 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -39,14 +39,59 @@
   (undefined-value))
 
 
+;;; FIND-ROTATED-LOOP-HEAD  --  Internal
+;;;
+;;;    If Block looks like the head of a loop, then attempt to rotate it.  A
+;;; block looks like a loop head if the number of some predecessor is less than
+;;; the block's number.  Since blocks are numbered in reverse DFN, this will
+;;; identify loop heads in a reducible flow graph.
+;;;
+;;;    When we find a suspected loop head, we scan back from the tail to find
+;;; an alternate loop head.  This substitution preserves the correctness of the
+;;; walk, since the old head can be reached from the new head.  We determine
+;;; the new head by scanning as far back as we can find increasing block
+;;; numbers.  Beats me if this is in general optimal, but it works in simple
+;;; cases.
+;;;
+(defun find-rotated-loop-head (block)
+  (declare (type cblock block))
+  (let* ((num (block-number block))
+	 (env (block-environment block))
+	 (pred (dolist (pred (block-pred block) nil)
+		 (when (and (not (block-flag pred))
+			    (eq (block-environment pred) env)
+			    (< (block-number pred) num))
+		   (return pred)))))
+    (cond
+     (pred
+      (let ((current pred)
+	    (current-num (block-number pred)))
+	(block DONE
+	  (loop
+	    (dolist (pred (block-pred current) (return-from DONE))
+	      (when (eq pred block)
+		(return-from DONE))
+	      (when (and (not (block-flag pred))
+			 (eq (block-environment pred) env)
+			 (> (block-number pred) current-num))
+		(setq current pred   current-num (block-number pred))
+		(return)))))
+	(assert (not (block-flag current)))
+	current))
+     (t
+      block))))
+	  
+
 ;;; Control-Analyze-Block  --  Internal
 ;;;
-;;;    Do a graph walk linking blocks into the emit order as we go.  We treat
-;;; blocks ending in tail local calls specially.  We can't walked the called
-;;; function immediately, since it is in a different function and we must keep
-;;; the code for a function contiguous.   Instead, we return the function that
-;;; we want to call so that it can be walked as soon as possible, which is
-;;; hopefully immediately.
+;;;    Do a graph walk linking blocks into the emit order as we go.  We call
+;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
+;;;
+;;;    We treat blocks ending in tail local calls specially.  We can't walked
+;;; the called function immediately, since it is in a different function and we
+;;; must keep the code for a function contiguous.  Instead, we return the
+;;; function that we want to call so that it can be walked as soon as possible,
+;;; which is hopefully immediately.
 ;;;
 ;;;    If any of the recursive calls ends in a tail local call, then we return
 ;;; the last such function, since it is the only one we can possibly drop
@@ -56,22 +101,23 @@
 (defun control-analyze-block (block tail)
   (declare (type cblock block) (type ir2-block tail))
   (unless (block-flag 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))
-
-    (let ((last (block-last block)))
-      (cond ((and (combination-p last) (node-tail-p last)
-		  (eq (basic-combination-kind last) :local))
-	     (combination-lambda last))
-	    (t
-	     (let ((fun nil))
-	       (dolist (succ (block-succ block))
-		 (let ((res (control-analyze-block succ tail)))
-		   (when res (setq fun res))))
-	       fun))))))
+    (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))
+      
+      (let ((last (block-last block)))
+	(cond ((and (combination-p last) (node-tail-p last)
+		    (eq (basic-combination-kind last) :local))
+	       (combination-lambda last))
+	      (t
+	       (let ((fun nil))
+		 (dolist (succ (block-succ block))
+		   (let ((res (control-analyze-block succ tail)))
+		     (when res (setq fun res))))
+		 fun)))))))
 
 
 ;;; CONTROL-ANALYZE-1-FUN  --  Internal
@@ -83,7 +129,7 @@
 ;;; will never reach the bind block, so we will always get to insert it at the
 ;;; beginning.
 ;;;
-;;;    If the talk from the bind node encountered a tail local call, then we
+;;;    If the walk from the bind node encountered a tail local call, then we
 ;;; 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.
 ;;;
@@ -111,7 +157,7 @@
 ;;;
 ;;;    When we are done, we delete all blocks that weren't reached during our
 ;;; walk.  This allows IR2 phases to assume that all IR1 blocks in the DFO have
-;;; valid IR2 blocks in their Info.  We delete all deleted blocks from the
+;;; valid IR2 blocks in their Info.  We remove all deleted blocks from the
 ;;; IR2-COMPONENT VALUES-RECEIVERS so that stack analysis won't get confused.
 ;;;
 (defun control-analyze (component)
-- 
GitLab