Move build-cps-term and friends to (language cps)

* module/language/cps.scm (let-gensyms):
  (build-cps-cont, build-cps-call, build-cps-term): New public
  interfaces, factored out of (language tree-il compile-cps).

* module/language/tree-il/compile-cps.scm: Update.

2 files changed, 317 insertions, 292 deletions

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 29c688a0c..35cf43d6b 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -70,7 +70,13 @@
             make-$call make-$primcall make-$values make-$prompt
 
             parse-cps
-            unparse-cps))
+            unparse-cps
+
+            ;; Building macros.
+            let-gensyms
+            build-cps-term
+            build-cps-call
+            build-cps-cont))
 
 ;; FIXME: Use SRFI-99, when Guile adds it.
 (define-syntax define-record-type*
@@ -226,3 +232,91 @@
      `(prompt ,escape? ,tag ,handler))
     (_
      (error "unexpected cps" exp))))
+
+;; FIXME: Figure out how to evaluate this automatically when Emacs
+;; visits this buffer.
+;;
+;; (put 'let-gensyms 'scheme-indent-function 1)
+;; (put 'build-cps-term 'scheme-indent-function 0)
+;; (put 'build-cps-call 'scheme-indent-function 0)
+;; (put 'build-cps-cont 'scheme-indent-function 0)
+;; (put '$letk 'scheme-indent-function 1)
+;; (put '$letk* 'scheme-indent-function 1)
+;; (put '$letconst 'scheme-indent-function 1)
+;; (put '$continue 'scheme-indent-function 1)
+;; (put '$kargs 'scheme-indent-function 2)
+
+(define-syntax let-gensyms
+  (syntax-rules ()
+    ((_ (sym ...) body body* ...)
+     (let ((sym (gensym (symbol->string 'sym))) ...)
+       body body* ...))))
+
+(define-syntax build-arity
+  (syntax-rules (unquote)
+    ((_ (unquote exp)) exp)
+    ((_ (req opt rest kw allow-other-keys?))
+     (make-$arity req opt rest kw allow-other-keys?))))
+
+(define-syntax build-cont-body
+  (syntax-rules (unquote $kif $ktrunc $kargs $kentry)
+    ((_ (unquote exp))
+     exp)
+    ((_ ($kif kt kf))
+     (make-$kif kt kf))
+    ((_ ($ktrunc req rest kargs))
+     (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+    ((_ ($kargs (name ...) (sym ...) body))
+     (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
+    ((_ ($kargs names syms body))
+     (make-$kargs names syms (build-cps-term body)))
+    ((_ ($kentry arity cont))
+     (make-$kentry (build-arity arity) (build-cps-cont cont)))))
+
+(define-syntax build-cps-cont
+  (syntax-rules (unquote)
+    ((_ (unquote exp)) exp)
+    ((_ (k src cont)) (make-$cont src k (build-cont-body cont)))))
+
+(define-syntax build-cps-call
+  (syntax-rules (unquote
+                 $var $void $const $prim $fun $call $primcall $values $prompt)
+    ((_ (unquote exp)) exp)
+    ((_ ($var sym)) (make-$var sym))
+    ((_ ($void)) (make-$void))
+    ((_ ($const val)) (make-$const val))
+    ((_ ($prim name)) (make-$prim name))
+    ((_ ($fun meta self free (unquote entries)))
+     (make-$fun meta self free entries))
+    ((_ ($fun meta self free (entry ...)))
+     (make-$fun meta self free (list (build-cps-cont entry) ...)))
+    ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+    ((_ ($call proc args)) (make-$call proc args))
+    ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+    ((_ ($primcall name args)) (make-$primcall name args))
+    ((_ ($values (arg ...))) (make-$values (list arg ...)))
+    ((_ ($values args)) (make-$values args))
+    ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+
+(define-syntax build-cps-term
+  (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+    ((_ (unquote exp))
+     exp)
+    ((_ ($letk (cont ...) body))
+     (make-$letk (list (build-cps-cont cont) ...)
+                 (build-cps-term body)))
+    ((_ ($letk* () body))
+     (build-cps-term body))
+    ((_ ($letk* (cont conts ...) body))
+     (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
+    ((_ ($letconst () body))
+     (build-cps-term body))
+    ((_ ($letconst ((name sym val) tail ...) body))
+     (let-gensyms (kconst)
+       (build-cps-term
+         ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
+           ($continue kconst ($const val))))))
+    ((_ ($letrec names gensyms funs body))
+     (make-$letrec names gensyms funs (build-cps-term body)))
+    ((_ ($continue k exp))
+     (make-$continue k (build-cps-call exp)))))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index d77b9d4a5..236d46a04 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -47,98 +47,9 @@
                  tree-il-fold))
   #:export (compile-cps))
 
-;; (put 'build-cps 'scheme-indent-function 0)
-;; (put 'build-cps* 'scheme-indent-function 1)
-;; (put '$letk 'scheme-indent-function 1)
-;; (put '$letk* 'scheme-indent-function 1)
-;; (put '$letconst 'scheme-indent-function 1)
-;; (put '$continue 'scheme-indent-function 1)
-;; (put '$kargs 'scheme-indent-function 2)
 ;; (put 'convert-arg 'scheme-indent-function 1)
 ;; (put 'convert-args 'scheme-indent-function 1)
 
-(define-syntax build-cont
-  (syntax-rules (unquote $kif $ktrunc $kargs)
-    ((_ (unquote exp))
-     exp)
-    ((_ ($kif kt kf))
-     (make-$kif kt kf))
-    ((_ ($ktrunc req rest kargs))
-     (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
-    ((_ ($kargs (name ...) (sym ...) body))
-     (make-$kargs (list name ...) (list sym ...) (build-cps body)))
-    ((_ ($kargs names syms body))
-     (make-$kargs names syms (build-cps body)))))
-
-(define-syntax build-cont-decl
-  (syntax-rules (unquote)
-    ((_ (unquote exp)) exp)
-    ((_ (k src cont)) (make-$cont src k (build-cont cont)))))
-
-(define-syntax build-arity
-  (syntax-rules (unquote)
-    ((_ (unquote exp)) exp)
-    ((_ (req opt rest kw allow-other-keys?))
-     (make-$arity req opt rest kw allow-other-keys?))))
-
-(define-syntax build-fun-entry
-  (syntax-rules (unquote)
-    ((_ (unquote exp)) exp)
-    ((_ ($kentry k src arity cont-decl))
-     (make-$cont src k (make-$kentry (build-arity arity)
-                                     (build-cont-decl cont-decl))))))
-
-(define-syntax build-fun
-  (syntax-rules (unquote)
-    ((_ ($fun meta self free (unquote body)))
-     (make-$fun meta self free body))
-    ((_ ($fun meta self free (entry ...)))
-     (make-$fun meta self free (list (build-fun-entry entry) ...)))))
-
-(define-syntax build-call
-  (syntax-rules (unquote
-                 $var $void $const $prim $fun $call $primcall $values $prompt)
-    ((_ (unquote exp)) exp)
-    ((_ ($var sym)) (make-$var sym))
-    ((_ ($void)) (make-$void))
-    ((_ ($const val)) (make-$const val))
-    ((_ ($prim name)) (make-$prim name))
-    ((_ ($fun . args)) (build-fun ($fun . args)))
-    ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
-    ((_ ($call proc args)) (make-$call proc args))
-    ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
-    ((_ ($primcall name args)) (make-$primcall name args))
-    ((_ ($values (arg ...))) (make-$values (list arg ...)))
-    ((_ ($values args)) (make-$values args))
-    ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
-
-(define-syntax build-cps
-  (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
-    ((_ (unquote exp))
-     exp)
-    ((_ ($letk (cont-decl ...) body))
-     (make-$letk (list (build-cont-decl cont-decl) ...)
-                 (build-cps body)))
-    ((_ ($letk* () body))
-     (build-cps body))
-    ((_ ($letk* (cont-decl cont-decls ...) body))
-     (build-cps ($letk (cont-decl) ($letk* (cont-decls ...) body))))
-    ((_ ($letconst () body))
-     (build-cps body))
-    ((_ ($letconst ((name sym val) tail ...) body))
-     (build-cps* (kconst)
-       ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
-         ($continue kconst ($const val)))))
-    ((_ ($letrec names gensyms funs body))
-     (make-$letrec names gensyms funs (build-cps body)))
-    ((_ ($continue k exp)) (make-$continue k (build-call exp)))))
-
-(define-syntax build-cps*
-  (syntax-rules ()
-    ((_ (sym ...) form)
-     (let ((sym (gensym (symbol->string 'sym))) ...)
-      (build-cps form)))))
-
 ;; Guile's semantics are that a toplevel lambda captures a reference on
 ;; the current module, and that all contained lambdas use that module to
 ;; resolve toplevel variables.  This parameter tracks whether or not we
@@ -155,43 +66,47 @@
 (define current-topbox-scope (make-parameter #f))
 
 (define (toplevel-box src name bound? val-proc)
-  (build-cps* (name-sym bound?-sym kbox box)
-    ($letconst (('name name-sym name)
-                ('bound? bound?-sym bound?))
-      ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
-        ,(match (current-topbox-scope)
-           (#f
-            (build-cps
-              ($continue kbox
-                ($primcall 'resolve
-                           (name-sym bound?-sym)))))
-           (scope
-            (build-cps* (scope-sym)
-              ($letconst (('scope scope-sym scope))
+  (let-gensyms (name-sym bound?-sym kbox box)
+    (build-cps-term
+      ($letconst (('name name-sym name)
+                  ('bound? bound?-sym bound?))
+        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+          ,(match (current-topbox-scope)
+             (#f
+              (build-cps-term
                 ($continue kbox
-                  ($primcall 'cached-toplevel-box
-                             (scope-sym name-sym bound?-sym)))))))))))
+                  ($primcall 'resolve
+                             (name-sym bound?-sym)))))
+             (scope
+              (let-gensyms (scope-sym)
+                (build-cps-term
+                  ($letconst (('scope scope-sym scope))
+                    ($continue kbox
+                      ($primcall 'cached-toplevel-box
+                                 (scope-sym name-sym bound?-sym)))))))))))))
 
 (define (module-box src module name public? bound? val-proc)
-  (build-cps* (module-sym name-sym public?-sym bound?-sym kbox box)
-    ($letconst (('module module-sym module)
-                ('name name-sym name)
-                ('public? public?-sym public?)
-                ('bound? bound?-sym bound?))
-      ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
-        ($continue kbox
-          ($primcall 'cached-module-box
-                     (module-sym name-sym public?-sym bound?-sym)))))))
+  (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+    (build-cps-term
+      ($letconst (('module module-sym module)
+                  ('name name-sym name)
+                  ('public? public?-sym public?)
+                  ('bound? bound?-sym bound?))
+        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+          ($continue kbox
+            ($primcall 'cached-module-box
+                       (module-sym name-sym public?-sym bound?-sym))))))))
 
 (define (capture-toplevel-scope src scope k)
-  (build-cps* (module scope-sym kmodule)
-    ($letconst (('scope scope-sym scope))
-      ($letk ((kmodule src ($kargs ('module) (module)
-                             ($continue k
-                               ($primcall 'cache-current-module!
-                                          (module scope-sym))))))
-        ($continue kmodule
-          ($primcall 'current-module ()))))))
+  (let-gensyms (module scope-sym kmodule)
+    (build-cps-term
+      ($letconst (('scope scope-sym scope))
+        ($letk ((kmodule src ($kargs ('module) (module)
+                               ($continue k
+                                 ($primcall 'cache-current-module!
+                                            (module scope-sym))))))
+          ($continue kmodule
+            ($primcall 'current-module ())))))))
 
 (define (fold-formals proc seed arity gensyms inits)
   (match arity
@@ -233,11 +148,12 @@
   (define tc8-iflag 4)
   (define unbound-val 9)
   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
-  (build-cps* (unbound ktest)
-    ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
-      ($letk ((ktest src ($kif kt kf)))
-        ($continue ktest
-          ($primcall 'eq? (sym unbound)))))))
+  (let-gensyms (unbound ktest)
+    (build-cps-term
+      ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+        ($letk ((ktest src ($kif kt kf)))
+          ($continue ktest
+            ($primcall 'eq? (sym unbound))))))))
 
 (define (init-default-value name sym subst init body)
   (match (assq-ref subst sym)
@@ -245,20 +161,22 @@
      (let ((src (tree-il-src init)))
        (define (maybe-box k make-body)
          (if box?
-             (build-cps* (kbox phi)
-               ($letk ((kbox src ($kargs (name) (phi)
-                                   ($continue k ($primcall 'box (phi))))))
-                 ,(make-body kbox)))
+             (let-gensyms (kbox phi)
+               (build-cps-term
+                 ($letk ((kbox src ($kargs (name) (phi)
+                                     ($continue k ($primcall 'box (phi))))))
+                   ,(make-body kbox))))
              (make-body k)))
-       (build-cps* (knext kbound kunbound)
-         ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
-           ,(maybe-box
-             knext
-             (lambda (k)
-               (build-cps
-                 ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
-                         (kunbound src ($kargs () () ,(convert init k subst))))
-                   ,(unbound? src sym kunbound kbound)))))))))))
+       (let-gensyms (knext kbound kunbound)
+         (build-cps-term
+           ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+             ,(maybe-box
+               knext
+               (lambda (k)
+                 (build-cps-term
+                   ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
+                           (kunbound src ($kargs () () ,(convert init k subst))))
+                     ,(unbound? src sym kunbound kbound))))))))))))
 
 ;; exp k-name alist -> term
 (define (convert exp k subst)
@@ -268,16 +186,18 @@
       (($ <lexical-ref> src name sym)
        (match (assq-ref subst sym)
          ((box #t)
-          (build-cps* (kunboxed unboxed)
-            ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
-              ($continue kunboxed ($primcall 'box-ref (box))))))
+          (let-gensyms (kunboxed unboxed)
+            (build-cps-term
+              ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+                ($continue kunboxed ($primcall 'box-ref (box)))))))
          ((subst #f) (k subst))
          (#f (k sym))))
       (else
        (let ((src (tree-il-src exp)))
-         (build-cps* (karg arg)
-           ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
-             ,(convert exp karg subst)))))))
+         (let-gensyms (karg arg)
+           (build-cps-term
+             ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
+               ,(convert exp karg subst))))))))
   ;; (exp ...) ((v-name ...) -> term) -> term
   (define (convert-args exps k)
     (match exps
@@ -291,26 +211,27 @@
   (define (box-bound-var name sym body)
     (match (assq-ref subst sym)
       ((box #t)
-       (build-cps* (k)
-         ($letk ((k #f ($kargs (name) (sym) ,body)))
-           ($continue k ($primcall 'box (sym))))))
+       (let-gensyms (k)
+         (build-cps-term
+           ($letk ((k #f ($kargs (name) (sym) ,body)))
+             ($continue k ($primcall 'box (sym)))))))
       (else body)))
 
   (match exp
     (($ <lexical-ref> src name sym)
      (match (assq-ref subst sym)
-       ((box #t) (build-cps ($continue k ($primcall 'box-ref (box)))))
-       ((subst #f) (build-cps ($continue k ($var subst))))
-       (#f (build-cps ($continue k ($var sym))))))
+       ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
+       ((subst #f) (build-cps-term ($continue k ($var subst))))
+       (#f (build-cps-term ($continue k ($var sym))))))
 
     (($ <void> src)
-     (build-cps ($continue k ($void))))
+     (build-cps-term ($continue k ($void))))
 
     (($ <const> src exp)
-     (build-cps ($continue k ($const exp))))
+     (build-cps-term ($continue k ($const exp))))
 
     (($ <primitive-ref> src name)
-     (build-cps ($continue k ($prim name))))
+     (build-cps-term ($continue k ($prim name))))
 
     (($ <lambda> src meta body)
      ;; FIXME: add src field to fun, add tail field also
@@ -325,36 +246,40 @@
                                         '()
                                         arity gensyms inits)))
               (cons
-               (build-cps* (kentry kargs)
-                 ,(build-fun-entry
-                   ($kentry
-                    kentry src ,arity
-                    (kargs
-                     src
-                     ($kargs names gensyms
-                       ,(fold-formals
-                         (lambda (name sym init body)
-                           (if init
-                               (init-default-value name sym subst init body)
-                               (box-bound-var name sym body)))
-                         (convert body 'ktail subst)
-                         arity gensyms inits))))))
+               (let-gensyms (kentry kargs)
+                 (build-cps-cont
+                   (kentry
+                    src
+                    ($kentry
+                     ,arity
+                     (kargs
+                      src
+                      ($kargs names gensyms
+                        ,(fold-formals
+                          (lambda (name sym init body)
+                            (if init
+                                (init-default-value name sym subst init body)
+                                (box-bound-var name sym body)))
+                          (convert body 'ktail subst)
+                          arity gensyms inits)))))))
                (if alternate (convert-entries alternate) '()))))))
        (if (current-topbox-scope)
-           (build-cps* (self)
-             ($continue k
-               ($fun meta self '() ,(convert-entries body))))
-           (build-cps* (scope kscope)
-             ($letk ((kscope src ($kargs () ()
-                                   ,(parameterize ((current-topbox-scope scope))
-                                      (convert exp k subst)))))
-               ,(capture-toplevel-scope src scope kscope))))))
+           (let-gensyms (self)
+             (build-cps-term
+               ($continue k
+                 ($fun meta self '() ,(convert-entries body)))))
+           (let-gensyms (scope kscope)
+             (build-cps-term
+               ($letk ((kscope src ($kargs () ()
+                                     ,(parameterize ((current-topbox-scope scope))
+                                        (convert exp k subst)))))
+                 ,(capture-toplevel-scope src scope kscope)))))))
 
     (($ <module-ref> src mod name public?)
      (module-box
       src mod name public? #t
       (lambda (box)
-        (build-cps ($continue k ($primcall 'box-ref (box)))))))
+        (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 
     (($ <module-set> src mod name public? exp)
      (convert-arg exp
@@ -362,13 +287,13 @@
          (module-box
           src mod name public? #f
           (lambda (box)
-            (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+            (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 
     (($ <toplevel-ref> src name)
      (toplevel-box
       src name #t
       (lambda (box)
-        (build-cps ($continue k ($primcall 'box-ref (box)))))))
+        (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
 
     (($ <toplevel-set> src name exp)
      (convert-arg exp
@@ -376,20 +301,21 @@
          (toplevel-box
           src name #f
           (lambda (box)
-            (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+            (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
 
     (($ <toplevel-define> src name exp)
      (convert-arg exp
        (lambda (val)
-         (build-cps* (kname name-sym)
-           ($letconst (('name name-sym name))
-             ($continue k ($primcall 'define! (name-sym val))))))))
+         (let-gensyms (kname name-sym)
+           (build-cps-term
+             ($letconst (('name name-sym name))
+               ($continue k ($primcall 'define! (name-sym val)))))))))
 
     (($ <call> src proc args)
      (convert-args (cons proc args)
        (match-lambda
         ((proc . args)
-         (build-cps ($continue k ($call proc args)))))))
+         (build-cps-term ($continue k ($call proc args)))))))
 
     (($ <primcall> src name args)
      (if (branching-primitive? name)
@@ -398,7 +324,7 @@
                   k subst)
          (convert-args args
            (lambda (args)
-             (build-cps ($continue k ($primcall name args)))))))
+             (build-cps-term ($continue k ($primcall name args)))))))
 
     ;; Prompts with inline handlers.
     (($ <prompt> src escape-only? tag body
@@ -416,133 +342,137 @@
      ;;
      ;; Escape prompts evaluate the body with the continuation of krest.
      ;; Otherwise we do a no-inline call to body, continuing to krest.
-     (convert-arg
-      tag
-      (lambda (tag)
-        (let ((hnames (append hreq (if hrest (list hrest) '()))))
-          (build-cps* (khargs khbody kret kprim prim kpop krest vals kbody)
-            ($letk* ((khbody hsrc ($kargs hnames hsyms
-                                    ,(fold box-bound-var
-                                           (convert hbody k subst)
-                                           hnames hsyms)))
-                     (khargs hsrc ($ktrunc hreq hrest khbody))
-                     (kpop src
-                           ($kargs ('rest) (vals)
-                             ($letk ((kret
-                                      src
-                                      ($kargs () ()
-                                        ($letk ((kprim
-                                                 src
-                                                 ($kargs ('prim) (prim)
-                                                   ($continue k
-                                                     ($primcall 'apply
-                                                                (prim vals))))))
-                                          ($continue kprim
-                                            ($prim 'values))))))
-                               ($continue kret
-                                 ($primcall 'pop-prompt ())))))
-                     (krest src ($ktrunc '() 'rest kpop)))
-              ,(if escape-only?
-                   (build-cps
-                     ($letk ((kbody (tree-il-src body) 
-                                    ($kargs () ()
-                                      ,(convert body krest subst))))
-                       ($continue kbody ($prompt #t tag khargs))))
-                   (convert-arg body
-                     (lambda (thunk)
-                       (build-cps
-                         ($letk ((kbody (tree-il-src body) 
-                                        ($kargs () ()
-                                          ($continue krest
-                                            ($primcall 'call-thunk/no-inline
-                                                       (thunk))))))
-                           ($continue kbody
-                             ($prompt #f tag khargs)))))))))))))
+     (convert-arg tag
+       (lambda (tag)
+         (let ((hnames (append hreq (if hrest (list hrest) '()))))
+           (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+             (build-cps-term
+               ($letk* ((khbody hsrc ($kargs hnames hsyms
+                                       ,(fold box-bound-var
+                                              (convert hbody k subst)
+                                              hnames hsyms)))
+                        (khargs hsrc ($ktrunc hreq hrest khbody))
+                        (kpop src
+                              ($kargs ('rest) (vals)
+                                ($letk ((kret
+                                         src
+                                         ($kargs () ()
+                                           ($letk ((kprim
+                                                    src
+                                                    ($kargs ('prim) (prim)
+                                                      ($continue k
+                                                        ($primcall 'apply
+                                                                   (prim vals))))))
+                                             ($continue kprim
+                                               ($prim 'values))))))
+                                  ($continue kret
+                                    ($primcall 'pop-prompt ())))))
+                        (krest src ($ktrunc '() 'rest kpop)))
+                 ,(if escape-only?
+                      (build-cps-term
+                        ($letk ((kbody (tree-il-src body) 
+                                       ($kargs () ()
+                                         ,(convert body krest subst))))
+                          ($continue kbody ($prompt #t tag khargs))))
+                      (convert-arg body
+                        (lambda (thunk)
+                          (build-cps-term
+                            ($letk ((kbody (tree-il-src body) 
+                                           ($kargs () ()
+                                             ($continue krest
+                                               ($primcall 'call-thunk/no-inline
+                                                          (thunk))))))
+                              ($continue kbody
+                                ($prompt #f tag khargs))))))))))))))
 
     ;; Eta-convert prompts without inline handlers.
     (($ <prompt> src escape-only? tag body handler)
-     (convert-args
-      (list tag body handler)
-      (lambda (args)
-        (build-cps
-          ($continue k ($primcall 'call-with-prompt args))))))
+     (convert-args (list tag body handler)
+       (lambda (args)
+         (build-cps-term
+           ($continue k ($primcall 'call-with-prompt args))))))
 
     (($ <abort> src tag args tail)
      (convert-args (append (list tag) args (list tail))
-                   (lambda (args*)
-                     (build-cps ($continue k ($primcall 'abort args*))))))
+       (lambda (args*)
+         (build-cps-term ($continue k ($primcall 'abort args*))))))
 
     (($ <conditional> src test consequent alternate)
-     (build-cps* (kif kt kf)
-       ($letk* ((kt (tree-il-src consequent) ($kargs () ()
-                                               ,(convert consequent k subst)))
-                (kf (tree-il-src alternate) ($kargs () ()
-                                              ,(convert alternate k subst)))
-                (kif src ($kif kt kf)))
-         ,(match test
-            (($ <primcall> src (? branching-primitive? name) args)
-             (convert-args args
-               (lambda (args)
-                 (build-cps ($continue kif ($primcall name args))))))
-            (_ (convert-arg test
-                 (lambda (test)
-                   (build-cps ($continue kif ($var test))))))))))
+     (let-gensyms (kif kt kf)
+       (build-cps-term
+         ($letk* ((kt (tree-il-src consequent) ($kargs () ()
+                                                 ,(convert consequent k subst)))
+                  (kf (tree-il-src alternate) ($kargs () ()
+                                                ,(convert alternate k subst)))
+                  (kif src ($kif kt kf)))
+           ,(match test
+              (($ <primcall> src (? branching-primitive? name) args)
+               (convert-args args
+                 (lambda (args)
+                   (build-cps-term ($continue kif ($primcall name args))))))
+              (_ (convert-arg test
+                   (lambda (test)
+                     (build-cps-term ($continue kif ($var test)))))))))))
 
     (($ <lexical-set> src name gensym exp)
-     (convert-arg
-      exp
-      (lambda (exp)
-        (match (assq-ref subst gensym)
-          ((box #t)
-           (build-cps
-             ($continue k ($primcall 'box-set! (box exp)))))))))
+     (convert-arg exp
+       (lambda (exp)
+         (match (assq-ref subst gensym)
+           ((box #t)
+            (build-cps-term
+              ($continue k ($primcall 'box-set! (box exp)))))))))
 
     (($ <seq> src head tail)
-     (build-cps* (ktrunc kseq)
-       ($letk* ((kseq (tree-il-src tail) ($kargs () ()
-                                           ,(convert tail k subst)))
-                (ktrunc src ($ktrunc '() #f kseq)))
-         ,(convert head ktrunc subst))))
+     (let-gensyms (ktrunc kseq)
+       (build-cps-term
+         ($letk* ((kseq (tree-il-src tail) ($kargs () ()
+                                             ,(convert tail k subst)))
+                  (ktrunc src ($ktrunc '() #f kseq)))
+           ,(convert head ktrunc subst)))))
 
     (($ <let> src names syms vals body)
      (let lp ((names names) (syms syms) (vals vals))
        (match (list names syms vals)
          ((() () ()) (convert body k subst))
          (((name . names) (sym . syms) (val . vals))
-          (build-cps* (klet)
-            ($letk ((klet src ($kargs (name) (sym)
-                                ,(box-bound-var name sym
-                                                (lp names syms vals)))))
-              ,(convert val klet subst)))))))
+          (let-gensyms (klet)
+            (build-cps-term
+              ($letk ((klet src ($kargs (name) (sym)
+                                  ,(box-bound-var name sym
+                                                  (lp names syms vals)))))
+                ,(convert val klet subst))))))))
 
     (($ <fix> src names gensyms funs body)
      ;; Some letrecs can be contified; that happens later.
      (if (current-topbox-scope)
-         (build-cps* (self)
-           ($letrec names
-                    gensyms
-                    (map (lambda (fun)
-                           (match (convert fun k subst)
-                             (($ $continue _ (and fun ($ $fun)))
-                              fun)))
-                         funs)
-                    ,(convert body k subst)))
-         (build-cps* (scope kscope)
-           ($letk ((kscope src ($kargs () ()
-                                 ,(parameterize ((current-topbox-scope scope))
-                                    (convert exp k subst)))))
-             ,(capture-toplevel-scope src scope kscope)))))
+         (let-gensyms (self)
+           (build-cps-term
+             ($letrec names
+                      gensyms
+                      (map (lambda (fun)
+                             (match (convert fun k subst)
+                               (($ $continue _ (and fun ($ $fun)))
+                                fun)))
+                           funs)
+                      ,(convert body k subst))))
+         (let-gensyms (scope kscope)
+           (build-cps-term
+             ($letk ((kscope src ($kargs () ()
+                                   ,(parameterize ((current-topbox-scope scope))
+                                      (convert exp k subst)))))
+               ,(capture-toplevel-scope src scope kscope))))))
 
     (($ <let-values> src exp
         ($ <lambda-case> lsrc req () rest #f () syms body #f))
      (let ((names (append req (if rest (list rest) '()))))
-       (build-cps* (ktrunc kargs)
-         ($letk* ((kargs src ($kargs names syms
-                               ,(fold box-bound-var
-                                      (convert body k subst)
-                                      names syms)))
-                  (ktrunc src ($ktrunc req rest kargs)))
-           ,(convert exp ktrunc subst)))))))
+       (let-gensyms (ktrunc kargs)
+         (build-cps-term
+           ($letk* ((kargs src ($kargs names syms
+                                 ,(fold box-bound-var
+                                        (convert body k subst)
+                                        names syms)))
+                    (ktrunc src ($ktrunc req rest kargs)))
+             ,(convert exp ktrunc subst))))))))
 
 (define (build-subst exp)
   "Compute a mapping from lexical gensyms to substituted gensyms.  The
@@ -582,12 +512,13 @@ indicates that the replacement variable is in a box."
 
 (define (cps-convert/thunk exp)
   (let ((src (tree-il-src exp)))
-    (build-cps* (init kentry kinit)
-      ,(build-fun
+    (let-gensyms (init kentry kinit)
+      (build-cps-call
         ($fun '() init '()
-              (($kentry kentry src ('() '() #f '() #f)
-                        (kinit src ($kargs () ()
-                                     ,(cps-convert exp))))))))))
+              ((kentry src
+                       ($kentry ('() '() #f '() #f)
+                                (kinit src ($kargs () ()
+                                             ,(cps-convert exp)))))))))))
 
 (define *comp-module* (make-fluid))