summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-07-25 11:03:59 +0200
committerAndy Wingo <wingo@pobox.com>2015-07-25 11:03:59 +0200
commite54fbff185786886b56f0438040c2a1d54363c6a (patch)
tree6bfdaf97825879ce3cac9d6399ed99259ef3ed92
parentee85e2969f623278e095c5facda4430b664a04aa (diff)
downloadguile-e54fbff185786886b56f0438040c2a1d54363c6a.tar.gz
Loop inversion with multiple exits
* module/language/cps/rotate-loops.scm (rotate-loop): Instead of restricting rotation to loops with just one exit node, restrict to loops with just one exit successor.
-rw-r--r--module/language/cps/rotate-loops.scm81
1 files changed, 54 insertions, 27 deletions
diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm
index 19ecf444c..c6b68bb32 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -66,6 +66,12 @@
(exits loop-exits)
(body loop-body))
+(define (loop-successors scc succs)
+ (intset-subtract (intset-fold (lambda (label exits)
+ (intset-union exits (intmap-ref succs label)))
+ scc empty-intset)
+ scc))
+
(define (find-exits scc succs)
(intset-fold (lambda (label exits)
(if (eq? empty-intset
@@ -84,6 +90,7 @@
($ $kargs entry-names entry-vars
($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp))))
(let* ((exit-if-true? (intset-ref body-labels entry-kf))
+ (loop-exits (find-exits body-labels succs))
(exit (if exit-if-true? entry-kt entry-kf))
(new-entry-label (if exit-if-true? entry-kf entry-kt))
(join-label (fresh-label))
@@ -149,31 +156,48 @@
(cps (intmap-replace! cps new-entry-label new-entry-cont)))
(intset-fold
(lambda (label cps)
- (if (intset-ref back-edges label)
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue _ src exp))
- (match (rename-exp exp body-vars)
- (($ $values args)
- (attach-trampoline label src names vars args))
- (exp
- (let* ((args (make-fresh-vars))
- (bind-label (fresh-label))
- (edge* (build-cont
- ($kargs names vars
- ($continue bind-label src ,exp))))
- (cps (intmap-replace! cps label edge*))
- ;; attach-trampoline uses intmap-replace!.
- (cps (intmap-add! cps bind-label #f)))
- (attach-trampoline bind-label src
- entry-names args args))))))
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (let ((cont (build-cont
- ($kargs names vars
- ($continue k src
- ,(rename-exp exp body-vars))))))
- (intmap-replace! cps label cont)))
- (($ $kreceive) cps))))
+ (cond
+ ((intset-ref back-edges label)
+ (match (intmap-ref cps label)
+ (($ $kargs names vars ($ $continue _ src exp))
+ (match (rename-exp exp body-vars)
+ (($ $values args)
+ (attach-trampoline label src names vars args))
+ (exp
+ (let* ((args (make-fresh-vars))
+ (bind-label (fresh-label))
+ (edge* (build-cont
+ ($kargs names vars
+ ($continue bind-label src ,exp))))
+ (cps (intmap-replace! cps label edge*))
+ ;; attach-trampoline uses intmap-replace!.
+ (cps (intmap-add! cps bind-label #f)))
+ (attach-trampoline bind-label src
+ entry-names args args)))))))
+ ((intset-ref loop-exits label)
+ (match (intmap-ref cps label)
+ (($ $kargs names vars
+ ($ $continue kf src ($ $branch kt exp)))
+ (let* ((trampoline-out-label (fresh-label))
+ (trampoline-out-cont
+ (make-trampoline join-label src body-vars))
+ (kf (if (eqv? kf exit) trampoline-out-label kf))
+ (kt (if (eqv? kt exit) trampoline-out-label kt))
+ (cont (build-cont
+ ($kargs names vars
+ ($continue kf src
+ ($branch kt ,(rename-exp exp body-vars))))))
+ (cps (intmap-replace! cps label cont)))
+ (intmap-add! cps trampoline-out-label trampoline-out-cont)))))
+ (else
+ (match (intmap-ref cps label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (let ((cont (build-cont
+ ($kargs names vars
+ ($continue k src
+ ,(rename-exp exp body-vars))))))
+ (intmap-replace! cps label cont)))
+ (($ $kreceive) cps)))))
(intset-remove body-labels entry-label)
cps))))))
@@ -198,8 +222,11 @@
(let ((back-edges (intset-intersect scc
(intmap-ref preds entry))))
(if (and (can-rotate? back-edges)
- (eqv? (trivial-intset (find-exits scc succs)) entry))
- ;; Loop header is the only exit. It must be a
+ (trivial-intset
+ (intset-subtract (intmap-ref succs entry) scc))
+ (trivial-intset (loop-successors scc succs)))
+ ;; Loop header is an exit, and there is only one
+ ;; exit continuation. Loop header must then be a
;; conditional branch and only one successor is an
;; exit. The values flowing out of the loop are the
;; loop variables.