;;; NIL when we are done.
(defun find-dominators (component)
(let ((head (loop-head (component-outer-loop component)))
;;; NIL when we are done.
(defun find-dominators (component)
(let ((head (loop-head (component-outer-loop component)))
- (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))))
+ (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))))
(setf (loop-blocks loop) nil)
(do-blocks (block component)
(let ((number (block-number block)))
(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)))))
+ (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)))))
(dolist (sub-loop (loop-inferiors loop))
(dolist (exit (loop-exits sub-loop))
(dolist (succ (block-succ exit))
(dolist (sub-loop (loop-inferiors loop))
(dolist (exit (loop-exits sub-loop))
(dolist (succ (block-succ exit))
;;; recurse on its successors.
(defun find-blocks-from-here (block loop)
(when (and (not (block-loop block))
;;; recurse on its successors.
(defun find-blocks-from-here (block loop)
(when (and (not (block-loop block))
(setf (block-loop block) loop)
(shiftf (block-loop-next block) (loop-blocks loop) block)
(dolist (succ (block-succ block))
(setf (block-loop block) loop)
(shiftf (block-loop-next block) (loop-blocks loop) block)
(dolist (succ (block-succ block))
(let ((superior (find-superior head (component-outer-loop component))))
(unless (eq (loop-head superior) head)
(let ((result (make-loop :head head
(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)))))
+ :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)))))
- (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)))))
+ (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)))))
(when (eq (block-flag block) :good)
(setf (block-flag block) :done)
(unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
(when (eq (block-flag block) :good)
(setf (block-flag block) :done)
(unless (every #'(lambda (x) (member (block-flag x) '(:good :done)))
(note-loop-head block component))
(dolist (succ (block-succ block))
(find-strange-loop-segments succ component))))
(note-loop-head block component))
(dolist (succ (block-succ block))
(find-strange-loop-segments succ component))))