summaryrefslogtreecommitdiff
path: root/module/language/cps/rotate-loops.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/rotate-loops.scm')
-rw-r--r--module/language/cps/rotate-loops.scm234
1 files changed, 234 insertions, 0 deletions
diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm
new file mode 100644
index 000000000..355a8189f
--- /dev/null
+++ b/module/language/cps/rotate-loops.scm
@@ -0,0 +1,234 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Rotate loops so that they end with conditional jumps, if possible.
+;;; The result goes from:
+;;;
+;;; loop:
+;;; if x < 5 goto done;
+;;; x = x + 1;
+;;; goto loop;
+;;; done:
+;;;
+;;; if x < 5 goto done;
+;;; loop:
+;;; x = x + 1;
+;;; if x < 5 goto done;
+;;; done:
+;;;
+;;; It's more code but there are fewer instructions in the body. Note
+;;; that this transformation isn't guaranteed to produce a loop that
+;;; ends in a conditional jump, because usually your loop has some state
+;;; that it's shuffling around and for now that shuffle is reified with
+;;; the test, not the loop header. Alack.
+;;;
+;;; Implementation-wise, things are complicated by values flowing out of
+;;; the loop. We actually perform this transformation only on loops
+;;; that have a single exit continuation, so that we define values
+;;; flowing out in one place. We rename the loop variables in two
+;;; places internally: one for the peeled comparison, and another for
+;;; the body. The loop variables' original names are then bound in a
+;;; join continuation for use by successor code.
+;;;
+;;; Code:
+
+(define-module (language cps rotate-loops)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:use-module (language cps with-cps)
+ #:export (rotate-loops))
+
+(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
+ (intset-subtract (intmap-ref succs label) scc))
+ exits
+ (intset-add exits label)))
+ scc
+ empty-intset))
+
+(define (find-entry scc preds)
+ (trivial-intset (find-exits scc preds)))
+
+(define (rotate-loop cps entry-label body-labels succs preds back-edges)
+ (match (intmap-ref cps entry-label)
+ ((and entry-cont
+ ($ $kargs entry-names entry-vars
+ ($ $branch entry-kf entry-kt entry-src
+ entry-op entry-param entry-args)))
+ (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))
+ (join-cont (build-cont
+ ($kargs entry-names entry-vars
+ ($continue exit entry-src ($values ())))))
+ (cps (intmap-add! cps join-label join-cont)))
+ (define (make-fresh-vars)
+ (map (lambda (_) (fresh-var)) entry-vars))
+ (define (make-trampoline k src values)
+ (build-cont ($kargs () () ($continue k src ($values values)))))
+ (define (rename-var var replacements)
+ "If VAR refers to a member of ENTRY-VARS, replace with a
+corresponding var from REPLACEMENTS; otherwise return VAR."
+ (match (list-index entry-vars var)
+ (#f var)
+ (idx (list-ref replacements idx))))
+ (define (rename-vars vars replacements)
+ (map (lambda (var) (rename-var var replacements)) vars))
+ (define (rename-term term replacements)
+ (define (rename arg) (rename-var arg replacements))
+ (define (rename* arg) (rename-vars arg replacements))
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src
+ ,(rewrite-exp exp
+ ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code)) ,exp)
+ (($ $values args)
+ ($values ,(rename* args)))
+ (($ $call proc args)
+ ($call (rename proc) ,(rename* args)))
+ (($ $callk k proc args)
+ ($callk k (rename proc) ,(rename* args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(rename* args))))))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt src op param ,(rename* args)))
+ (($ $prompt k kh src escape? tag)
+ ($prompt k kh src escape? (rename tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(rename* args)))))
+ (define (attach-trampoline cps label src names vars args)
+ (with-cps cps
+ (letk ktramp-out ,(make-trampoline join-label src args))
+ (letk ktramp-in ,(make-trampoline new-entry-label src args))
+ (setk label
+ ($kargs names vars
+ ($branch (if exit-if-true? ktramp-in ktramp-out)
+ (if exit-if-true? ktramp-out ktramp-in)
+ entry-src
+ entry-op entry-param ,(rename-vars entry-args args))))))
+ ;; Rewrite the targets of the entry branch to go to
+ ;; trampolines. One will pass values out of the loop, and
+ ;; one will pass values into the loop.
+ (let* ((pre-header-vars (make-fresh-vars))
+ (body-vars (make-fresh-vars))
+ (cps (attach-trampoline cps entry-label entry-src
+ entry-names pre-header-vars
+ pre-header-vars))
+ (new-entry-cont (build-cont
+ ($kargs entry-names body-vars
+ ,(match (intmap-ref cps new-entry-label)
+ (($ $kargs () () term) term)))))
+ (cps (intmap-replace! cps new-entry-label new-entry-cont)))
+ (intset-fold
+ (lambda (label cps)
+ (cond
+ ((intset-ref back-edges label)
+ (match (intmap-ref cps label)
+ (($ $kargs names vars term)
+ (match (rename-term term body-vars)
+ (($ $continue _ src ($ $values args))
+ (attach-trampoline cps label src names vars args))
+ (($ $continue _ src 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 setk.
+ (cps (intmap-add! cps bind-label #f)))
+ (attach-trampoline cps bind-label src
+ entry-names args args)))))))
+ ((intset-ref loop-exits label)
+ (match (intmap-ref cps label)
+ (($ $kargs names vars ($ $branch kf kt src op param args))
+ (with-cps cps
+ (letk ktramp-out ,(make-trampoline join-label src body-vars))
+ (setk label
+ ($kargs names vars
+ ($branch (if (eqv? kf exit) ktramp-out kf)
+ (if (eqv? kt exit) ktramp-out kt)
+ src
+ op param ,(rename-vars args body-vars))))))))
+ (else
+ (match (intmap-ref cps label)
+ (($ $kargs names vars term)
+ (with-cps cps
+ (setk label ($kargs names vars
+ ,(rename-term term body-vars)))))
+ (($ $kreceive) cps)))))
+ (intset-remove body-labels entry-label)
+ cps))))))
+
+(define (rotate-loops-in-function kfun body cps)
+ (define (can-rotate? edges)
+ (intset-fold (lambda (label rotate?)
+ (match (intmap-ref cps label)
+ (($ $kreceive) #f)
+ (($ $kargs _ _ ($ $branch)) #f)
+ (($ $kargs _ _ ($ $continue)) rotate?)))
+ edges #t))
+ (let* ((succs (compute-successors cps kfun))
+ (preds (invert-graph succs)))
+ (intmap-fold
+ (lambda (id scc cps)
+ (cond
+ ((trivial-intset scc) cps)
+ ((find-entry scc preds)
+ => (lambda (entry)
+ (let ((back-edges (intset-intersect scc
+ (intmap-ref preds entry))))
+ (if (and (can-rotate? back-edges)
+ (trivial-intset
+ (intset-subtract (intmap-ref succs entry) scc))
+ (trivial-intset (loop-successors scc succs))
+ (match (intmap-ref cps entry)
+ ;; Can't rotate $prompt out of loop header.
+ (($ $kargs _ _ ($ $prompt)) #f)
+ (_ #t)))
+ ;; Loop header is an exit, and there is only one
+ ;; exit continuation. Loop header isn't a prompt,
+ ;; so it must be a conditional branch and only one
+ ;; successor is an exit. The values flowing out of
+ ;; the loop are the loop variables.
+ (rotate-loop cps entry scc succs preds back-edges)
+ cps))))
+ (else cps)))
+ (compute-strongly-connected-components succs kfun)
+ cps)))
+
+(define (rotate-loops cps)
+ (persistent-intmap
+ (with-fresh-name-state cps
+ (intmap-fold rotate-loops-in-function
+ (compute-reachable-functions cps)
+ cps))))