$fun has list of entries; rewrite compile-cps to use builder macros

* module/language/cps.scm: Change $fun to have a list of entries.  A
  $kentry no longer knows about its "alternate".

* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm: Adapt to change.

* module/language/tree-il/compile-cps.scm: Rewrite to use new "builder"
  macros.

9 files changed, 460 insertions, 446 deletions

diff --git a/module/language/cps.scm b/module/language/cps.scm
index e0e2e8e40..29c688a0c 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -108,7 +108,7 @@
 (define-cps-type $kif kt kf)
 (define-cps-type $ktrunc arity k)
 (define-cps-type $kargs names syms body)
-(define-cps-type $kentry arity cont alternate)
+(define-cps-type $kentry arity cont)
 
 ;; Calls.
 (define-cps-type $continue k exp)
@@ -116,7 +116,7 @@
 (define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
-(define-cps-type $fun meta self free body)
+(define-cps-type $fun meta self free entries)
 (define-cps-type $letrec names syms funs body)
 (define-cps-type $call proc args)
 (define-cps-type $primcall name args)
@@ -144,12 +144,9 @@
      (make-$ktrunc (make-$arity req '() rest '() #f) k))
     (('kargs names syms body)
      (make-$kargs names syms (parse-cps body)))
-    (('kentry (req opt rest kw allow-other-keys?) body . tail)
+    (('kentry (req opt rest kw allow-other-keys?) body)
      (make-$kentry (make-$arity req opt rest kw allow-other-keys?)
-                   (parse-cps body)
-                   (match tail
-                     ((alternate) (parse-cps alternate))
-                     (() #f))))
+                   (parse-cps body)))
     (('kseq body)
      (make-$kargs '() '() (parse-cps body)))
 
@@ -164,8 +161,8 @@
      (make-$const exp))
     (('prim name)
      (make-$prim name))
-    (('fun meta self free body)
-     (make-$fun meta self free (parse-cps body)))
+    (('fun meta self free entries)
+     (make-$fun meta self free (map parse-cps entries)))
     (('letrec ((name sym fun) ...) body)
      (make-$letrec name sym (map parse-cps fun) (parse-cps body)))
     (('call proc arg ...)
@@ -197,10 +194,9 @@
      `(kseq ,(unparse-cps body)))
     (($ $kargs names syms body)
      `(kargs ,names ,syms ,(unparse-cps body)))
-    (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body alternate)
+    (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body)
      `(kentry (,req ,opt ,rest ,kw ,allow-other-keys?)
-              ,(unparse-cps body)
-              ,@(if alternate (list (unparse-cps alternate)) '())))
+              ,(unparse-cps body)))
 
     ;; Calls.
     (($ $continue k exp)
@@ -213,8 +209,8 @@
      `(const ,val))
     (($ $prim name)
      `(prim ,name))
-    (($ $fun meta self free body)
-     `(fun ,meta ,self ,free ,(unparse-cps body)))
+    (($ $fun meta self free entries)
+     `(fun ,meta ,self ,free ,(map unparse-cps entries)))
     (($ $letrec names syms funs body)
      `(letrec ,(map (lambda (name sym fun)
                       (list name sym (unparse-cps fun)))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 12d2bba35..3c522689d 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -38,8 +38,11 @@
 
 (define (fold-conts proc seed term)
   (match term
-    (($ $fun meta self free body)
-     (fold-conts proc seed body))
+    (($ $fun meta self free entries)
+     (fold (lambda (exp seed)
+             (fold-conts proc seed exp))
+           seed
+           entries))
     
     (($ $letrec names syms funs body)
      (fold-conts proc
@@ -60,11 +63,8 @@
     (($ $cont src sym ($ $kargs names syms body))
      (fold-conts proc (proc term seed) body))
 
-    (($ $cont src sym ($ $kentry arity body alternate))
-     (let ((seed (fold-conts proc (proc term seed) body)))
-       (if alternate
-           (fold-conts proc seed alternate)
-           seed)))
+    (($ $cont src sym ($ $kentry arity body))
+     (fold-conts proc (proc term seed) body))
 
     (($ $cont)
      (proc term seed))
@@ -143,13 +143,12 @@
          (make-$letk (map lp conts) (lp body)))
         (($ $cont src sym ($ $kargs names syms body))
          (make-$cont src sym (make-$kargs names syms (lp body))))
-        (($ $cont src sym ($ $kentry arity body alternate))
-         (make-$cont src sym (make-$kentry arity (lp body)
-                                           (and alternate (lp alternate)))))
+        (($ $cont src sym ($ $kentry arity body))
+         (make-$cont src sym (make-$kentry arity (lp body))))
         (($ $cont)
          term)
-        (($ $fun meta self free body)
-         (make-$fun meta self free (lp body)))
+        (($ $fun meta self free entries)
+         (make-$fun meta self free (map lp entries)))
         (($ $letrec names syms funs body)
          (make-$letrec names syms (map lp funs) (lp body)))
         (($ $continue k exp)
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 24a5b4fac..7b33dd73d 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -101,33 +101,37 @@ continue with @var{body}."
         free
         (iota (length free))))
 
+(define (cc* exps self bound)
+  "Convert all free references in the list of expressions @var{exps} to
+bound references, and convert functions to flat closures.  Returns two
+values: the transformed list, and a cumulative set of free variables."
+  (let lp ((exps exps) (exps* '()) (free '()))
+    (match exps
+      (() (values (reverse exps*) free))
+      ((exp . exps)
+       (receive (exp* free*) (cc exp self bound)
+         (lp exps (cons exp* exps*) (union free free*)))))))
+
 ;; Closure conversion.
 (define (cc exp self bound)
   "Convert all free references in @var{exp} to bound references, and
 convert functions to flat closures."
   (match exp
     (($ $letk conts body)
-     (let lp ((conts conts) (conts* '()) (free '()))
-       (match conts
-         (()
-          (receive (body free*) (cc body self bound)
-            (values (make-$letk (reverse conts*) body)
-                    (union free free*))))
-         ((cont . conts)
-          (receive (cont* free*) (cc cont self bound)
-            (lp conts (cons cont* conts*) (union free free*)))))))
+     (receive (conts free) (cc* conts self bound)
+       (receive (body free*) (cc body self bound)
+         (values (make-$letk conts body)
+                 (union free free*)))))
 
     (($ $cont src sym ($ $kargs names syms body))
      (receive (body free) (cc body self (append syms bound))
        (values (make-$cont src sym (make-$kargs names syms body))
                free)))
 
-    (($ $cont src sym ($ $kentry arity body alternate))
+    (($ $cont src sym ($ $kentry arity body))
      (receive (body free) (cc body self bound)
-       (receive (alternate free*)
-           (if alternate (cc alternate self bound) (values #f '()))
-         (values (make-$cont src sym (make-$kentry arity body alternate))
-                 (union free free*)))))
+       (values (make-$cont src sym (make-$kentry arity body))
+               free)))
 
     (($ $cont)
      ;; Other kinds of continuations don't bind values and don't have
@@ -144,14 +148,14 @@ convert functions to flat closures."
                   (free free))
            (match in
              (() (values (bindings body) free))
-             (((name sym ($ $fun meta self () fun-body)) . in)
-              (receive (fun-body fun-free) (cc fun-body self (list self))
+             (((name sym ($ $fun meta self () entries)) . in)
+              (receive (entries fun-free) (cc* entries self (list self))
                 (lp in
                     (lambda (body)
                       (let ((k (gensym "k")))
                         (make-$let1v
                          #f k name sym (bindings body)
-                         (make-$continue k (make-$fun meta self fun-free fun-body)))))
+                         (make-$continue k (make-$fun meta self fun-free entries)))))
                     (init-closure #f sym fun-free body)
                     (union free (difference fun-free bound))))))))))
 
@@ -167,11 +171,11 @@ convert functions to flat closures."
             ($ $prim)))
      (values exp '()))
 
-    (($ $continue k ($ $fun meta self () body))
-     (receive (body free) (cc body self (list self))
+    (($ $continue k ($ $fun meta self () entries))
+     (receive (entries free) (cc* entries self (list self))
        (match free
          (()
-          (values (make-$continue k (make-$fun meta self free body))
+          (values (make-$continue k (make-$fun meta self free entries))
                   free))
          (else
           (values
@@ -181,7 +185,7 @@ convert functions to flat closures."
               #f kinit v v
               (init-closure #f v free
                             (make-$continue k (make-$var v)))
-              (make-$continue kinit (make-$fun meta self free body))))
+              (make-$continue kinit (make-$fun meta self free entries))))
            (difference free bound))))))
 
     (($ $continue k ($ $call proc args))
@@ -222,10 +226,8 @@ convert functions to flat closures."
          (make-$letk (map lp conts) (lp body)))
         (($ $cont src sym ($ $kargs names syms body))
          (make-$cont src sym (make-$kargs names syms (lp body))))
-        (($ $cont src sym ($ $kentry arity body alternate))
-         (make-$cont src sym (make-$kentry arity (lp body)
-                                           (and alternate
-                                                (lp alternate)))))
+        (($ $cont src sym ($ $kentry arity body))
+         (make-$cont src sym (make-$kentry arity (lp body))))
         ;; Other kinds of continuations don't
         ;; bind values and don't have bodies.
         (($ $cont) exp)
@@ -253,8 +255,9 @@ convert functions to flat closures."
         (($ $continue k (or ($ $var) ($ $void) ($ $const) ($ $prim)
                             ($ $call) ($ $values) ($ $prompt) ($ $primcall)))
          exp)
-        (($ $continue k ($ $fun meta self free body))
-         (make-$continue k (make-$fun meta self free (lpfree body free))))
+        (($ $continue k ($ $fun meta self free entries))
+         (make-$continue k (make-$fun meta self free
+                                      (map (cut lpfree <> free) entries))))
         (($ $values args) exp)
         (_ ((error "convert-to-indices: unhandled case")))))))
 
@@ -262,8 +265,8 @@ convert functions to flat closures."
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
   (match exp
-    (($ $fun meta self () body)
-     (receive (body free) (cc body #f '())
+    (($ $fun meta self () entries)
+     (receive (entries free) (cc* entries #f '())
        (unless (null? free)
-         (error "Expected no free vars in toplevel thunk" exp))
-       (make-$fun meta self '() (convert-to-indices body))))))
+         (error "Expected no free vars in toplevel thunk" exp entries free))
+       (make-$fun meta self '() (map convert-to-indices entries))))))
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 675680db6..8f2c7abe3 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -71,9 +71,9 @@
     (($ $continue _ exp)
      (visit-funs proc exp))
 
-    (($ $fun meta self free body)
+    (($ $fun meta self free entries)
      (proc exp)
-     (visit-funs proc body))
+     (for-each (lambda (entry) (visit-funs proc entry)) entries))
 
     (($ $letk conts body)
      (visit-funs proc body)
@@ -82,10 +82,8 @@
     (($ $cont src sym ($ $kargs names syms body))
      (visit-funs proc body))
 
-    (($ $cont src sym ($ $kentry arity body alternate))
-     (visit-funs proc body)
-     (when alternate
-       (visit-funs proc alternate)))
+    (($ $cont src sym ($ $kentry arity body))
+     (visit-funs proc body))
 
     (_ (values))))
 
@@ -170,9 +168,9 @@
             (($ $const exp)
              (when dst
                (emit `(load-constant ,dst ,exp))))
-            (($ $fun meta self () body)
+            (($ $fun meta self () entries)
              (emit `(load-static-procedure ,dst ,self)))
-            (($ $fun meta self free body)
+            (($ $fun meta self free entries)
              (emit `(make-closure ,dst ,self ,(length free))))
             (($ $call proc args)
              (let ((proc-slot (lookup-call-proc-slot label slots))
@@ -333,14 +331,12 @@
     (define (emit asm)
       (set! rtl (cons asm rtl)))
 
-    (define (emit-fun-body self body)
+    (define (emit-fun-entry self body alternate)
       (call-with-values (lambda () (allocate-slots self body))
         (lambda (slots nlocals)
           (match body
             (($ $cont src k
-                ($ $kentry ($ $arity req opt rest kw allow-other-keys?)
-                   body
-                   alternate))
+                ($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
              (let ((kw-indices (map (match-lambda
                                      ((key name sym)
                                       (cons key (lookup-slot sym slots))))
@@ -349,19 +345,25 @@
                (emit `(begin-kw-arity ,req ,opt ,rest
                                       ,kw-indices ,allow-other-keys?
                                       ,nlocals
-                                      ,(match alternate
-                                         (($ $cont _ k) k)
-                                         (#f #f))))
+                                      ,alternate))
                (for-each emit (emit-rtl-sequence body slots nlocals))
-               (emit `(end-arity))
-               (when alternate
-                 (emit-fun-body self alternate))))))))
+               (emit `(end-arity))))))))
+
+    (define (emit-fun-entries self entries)
+      (match entries
+        ((entry . entries)
+         (let ((alternate (match entries
+                            (($cont _ k) k)
+                            (() #f))))
+           (emit-fun-entry self entry alternate)
+           (when alternate
+             (emit-fun-entries self entries))))))
 
     (match f
       ;; FIXME: We shouldn't use SELF as a label.
-      (($ $fun meta self free body)
+      (($ $fun meta self free entries)
        (emit `(begin-program ,self ,(or meta '())))
-       (emit-fun-body self body)
+       (emit-fun-entries self entries)
        (emit `(end-program))
        (reverse rtl)))))
 
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 6a86f97e8..4c51aba66 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -97,7 +97,7 @@
 
         ;; Treat the entry continuation as its own parent, and as a hack
         ;; declare "ktail" as being a child of the entry.
-        (($ $cont src k ($ $kentry arity body alternate))
+        (($ $cont src k ($ $kentry arity body))
          (when exp-k
            (error "$kentry not at top level?"))
          (add-def! k k)
@@ -105,8 +105,6 @@
          (hashq-set! uplinks k (make-uplink #f 0))
          (add-def! 'ktail k)
          (link-parent! 'ktail k)
-         ;; The alternate clause, if present, should be analyzed
-         ;; separately.
          (visit body k))
 
         (($ $cont src k cont)
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 364c19447..378cb8976 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -53,8 +53,11 @@
 
 (define (fold-conts proc seed term)
   (match term
-    (($ $fun meta self free body)
-     (fold-conts proc seed body))
+    (($ $fun meta self free entries)
+     (fold (lambda (exp seed)
+             (fold-conts proc seed exp))
+           seed
+           entries))
 
     (($ $letrec names syms funs body)
      (fold-conts proc
@@ -75,11 +78,8 @@
     (($ $cont src sym ($ $kargs names syms body))
      (fold-conts proc (proc term seed) body))
 
-    (($ $cont src sym ($ $kentry arity body alternate))
-     (let ((seed (fold-conts proc (proc term seed) body)))
-       (if alternate
-           (fold-conts proc seed alternate)
-           seed)))
+    (($ $cont src sym ($ $kentry arity body))
+     (fold-conts proc (proc term seed) body))
 
     (($ $cont)
      (proc term seed))
@@ -132,15 +132,13 @@
   (let ((conts (build-cont-table fun)))
     (define (visit-fun term)
       (match term
-        (($ $fun meta self free body)
-         (make-$fun meta self free (visit-entry body)))))
+        (($ $fun meta self free entries)
+         (make-$fun meta self free (map visit-entry entries)))))
     (define (visit-entry term)
       (match term
-        (($ $cont src sym ($ $kentry arity body alternate))
+        (($ $cont src sym ($ $kentry arity body))
          (make-$cont src sym
-                     (make-$kentry arity (visit-cont body)
-                                   (and alternate
-                                        (visit-entry alternate)))))))
+                     (make-$kentry arity (visit-cont body))))))
     (define (visit-cont term)
       (match term
         (($ $cont src sym ($ $kargs names syms body))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 34311e949..7aa112295 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -212,7 +212,7 @@ are comparable with eqv?.  A tmp slot may be used."
         (nlocals 0)
         (nargs (match exp
                  (($ $cont _ _ 
-                     ($ $kentry _ ($ $cont _ _ ($ $kargs names syms)) _))
+                     ($ $kentry _ ($ $cont _ _ ($ $kargs names syms))))
                   (length syms))))
         (visited (make-hash-table))
         (allocation (make-hash-table)))
@@ -297,8 +297,7 @@ are comparable with eqv?.  A tmp slot may be used."
          (hashq-set! visited k #t)
          (visit cont k live-set))
 
-        (($ $kentry arity body alternate)
-         ;; Alternate clauses, if any, should be allocated separately.
+        (($ $kentry arity body)
          (visit body exp-k (allocate! self exp-k 0 live-set)))
 
         (($ $kargs names syms body)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 6ddffd393..eed74ddcc 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -92,7 +92,7 @@
           #t)
          (($ $prim name)
           (unless (symbol? name) (error "name should be a symbol" exp)))
-         (($ $fun meta self free body)
+         (($ $fun meta self free entries)
           (when (and meta (not (and (list? meta) (and-map pair? meta))))
             (error "meta should be alist" meta))
           (unless (symbol? self)
@@ -101,43 +101,41 @@
             (error "free should be list of symbols" exp))
           (unless (symbol? k)
             (error "entry should be symbol" k))
-          (let lp ((body body))
-            (match body
-              (#f #t)
-              (($ $cont src* k*
-                  ($ $kentry arity ($ $cont src k ($ $kargs names syms body))
-                     alternate))
-               (check-src src*)
-               (check-src src)
-               (match arity
-                 (($ $arity ((? symbol?) ...) ((? symbol?) ...) (or #f (? symbol?))
-                     (((? keyword?)
-                       (? symbol?)
-                       (and (? symbol?) (? (cut memq <> syms))))
-                      ...)
-                     (or #f #t))
-                  #t)
-                 (else (error "bad arity" arity)))
-               (unless (and (list? names) (and-map symbol? names))
-                 (error "letrec names not symbols" exp))
-               (unless (and (list? syms) (and-map symbol? syms))
-                 (error "letrec syms not symbols" exp))
-               (unless (match arity
-                         (($ $arity req opt rest kw allow-other-keys?)
-                          (= (length syms) 
-                             (length names)
-                             (+ (length req)
-                                (length opt)
-                                (if rest 1 0)
-                                ;; FIXME: technically possible for kw syms to
-                                ;; alias other syms
-                                (length kw)))))
-                 (error "unexpected fun-case syms" exp))
-               ;; The continuation environment is null, because we don't turn
-               ;; captured continuations into closures.
-               (visit body (add-env (list k* k) '())
-                      (add-env (cons self syms) v-env))
-               (lp alternate)))))
+          (for-each
+           (match-lambda
+            (($ $cont src* k*
+                ($ $kentry arity ($ $cont src k ($ $kargs names syms body))))
+             (check-src src*)
+             (check-src src)
+             (match arity
+               (($ $arity ((? symbol?) ...) ((? symbol?) ...) (or #f (? symbol?))
+                   (((? keyword?)
+                     (? symbol?)
+                     (and (? symbol?) (? (cut memq <> syms))))
+                    ...)
+                   (or #f #t))
+                #t)
+               (else (error "bad arity" arity)))
+             (unless (and (list? names) (and-map symbol? names))
+               (error "letrec names not symbols" exp))
+             (unless (and (list? syms) (and-map symbol? syms))
+               (error "letrec syms not symbols" exp))
+             (unless (match arity
+                       (($ $arity req opt rest kw allow-other-keys?)
+                        (= (length syms) 
+                           (length names)
+                           (+ (length req)
+                              (length opt)
+                              (if rest 1 0)
+                              ;; FIXME: technically possible for kw syms to
+                              ;; alias other syms
+                              (length kw)))))
+               (error "unexpected fun-case syms" exp))
+             ;; The continuation environment is null, because we don't turn
+             ;; captured continuations into closures.
+             (visit body (add-env (list k* k) '())
+                    (add-env (cons self syms) v-env))))
+           entries))
          (($ $letrec names syms funs body)
           (unless (and (list? names) (and-map symbol? names))
             (error "letrec names not symbols" exp))
@@ -150,8 +148,7 @@
             (error "letrec syms, names, and funs not same length" exp))
           (let ((v-env (add-env syms v-env)))
             (for-each (cut visit <> k-env v-env) funs)
-            (visit body k-env v-env)))
-         (($ $call proc args)
+            (visit body k-env v-env)))(($ $call proc args)
           (check-var proc v-env)
           (for-each (cut check-var <> v-env) args))
          (($ $primcall name args)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index b4bc39b67..d77b9d4a5 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -47,23 +47,97 @@
                  tree-il-fold))
   #:export (compile-cps))
 
-;; Helpers.
-(define-inlinable (make-$let1k cont body)
-  (make-$letk (list cont) body))
-(define-inlinable (make-$let1v src k name sym cont-body body)
-  (make-$let1k (make-$cont src k (make-$kargs (list name) (list sym) cont-body))
-               body))
-(define-inlinable (make-$let1c src name sym val cont-body)
-  (let ((k (gensym "kconst")))
-    (make-$let1v src k name sym cont-body (make-$continue k (make-$const val)))))
-(define-inlinable (make-$letk* conts body)
-  (match conts
-    (() body)
-    ((cont . conts)
-     (make-$let1k cont (make-$letk* conts body)))))
-(define-inlinable (make-let src val-proc body-proc)
-  (let ((k (gensym "k")) (sym (gensym "v")))
-    (make-$let1v src k 'tmp sym (body-proc sym) (val-proc k))))
+;; (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
@@ -81,62 +155,43 @@
 (define current-topbox-scope (make-parameter #f))
 
 (define (toplevel-box src name bound? val-proc)
-  (let ((name-sym (gensym "name"))
-        (bound?-sym (gensym "bound?")))
-    (make-$let1c
-     src 'name name-sym name
-     (make-$let1c
-      src 'bound? bound?-sym bound?
-      (make-let
-       src
-       (lambda (k)
-         (match (current-topbox-scope)
+  (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
-            (make-$continue k (make-$primcall
-                               'resolve
-                               (list name-sym bound?-sym))))
+            (build-cps
+              ($continue kbox
+                ($primcall 'resolve
+                           (name-sym bound?-sym)))))
            (scope
-            (let ((scope-sym (gensym "scope")))
-              (make-$let1c
-               src 'scope scope-sym scope
-               (make-$continue k (make-$primcall
-                               'cached-toplevel-box
-                               (list scope-sym name-sym bound?-sym))))))))
-       val-proc)))))
+            (build-cps* (scope-sym)
+              ($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)
-  (let ((module-sym (gensym "module"))
-        (name-sym (gensym "name"))
-        (public?-sym (gensym "public?"))
-        (bound?-sym (gensym "bound?")))
-    (make-$let1c
-      src 'module module-sym module
-      (make-$let1c
-       src 'name name-sym name
-       (make-$let1c
-        src 'public? public?-sym public?
-        (make-$let1c
-         src 'bound? bound?-sym bound?
-         (make-let
-          src
-          (lambda (k)
-            (make-$continue k (make-$primcall
-                            'cached-module-box
-                            (list module-sym name-sym public?-sym bound?-sym))))
-          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)))))))
 
 (define (capture-toplevel-scope src scope k)
-  (let ((module (gensym "module"))
-        (scope-sym (gensym "scope"))
-        (kmodule (gensym "kmodule")))
-    (make-$let1c
-     src 'scope scope-sym scope
-     (make-$let1v
-      src kmodule 'module module
-      (make-$continue
-       k
-       (make-$primcall 'cache-current-module! (list module scope-sym)))
-      (make-$continue kmodule (make-$primcall 'current-module '()))))))
+  (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 ()))))))
 
 (define (fold-formals proc seed arity gensyms inits)
   (match arity
@@ -178,45 +233,32 @@
   (define tc8-iflag 4)
   (define unbound-val 9)
   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
-  (let ((unbound-sym (gensym "unbound"))
-        (ktest (gensym "ktest")))
-    (make-$let1c
-     src 'unbound unbound-sym (pointer->scm (make-pointer unbound-bits))
-     (make-$let1k
-      (make-$cont src ktest (make-$kif kt kf))
-      (make-$continue ktest (make-$primcall 'eq? (list sym unbound-sym)))))))
+  (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)))))))
 
 (define (init-default-value name sym subst init body)
   (match (assq-ref subst sym)
     ((subst-sym box?)
-     (let ((knext (gensym "knext"))
-           (kbound (gensym "kbound"))
-           (kunbound (gensym "kunbound"))
-           (src (tree-il-src init)))
+     (let ((src (tree-il-src init)))
        (define (maybe-box k make-body)
          (if box?
-             (let ((kbox (gensym "kbox"))
-                   (phi (gensym "phi")))
-               (make-$let1k
-                (make-$cont src kbox
-                            (make-$kargs (list name) (list phi)
-                                         (make-$continue
-                                          k
-                                          (make-$primcall 'box (list phi)))))
-                (make-body kbox)))
+             (build-cps* (kbox phi)
+               ($letk ((kbox src ($kargs (name) (phi)
+                                   ($continue k ($primcall 'box (phi))))))
+                 ,(make-body kbox)))
              (make-body k)))
-       (make-$let1k
-        (make-$cont src knext (make-$kargs (list name) (list subst-sym) body))
-        (maybe-box
-         knext
-         (lambda (k)
-           (make-$letk*
-            (list
-             (make-$cont src kbound
-                         (make-$kargs '() '() (make-$continue k (make-$var sym))))
-             (make-$cont src kunbound
-                         (make-$kargs '() '() (convert init k subst))))
-            (unbound? src sym kunbound kbound)))))))))
+       (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)))))))))))
 
 ;; exp k-name alist -> term
 (define (convert exp k subst)
@@ -226,96 +268,128 @@
       (($ <lexical-ref> src name sym)
        (match (assq-ref subst sym)
          ((box #t)
-          (make-let src
-                    (lambda (k)
-                      (make-$continue k (make-$primcall 'box-ref (list box))))
-                    k))
+          (build-cps* (kunboxed unboxed)
+            ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+              ($continue kunboxed ($primcall 'box-ref (box))))))
          ((subst #f) (k subst))
          (#f (k sym))))
-      (else (make-let (tree-il-src exp)
-                      (cut convert exp <> subst)
-                      k))))
+      (else
+       (let ((src (tree-il-src exp)))
+         (build-cps* (karg arg)
+           ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
+             ,(convert exp karg subst)))))))
   ;; (exp ...) ((v-name ...) -> term) -> term
   (define (convert-args exps k)
     (match exps
       (() (k '()))
       ((exp . exps)
        (convert-arg exp
-                    (lambda (name)
-                      (convert-args exps
-                                    (lambda (names)
-                                      (k (cons name names)))))))))
+         (lambda (name)
+           (convert-args exps
+             (lambda (names)
+               (k (cons name names)))))))))
   (define (box-bound-var name sym body)
     (match (assq-ref subst sym)
       ((box #t)
-       (let ((k (gensym "k")))
-         (make-$let1v #f k name box body
-                      (make-$continue k (make-$primcall 'box (list sym))))))
+       (build-cps* (k)
+         ($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)
-        (make-$continue k (make-$primcall 'box-ref (list box))))
-       ((subst #f) (make-$continue k (make-$var subst)))
-       (#f (make-$continue k (make-$var sym)))))
-    (($ <void> src) (make-$continue k (make-$void)))
-    (($ <const> src exp) (make-$continue k (make-$const exp)))
-    (($ <primitive-ref> src name) (make-$continue k (make-$prim name)))
+       ((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))))))
+
+    (($ <void> src)
+     (build-cps ($continue k ($void))))
+
+    (($ <const> src exp)
+     (build-cps ($continue k ($const exp))))
+
+    (($ <primitive-ref> src name)
+     (build-cps ($continue k ($prim name))))
+
     (($ <lambda> src meta body)
-     ;; FIXME: propagate src to kentry
-     (if (current-topbox-scope)
-         (make-$continue k (make-$fun meta (gensym "self") '()
-                                      (convert body 'ktail subst)))
-         (let ((scope (gensym "scope"))
-               (kscope (gensym "kscope")))
-           (make-$let1k
-            (make-$cont src kscope
-                     (make-$kargs '() '() 
-                                  (parameterize ((current-topbox-scope scope))
-                                    (convert exp k subst))))
-            (capture-toplevel-scope src scope kscope)))))
+     ;; FIXME: add src field to fun, add tail field also
+     (let ()
+       (define (convert-entries body)
+         (match body
+           (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+            (let* ((arity (make-$arity req (or opt '()) rest
+                                       (if kw (cdr kw) '()) (and kw (car kw))))
+                   (names (fold-formals (lambda (name sym init names)
+                                          (cons name names))
+                                        '()
+                                        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))))))
+               (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))))))
 
     (($ <module-ref> src mod name public?)
      (module-box
       src mod name public? #t
       (lambda (box)
-        (make-$continue k (make-$primcall 'box-ref (list box))))))
+        (build-cps ($continue k ($primcall 'box-ref (box)))))))
+
     (($ <module-set> src mod name public? exp)
-     (convert-arg
-      exp
-      (lambda (val)
-        (module-box
-         src mod name public? #f
-         (lambda (box)
-           (make-$continue k (make-$primcall 'box-set! (list box val))))))))
+     (convert-arg exp
+       (lambda (val)
+         (module-box
+          src mod name public? #f
+          (lambda (box)
+            (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+
     (($ <toplevel-ref> src name)
      (toplevel-box
       src name #t
       (lambda (box)
-        (make-$continue k (make-$primcall 'box-ref (list box))))))
+        (build-cps ($continue k ($primcall 'box-ref (box)))))))
+
     (($ <toplevel-set> src name exp)
-     (convert-arg
-      exp
-      (lambda (val)
-        (toplevel-box
-         src name #f
-         (lambda (box)
-           (make-$continue k (make-$primcall 'box-set! (list box val))))))))
+     (convert-arg exp
+       (lambda (val)
+         (toplevel-box
+          src name #f
+          (lambda (box)
+            (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+
     (($ <toplevel-define> src name exp)
-     (make-let src
-               (lambda (k) (make-$continue k (make-$const name)))
-               (lambda (name)
-                 (convert-arg
-                  exp
-                  (lambda (val)
-                    (make-$continue k (make-$primcall 'define! (list name val))))))))
+     (convert-arg exp
+       (lambda (val)
+         (build-cps* (kname name-sym)
+           ($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) (make-$continue k (make-$call proc args))))))
+       (match-lambda
+        ((proc . args)
+         (build-cps ($continue k ($call proc args)))))))
 
     (($ <primcall> src name args)
      (if (branching-primitive? name)
@@ -323,8 +397,8 @@
                                     (make-const #f #f))
                   k subst)
          (convert-args args
-                       (lambda (args)
-                         (make-$continue k (make-$primcall name args))))))
+           (lambda (args)
+             (build-cps ($continue k ($primcall name args)))))))
 
     ;; Prompts with inline handlers.
     (($ <prompt> src escape-only? tag body
@@ -345,101 +419,74 @@
      (convert-arg
       tag
       (lambda (tag)
-        (let ((khargs (gensym "khargs"))
-              (khbody (gensym "khbody")))
-          (make-$let1k
-           (let ((hnames (append hreq (if hrest (list hrest) '()))))
-             (make-$cont hsrc khbody
-                         (make-$kargs hnames hsyms
-                                      (fold box-bound-var
-                                            (convert hbody k subst)
-                                            hnames hsyms))))
-           (make-$let1k
-            (make-$cont hsrc khargs
-                        (make-$ktrunc (make-$arity hreq '() hrest '() #f)
-                                      khbody))
-            (cond
-             (escape-only?
-              (let ((kret (gensym "kret"))
-                    (kprim (gensym "kvalues"))
-                    (prim (gensym "values"))
-                    (kpop (gensym "kpop"))
-                    (krest (gensym "krest"))
-                    (vals (gensym "vals")))
-                (make-$letk*
-                 (list
-                  (make-$cont
-                   src kpop
-                   (make-$kargs
-                    (list 'rest) (list vals)
-                    (make-$let1k
-                     (make-$cont
-                      src kret
-                      (make-$kargs
-                       '() '()
-                       (make-$let1k
-                        (make-$cont
-                         src kprim
-                         (make-$kargs
-                          (list 'prim) (list prim)
-                          (make-$continue
-                           k
-                           (make-$primcall 'apply (list prim vals)))))
-                        (make-$continue kprim (make-$prim 'values)))))
-                     (make-$continue kret (make-$primcall 'pop-prompt '())))))
-                  (make-$cont src krest
-                              (make-$ktrunc (make-$arity '() '() 'rest '() #f)
-                                            kpop)))
-                 (let ((kbody (gensym "kbody")))
-                   (if escape-only?
-                       (make-$let1k
-                        (make-$cont (tree-il-src body) kbody
-                                    (convert body krest subst))
-                        (make-$continue kbody (make-$prompt #t tag khargs)))
-                       (convert-arg
-                        body
-                        (lambda (body)
-                          (make-$let1k
-                           (make-$cont
-                            (tree-il-src body) kbody
-                            (make-$continue
-                             krest
-                             (make-$primcall 'call-thunk/no-inline (list body))))
-                           (make-$continue
-                            kbody
-                            (make-$prompt #f tag khargs)))))))))))))))))
+        (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)))))))))))))
 
     ;; Eta-convert prompts without inline handlers.
     (($ <prompt> src escape-only? tag body handler)
      (convert-args
       (list tag body handler)
       (lambda (args)
-        (make-$continue k (make-$primcall 'call-with-prompt args)))))
+        (build-cps
+          ($continue k ($primcall 'call-with-prompt args))))))
 
     (($ <abort> src tag args tail)
      (convert-args (append (list tag) args (list tail))
                    (lambda (args*)
-                     (make-$continue k (make-$primcall 'abort args*)))))
+                     (build-cps ($continue k ($primcall 'abort args*))))))
 
     (($ <conditional> src test consequent alternate)
-     (let ((kif (gensym "kif"))
-           (kt (gensym "k"))
-           (kf (gensym "k")))
-       (make-$letk*
-        (list (make-$cont (tree-il-src consequent) kt
-                          (make-$kargs '() '() (convert consequent k subst)))
-              (make-$cont (tree-il-src alternate) kf
-                          (make-$kargs '() '() (convert alternate k subst))))
-        (make-$let1k
-         (make-$cont src kif (make-$kif kt kf))
-         (match test
-           (($ <primcall> src (? branching-primitive? name) args)
-            (convert-args args
-                          (lambda (args)
-                            (make-$continue kif (make-$primcall name args)))))
-           (_ (convert-arg test
-                           (lambda (test)
-                             (make-$continue kif (make-$var test))))))))))
+     (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))))))))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg
@@ -447,76 +494,55 @@
       (lambda (exp)
         (match (assq-ref subst gensym)
           ((box #t)
-           (make-$continue k (make-$primcall 'box-set! (list box exp))))))))
-
-    (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
-     (let ((arity (make-$arity req (or opt '()) rest
-                               (if kw (cdr kw) '()) (and kw (car kw)))))
-       (make-$cont
-        src (gensym "kentry")
-        (make-$kentry
-         arity
-         (make-$cont
-          src (gensym "kcase")
-          (make-$kargs
-           (fold-formals (lambda (name sym init names)
-                           (cons name names))
-                         '()
-                         arity gensyms inits)
-           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 k subst)
-                         arity gensyms inits)))
-         (and alternate (convert alternate k subst))))))
+           (build-cps
+             ($continue k ($primcall 'box-set! (box exp)))))))))
 
     (($ <seq> src head tail)
-     (let ((ktrunc (gensym "ktrunc"))
-           (kseq (gensym "kseq")))
-       (make-$letk* (list (make-$cont (tree-il-src tail) kseq
-                                   (make-$kargs '() '()
-                                                (convert tail k subst)))
-                          (make-$cont src ktrunc
-                                   (make-$ktrunc (make-$arity '() '() #f '() #f)
-                                                 kseq)))
-                    (convert head ktrunc subst))))
+     (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> 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))
-          (let ((klet (gensym "k")))
-            (make-$let1v src klet name sym
-                         (box-bound-var name sym (lp names syms vals))
-                         (convert val klet subst)))))))
+          (build-cps* (klet)
+            ($letk ((klet src ($kargs (name) (sym)
+                                ,(box-bound-var name sym
+                                                (lp names syms vals)))))
+              ,(convert val klet subst)))))))
 
-    (($ <fix> src names gensyms (($ <lambda> lsrc lmeta lbody) ...) body)
+    (($ <fix> src names gensyms funs body)
      ;; Some letrecs can be contified; that happens later.
-     (make-$letrec names gensyms
-                   (map (lambda (src meta body)
-                          ;; FIXME: propagate src to kentry
-                          (make-$fun meta (gensym "self") '()
-                                     (convert body 'ktail subst)))
-                        lsrc lmeta lbody)
-                   (convert body k subst)))
+     (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-values> src exp
         ($ <lambda-case> lsrc req () rest #f () syms body #f))
-     (let* ((ktrunc (gensym "ktrunc"))
-            (kargs (gensym "kargs"))
-            (names (append req (if rest (list rest) '())))
-            (arity (make-$arity req '() rest '() #f)))
-       (make-$letk* (list (make-$cont src kargs
-                                   (make-$kargs names syms
-                                                (fold box-bound-var
-                                                      (convert body k subst)
-                                                      names syms)))
-                          (make-$cont src ktrunc
-                                   (make-$ktrunc arity kargs)))
-                    (convert exp ktrunc subst))))))
+     (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)))))))
 
 (define (build-subst exp)
   "Compute a mapping from lexical gensyms to substituted gensyms.  The
@@ -555,17 +581,13 @@ indicates that the replacement variable is in a box."
   (convert exp 'ktail (build-subst exp)))
 
 (define (cps-convert/thunk exp)
-  (make-$fun '() (gensym "init") '()
-             (make-$cont
-              (tree-il-src exp)
-              (gensym "kentry")
-              (make-$kentry (make-$arity '() '() #f '() #f)
-                            (make-$cont
-                             (tree-il-src exp)
-                             (gensym "kinit")
-                             (make-$kargs '() '()
-                                          (cps-convert exp)))
-                            #f))))
+  (let ((src (tree-il-src exp)))
+    (build-cps* (init kentry kinit)
+      ,(build-fun
+        ($fun '() init '()
+              (($kentry kentry src ('() '() #f '() #f)
+                        (kinit src ($kargs () ()
+                                     ,(cps-convert exp))))))))))
 
 (define *comp-module* (make-fluid))