;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: loop.lisp,v 1.2 91/02/20 14:58:33 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;;    Stuff to annotate the flow graph with information about the loops in it.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

;;; Find-Dominators  --  Internal
;;;
;;;    Find the set of blocks that dominates each block in Component.  We
;;; assume that the Dominators for each block is initially NIL, which serves to
;;; represent the set of all blocks.  If a block is not reachable from an entry
;;; point, then its dominators will still be NIL when we are done.
;;;
(defun find-dominators (component)
  (let ((head (loop-head component))
	changed)
    (let ((set (make-sset)))
      (sset-adjoin head set)
      (setf (block-dominators head) set))
    (loop
     (setq changed nil)
     (do-blocks (block component :tail)
       (let ((dom (block-dominators block)))
	 (when dom (sset-delete block dom))
	 (dolist (pred (block-pred block))
	   (let ((pdom (block-dominators pred)))
	     (when pdom
	       (if dom
		   (when (sset-intersection dom pdom)
		     (setq changed t))
		   (setq dom (copy-sset pdom) changed t)))))
	 
	 (setf (block-dominators block) dom)
	 (when dom (sset-adjoin block dom))))
     (unless changed (return)))))


;;; Dominates-P  --  Internal
;;;
;;;    Return true if Block1 dominates Block2, false otherwise.
;;;
(proclaim '(function dominates-p (block block) boolean))
(defun dominates-p (block1 block2)
  (let ((set (block-dominators block2)))
    (if set
	(sset-member block1 set)
	t)))

;;; Loop-Analyze  --  Interface
;;;
;;;    Set up the Loop structures which describe the loops in the flow graph
;;; for Component.  We NIL out any existing loop information, and then scan
;;; through the blocks looking for blocks which are the destination of a
;;; retreating edge: an edge that goes backward in the DFO.  We then create
;;; Loop structures to describe the loops that have those blocks as their
;;; heads.  If find the head of a strange loop, then we do some graph walking
;;; to find the other segments in the strange loop.  After we have found the
;;; loop structure, we walk it to initialize the block lists.
;;;
(proclaim '(function loop-analyze (component) void))
(defun loop-analyze (component)
  (do-blocks (block component :both)
    (setf (block-loop block) nil))
  (setf (loop-inferiors component) ())
  (setf (loop-blocks component) nil)

  (do-blocks (block component)
    (let ((number (block-number block)))
      (dolist (pred (block-pred block))
	(when (<= (block-number pred) number)
	  (when (note-loop-head block component)
	    (clear-flags component)
	    (setf (block-flag block) :good)
	    (dolist (succ (block-succ block))
	      (find-strange-loop-blocks succ block))
	    (find-strange-loop-segments block component))
	  (return)))))

  (find-loop-blocks component))


;;; Find-Loop-Blocks  --  Internal
;;;
;;;    This function initializes the block lists for Loop and the loops nested
;;; within it.  We recursively descend into the loop nesting and place the
;;; blocks in the appropriate loop on the way up.  When we are done, we scan
;;; the blocks looking for exits.  An exit is always a block that has a
;;; successor which doesn't have a Loop assigned yet, since the target of the
;;; exit must be in a superior loop.
;;;
;;;    We find the blocks by doing a forward walk from the head of the loop and
;;; from any exits of nested loops.  The walks from inferior loop exits are
;;; necessary because the walks from the head terminate when they encounter a
;;; block in an inferior loop.
;;;
(proclaim '(function find-loop-blocks (loop) void))
(defun find-loop-blocks (loop)
  (dolist (sub-loop (loop-inferiors loop))
    (find-loop-blocks sub-loop))

  (find-blocks-from-here (loop-head loop) loop)
  (dolist (sub-loop (loop-inferiors loop))
    (dolist (exit (loop-exits sub-loop))
      (dolist (succ (block-succ exit))
	(find-blocks-from-here succ loop))))
  
  (collect ((exits))
    (dolist (sub-loop (loop-inferiors loop))
      (dolist (exit (loop-exits sub-loop))
	(dolist (succ (block-succ exit))
	  (unless (block-loop succ)
	    (exits exit)
	    (return)))))
    
    (do ((block (loop-blocks loop) (block-loop-next block)))
	((null block))
      (dolist (succ (block-succ block))
	(unless (block-loop succ)
	  (exits block)
	  (return))))
    
    (setf (loop-exits loop) (exits))))


;;; Find-Blocks-From-Here  --  Internal
;;;
;;;    This function does a graph walk to find the blocks directly within Loop
;;; that can be reached by a forward walk from Block.  If Block is already
;;; in a loop or is not dominated by the Loop-Head, then we return.  Otherwise,
;;; we add the block to the Blocks for Loop and recurse on its successors.
;;;
(proclaim '(function find-blocks-from-here (block loop) void))
(defun find-blocks-from-here (block loop)
  (when (and (not (block-loop block))
	     (dominates-p (loop-head loop) block))
    (setf (block-loop block) loop)
    (shiftf (block-loop-next block) (loop-blocks loop) block)
    (dolist (succ (block-succ block))
      (find-blocks-from-here succ loop))))


;;; Note-Loop-Head  --  Internal
;;;
;;;    Create a loop structure to describe the loop headed by the block Head.
;;; If there is one already, just return.  If some retreating edge into the
;;; head is from a block which isn't dominated by the head, then we have the
;;; head of a strange loop segment.  We return true if Head is part of a newly
;;; discovered strange loop.
;;;
(proclaim '(function note-loop-head (block component) void))
(defun note-loop-head (head component)
  (let ((superior (find-superior head component)))
    (unless (eq (loop-head superior) head)
      (let ((result (make-loop :head head  :component component  :kind :natural
			       :superior superior  :depth (1+ (loop-depth superior))))
	    (number (block-number head)))
	(push result (loop-inferiors superior))
	(dolist (pred (block-pred head))
	  (when (<= (block-number pred) number)
	    (if (dominates-p head pred)
		(push pred (loop-tail result))
		(setf (loop-kind result) :strange))))
	
	(eq (loop-kind result) :strange)))))


;;; Find-Superior  --  Internal
;;;
;;;    Find the loop which would be the superior of a loop headed by Head.  If
;;; there is already a loop with that head, then return that loop.
;;;
(proclaim '(function find-superior (block loop) loop))
(defun find-superior (head loop)
  (if (eq (loop-head loop) head)
      loop
      (dolist (inferior (loop-inferiors loop) loop)
	(when (dominates-p (loop-head inferior) head)
	  (return (find-superior head inferior))))))


;;; Find-Strange-Loop-Blocks  --  Internal
;;;
;;;    Do a graph walk to find the blocks in the strange loop which Head is in.
;;; Block is the block we are currently at and Component is the component we
;;; are in.  We do a walk forward from block, using only edges which are not
;;; back edges.  We return true if there is a path from Block to Head, false
;;; otherwise.  If the Block-Flag is true then we return.  We use two non-null
;;; values of Flag to indicate whether a path from the Block back to Head was
;;; found.
;;;
(proclaim '(function find-strange-loop-blocks (block block) boolean))
(defun find-strange-loop-blocks (block head)
  (let ((flag (block-flag block)))
    (cond (flag
	   (if (eq flag :good)
	       t
	       nil))
	  (t
	   (setf (block-flag block) :bad)
	   (unless (dominates-p block head)
	     (dolist (succ (block-succ block))
	       (when (find-strange-loop-blocks succ head)
		 (setf (block-flag block) :good))))
	   
	   (eq (block-flag block) :good)))))


;;; Find-Strange-Loop-Segments  --  Internal
;;;
;;;    Do a graph walk to find the segments in the strange loop that has Block
;;; in it.  We walk forward, looking only at blocks in the loop (flagged as
;;; :Good.)  Each block in the loop that has predecessors outside of the
;;; loop is the head of a segment.  We enter the Loop structures in Component.
;;;
(proclaim '(function find-strange-loop-segments (block component) void))
(defun find-strange-loop-segments (block component)
  (when (eq (block-flag block) :good)
    (setf (block-flag block) :done)
    (unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
		   (block-pred block))
      (note-loop-head block component))

    (dolist (succ (block-succ block))
      (find-strange-loop-segments succ component))))