;;; -*- Package: C -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /project/cmucl/cvsroot/src/compiler/loop.lisp,v 1.2 2010-03-19 15:19:00 rtoy Exp $")
;;; **********************************************************************
;;;
;;; Stuff to annotate the flow graph with information about the loops in it.
;;;
;;; Written by Rob MacLachlan
(in-package "C")
(intl:textdomain "cmucl")

;;; 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-outer-loop 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.
(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.
(defun loop-analyze (component)
  (let ((loop (component-outer-loop component)))
    (do-blocks (block component :both)
      (setf (block-loop block) nil))
    (setf (loop-inferiors loop) ())
    (setf (loop-blocks loop) 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-outer-loop 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.
(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.
(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.
(defun note-loop-head (head component)
  (let ((superior (find-superior head (component-outer-loop component))))
    (unless (eq (loop-head superior) head)
      (let ((result (make-loop :head head
			       :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.
(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.
(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.
(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))))
