LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/language/cps/reify-primitives.scm

@@ -0,0 +1,179 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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:
+;;;
+;;; A pass to reify lone $prim's that were never folded into a
+;;; $primcall, and $primcall's to primitives that don't have a
+;;; corresponding VM op.
+;;;
+;;; Code:
+
+(define-module (language cps reify-primitives)
+  #:use-module (ice-9 match)
+  #:use-module (language cps)
+  #:use-module (language cps utils)
+  #:use-module (language cps with-cps)
+  #:use-module (language cps primitives)
+  #:use-module (language cps intmap)
+  #:use-module (language bytecode)
+  #:export (reify-primitives))
+
+(define (module-box cps src module name public? bound? val-proc)
+  (with-cps cps
+    (letv box)
+    (let$ body (val-proc box))
+    (letk kbox ($kargs ('box) (box) ,body))
+    ($ (with-cps-constants ((module module)
+                            (name name)
+                            (public? public?)
+                            (bound? bound?))
+         (build-term ($continue kbox src
+                       ($primcall 'cached-module-box
+                                  (module name public? bound?))))))))
+
+(define (primitive-module name)
+  (case name
+    ((bytevector?
+      bytevector-length
+
+      bytevector-u8-ref bytevector-u8-set!
+      bytevector-s8-ref bytevector-s8-set!
+
+      bytevector-u16-ref bytevector-u16-set!
+      bytevector-u16-native-ref bytevector-u16-native-set!
+      bytevector-s16-ref bytevector-s16-set!
+      bytevector-s16-native-ref bytevector-s16-native-set!
+
+      bytevector-u32-ref bytevector-u32-set!
+      bytevector-u32-native-ref bytevector-u32-native-set!
+      bytevector-s32-ref bytevector-s32-set!
+      bytevector-s32-native-ref bytevector-s32-native-set!
+
+      bytevector-u64-ref bytevector-u64-set!
+      bytevector-u64-native-ref bytevector-u64-native-set!
+      bytevector-s64-ref bytevector-s64-set!
+      bytevector-s64-native-ref bytevector-s64-native-set!
+
+      bytevector-ieee-single-ref bytevector-ieee-single-set!
+      bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+      bytevector-ieee-double-ref bytevector-ieee-double-set!
+      bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
+     '(rnrs bytevectors))
+    ((atomic-box?
+      make-atomic-box atomic-box-ref atomic-box-set!
+      atomic-box-swap! atomic-box-compare-and-swap!)
+     '(ice-9 atomic))
+    ((current-thread) '(ice-9 threads))
+    ((class-of) '(oop goops))
+    ((u8vector-ref
+      u8vector-set! s8vector-ref s8vector-set!
+      u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+      u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+      u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+      f32vector-ref f32vector-set! f64vector-ref f64vector-set!)
+     '(srfi srfi-4))
+    (else '(guile))))
+
+(define (primitive-ref cps name k src)
+  (module-box cps src (primitive-module name) name #f #t
+              (lambda (cps box)
+                (with-cps cps
+                  (build-term
+                    ($continue k src ($primcall 'box-ref (box))))))))
+
+(define (builtin-ref cps idx k src)
+  (with-cps cps
+    ($ (with-cps-constants ((idx idx))
+         (build-term
+           ($continue k src ($primcall 'builtin-ref (idx))))))))
+
+(define (reify-clause cps ktail)
+  (with-cps cps
+    (letv throw)
+    (let$ throw-body
+          (with-cps-constants ((wna 'wrong-number-of-args)
+                               (false #f)
+                               (str "Wrong number of arguments")
+                               (eol '()))
+            (build-term
+              ($continue ktail #f
+                ($call throw (wna false str eol false))))))
+    (letk kthrow ($kargs ('throw) (throw) ,throw-body))
+    (let$ body (primitive-ref 'throw kthrow #f))
+    (letk kbody ($kargs () () ,body))
+    (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
+    kclause))
+
+;; A $kreceive continuation should have only one predecessor.
+(define (uniquify-receive cps k)
+  (match (intmap-ref cps k)
+    (($ $kreceive ($ $arity req () rest () #f) kargs)
+     (with-cps cps
+       (letk k ($kreceive req rest kargs))
+       k))
+    (_
+     (with-cps cps k))))
+
+(define (reify-primitives cps)
+  (define (visit-cont label cont cps)
+    (define (resolve-prim cps name k src)
+      (cond
+       ((builtin-name->index name)
+        => (lambda (idx) (builtin-ref cps idx k src)))
+       (else
+        (primitive-ref cps name k src))))
+    (match cont
+      (($ $kfun src meta self tail #f)
+       (with-cps cps
+         (let$ clause (reify-clause tail))
+         (setk label ($kfun src meta self tail clause))))
+      (($ $kargs names vars ($ $continue k src ($ $prim name)))
+       (with-cps cps
+         (let$ k (uniquify-receive k))
+         (let$ body (resolve-prim name k src))
+         (setk label ($kargs names vars ,body))))
+      (($ $kargs names vars
+          ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc))))
+       (with-cps cps
+         (setk label ($kargs names vars ($continue k src ($call proc ()))))))
+      (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
+       (if (or (prim-instruction name) (branching-primitive? name))
+           ;; Assume arities are correct.
+           cps
+           (with-cps cps
+             (letv proc)
+             (let$ k (uniquify-receive k))
+             (letk kproc ($kargs ('proc) (proc)
+                           ($continue k src ($call proc args))))
+             (let$ body (resolve-prim name kproc src))
+             (setk label ($kargs names vars ,body)))))
+      (($ $kargs names vars ($ $continue k src ($ $call proc args)))
+       (with-cps cps
+         (let$ k (uniquify-receive k))
+         (setk label ($kargs names vars
+                       ($continue k src ($call proc args))))))
+      (($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
+       (with-cps cps
+         (let$ k (uniquify-receive k))
+         (setk label ($kargs names vars
+                       ($continue k src ($callk k* proc args))))))
+      (_ cps)))
+
+  (with-fresh-name-state cps
+    (persistent-intmap (intmap-fold visit-cont cps cps))))

data/share/guile/2.2/language/cps/renumber.scm

@@ -0,0 +1,217 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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:
+;;;
+;;; A pass to renumber variables and continuation labels so that they
+;;; are contiguous within each function and, in the case of labels,
+;;; topologically sorted.
+;;;
+;;; Code:
+
+(define-module (language cps renumber)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (language cps)
+  #:use-module (language cps utils)
+  #:use-module (language cps intset)
+  #:use-module (language cps intmap)
+  #:export (renumber))
+
+(define* (compute-tail-path-lengths conts kfun preds)
+  (define (add-lengths labels lengths length)
+    (intset-fold (lambda (label lengths)
+                   (intmap-add! lengths label length))
+                 labels
+                 lengths))
+  (define (compute-next labels lengths)
+    (intset-fold (lambda (label labels)
+                   (fold1 (lambda (pred labels)
+                            (if (intmap-ref lengths pred (lambda (_) #f))
+                                labels
+                                (intset-add! labels pred)))
+                          (intmap-ref preds label)
+                          labels))
+                 labels
+                 empty-intset))
+  (define (visit labels lengths length)
+    (let ((lengths (add-lengths labels lengths length)))
+      (values (compute-next labels lengths) lengths (1+ length))))
+  (match (intmap-ref conts kfun)
+    (($ $kfun src meta self tail clause)
+     (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
+
+;; Topologically sort the continuation tree starting at k0, using
+;; reverse post-order numbering.
+(define (sort-labels-locally conts k0 path-lengths)
+  (define (visit-kf-first? kf kt)
+    ;; Visit the successor of a branch with the shortest path length to
+    ;; the tail first, so that if the branches are unsorted, the longer
+    ;; path length will appear first.  This will move a loop exit out of
+    ;; a loop.
+    (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
+          (kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
+      (if kt-len
+          (or (not kf-len) (< kf-len kt-len)
+              ;; If the path lengths are the same, preserve original
+              ;; order to avoid squirreliness.
+              (and (= kf-len kt-len) (< kt kf)))
+          (if kf-len #f (< kt kf)))))
+  (let ((order '())
+        (visited empty-intset))
+    (let visit ((k k0) (order '()) (visited empty-intset))
+      (define (visit2 k0 k1 order visited)
+        (let-values (((order visited) (visit k0 order visited)))
+          (visit k1 order visited)))
+      (if (intset-ref visited k)
+          (values order visited)
+          (let ((visited (intset-add visited k)))
+            (call-with-values
+                (lambda ()
+                  (match (intmap-ref conts k)
+                    (($ $kargs names syms ($ $continue k src exp))
+                     (match exp
+                       (($ $prompt escape? tag handler)
+                        (visit2 k handler order visited))
+                       (($ $branch kt)
+                        (if (visit-kf-first? k kt)
+                            (visit2 k kt order visited)
+                            (visit2 kt k order visited)))
+                       (_
+                        (visit k order visited))))
+                    (($ $kreceive arity k) (visit k order visited))
+                    (($ $kclause arity kbody kalt)
+                     (if kalt
+                         (visit2 kalt kbody order visited)
+                         (visit kbody order visited)))
+                    (($ $kfun src meta self tail clause)
+                     (if clause
+                         (visit2 tail clause order visited)
+                         (visit tail order visited)))
+                    (($ $ktail) (values order visited))))
+              (lambda (order visited)
+                ;; Add k to the reverse post-order.
+                (values (cons k order) visited))))))))
+
+(define (compute-renaming conts kfun)
+  ;; labels := old -> new
+  ;; vars := old -> new
+  (define *next-label* -1)
+  (define *next-var* -1)
+  (define (rename-label label labels)
+    (set! *next-label* (1+ *next-label*))
+    (intmap-add! labels label *next-label*))
+  (define (rename-var sym vars)
+    (set! *next-var* (1+ *next-var*))
+    (intmap-add! vars sym *next-var*))
+  (define (rename label labels vars)
+    (values (rename-label label labels)
+            (match (intmap-ref conts label)
+              (($ $kargs names syms exp)
+               (fold1 rename-var syms vars))
+              (($ $kfun src meta self tail clause)
+               (rename-var self vars))
+              (_ vars))))
+  (define (maybe-visit-fun kfun labels vars)
+    (if (intmap-ref labels kfun (lambda (_) #f))
+        (values labels vars)
+        (visit-fun kfun labels vars)))
+  (define (visit-nested-funs k labels vars)
+    (match (intmap-ref conts k)
+      (($ $kargs names syms ($ $continue k src ($ $fun kfun)))
+       (visit-fun kfun labels vars))
+      (($ $kargs names syms ($ $continue k src ($ $rec names* syms*
+                                                  (($ $fun kfun) ...))))
+       (fold2 visit-fun kfun labels vars))
+      (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree)))
+       ;; Closures with zero free vars get copy-propagated so it's
+       ;; possible to already have visited them.
+       (maybe-visit-fun kfun labels vars))
+      (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
+       ;; Well-known functions never have a $closure created for them
+       ;; and are only referenced by their $callk call sites.
+       (maybe-visit-fun kfun labels vars))
+      (_ (values labels vars))))
+  (define (visit-fun kfun labels vars)
+    (let* ((preds (compute-predecessors conts kfun))
+           (path-lengths (compute-tail-path-lengths conts kfun preds))
+           (order (sort-labels-locally conts kfun path-lengths)))
+      ;; First rename locally, then recurse on nested functions.
+      (let-values (((labels vars) (fold2 rename order labels vars)))
+        (fold2 visit-nested-funs order labels vars))))
+  (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
+    (values (persistent-intmap labels) (persistent-intmap vars))))
+
+(define* (renumber conts #:optional (kfun 0))
+  (let-values (((label-map var-map) (compute-renaming conts kfun)))
+    (define (rename-label label) (intmap-ref label-map label))
+    (define (rename-var var) (intmap-ref var-map var))
+    (define (rename-exp exp)
+      (rewrite-exp exp
+        ((or ($ $const) ($ $prim)) ,exp)
+        (($ $closure k nfree)
+         ($closure (rename-label k) nfree))
+        (($ $fun body)
+         ($fun (rename-label body)))
+        (($ $rec names vars funs)
+         ($rec names (map rename-var vars) (map rename-exp funs)))
+        (($ $values args)
+         ($values ,(map rename-var args)))
+        (($ $call proc args)
+         ($call (rename-var proc) ,(map rename-var args)))
+        (($ $callk k proc args)
+         ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
+        (($ $branch kt exp)
+         ($branch (rename-label kt) ,(rename-exp exp)))
+        (($ $primcall name args)
+         ($primcall name ,(map rename-var args)))
+        (($ $prompt escape? tag handler)
+         ($prompt escape? (rename-var tag) (rename-label handler)))))
+    (define (rename-arity arity)
+      (match arity
+        (($ $arity req opt rest () aok?)
+         arity)
+        (($ $arity req opt rest kw aok?)
+         (match kw
+           (() arity)
+           (((kw kw-name kw-var) ...)
+            (let ((kw (map list kw kw-name (map rename-var kw-var))))
+              (make-$arity req opt rest kw aok?)))))))
+    (persistent-intmap
+     (intmap-fold
+      (lambda (old-k new-k out)
+        (intmap-add!
+         out
+         new-k
+         (rewrite-cont (intmap-ref conts old-k)
+                       (($ $kargs names syms ($ $continue k src exp))
+                        ($kargs names (map rename-var syms)
+                          ($continue (rename-label k) src ,(rename-exp exp))))
+                       (($ $kreceive ($ $arity req () rest () #f) k)
+                        ($kreceive req rest (rename-label k)))
+                       (($ $ktail)
+                        ($ktail))
+                       (($ $kfun src meta self tail clause)
+                        ($kfun src meta (rename-var self) (rename-label tail)
+                          (and clause (rename-label clause))))
+                       (($ $kclause arity body alternate)
+                        ($kclause ,(rename-arity arity) (rename-label body)
+                                  (and alternate (rename-label alternate)))))))
+      label-map
+      empty-intmap))))

data/share/guile/2.2/language/cps/rotate-loops.scm

@@ -0,0 +1,239 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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)
+  #: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
+             ($ $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))
+            (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 (replace-exit k trampoline)
+         (if (eqv? k exit) trampoline k))
+       (define (rename-exp exp vars)
+         (define (rename-var var)
+           (match (list-index entry-vars var)
+             (#f var)
+             (idx (list-ref vars idx))))
+         (rewrite-exp exp
+           ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
+           (($ $values args)
+            ($values ,(map rename-var args)))
+           (($ $call proc args)
+            ($call (rename-var proc) ,(map rename-var args)))
+           (($ $callk k proc args)
+            ($callk k (rename-var proc) ,(map rename-var args)))
+           (($ $branch kt ($ $values (arg)))
+            ($branch kt ($values ((rename-var arg)))))
+           (($ $branch kt ($ $primcall name args))
+            ($branch kt ($primcall name ,(map rename-var args))))
+           (($ $primcall name args)
+            ($primcall name ,(map rename-var args)))
+           (($ $prompt escape? tag handler)
+            ($prompt escape? (rename-var tag) handler))))
+       (define (attach-trampoline label src names vars args)
+         (let* ((trampoline-out-label (fresh-label))
+                (trampoline-out-cont
+                 (make-trampoline join-label src args))
+                (trampoline-in-label (fresh-label))
+                (trampoline-in-cont
+                 (make-trampoline new-entry-label src args))
+                (kf (if exit-if-true? trampoline-in-label trampoline-out-label))
+                (kt (if exit-if-true? trampoline-out-label trampoline-in-label))
+                (cont (build-cont
+                        ($kargs names vars
+                          ($continue kf entry-src
+                            ($branch kt ,(rename-exp entry-exp args))))))
+                (cps (intmap-replace! cps label cont))
+                (cps (intmap-add! cps trampoline-in-label trampoline-in-cont)))
+           (intmap-add! cps trampoline-out-label trampoline-out-cont)))
+       ;; 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 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 ($ $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))))))
+
+(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 _ _ ($ $continue _ _ exp))
+                      (match exp
+                        (($ $branch) #f)
+                        (_ 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 _ _ ($ $continue _ _ ($ $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))))