diff --git a/module/language/cps.scm b/module/language/cps.scm
index c685ddc93..86cdec5fe 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -122,7 +122,11 @@
             $kif $kreceive $kargs $kfun $ktail $kclause
 
             ;; Expressions.
-            $void $const $prim $fun $call $callk $primcall $values $prompt
+            $void $const $prim $fun $closure
+            $call $callk $primcall $values $prompt
+
+            ;; First-order CPS root.
+            $program
 
             ;; Fresh names.
             label-counter var-counter
@@ -173,7 +177,7 @@
 ;; Terms.
 (define-cps-type $letk conts body)
 (define-cps-type $continue k src exp)
-(define-cps-type $letrec names syms funs body)
+(define-cps-type $letrec names syms funs body) ; Higher-order.
 
 ;; Continuations
 (define-cps-type $cont k cont)
@@ -188,13 +192,18 @@
 (define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
-(define-cps-type $fun free body)
+(define-cps-type $fun free body) ; Higher-order.
+(define-cps-type $closure label nfree) ; First-order.
 (define-cps-type $call proc args)
-(define-cps-type $callk k proc args)
+(define-cps-type $callk k proc args) ; First-order.
 (define-cps-type $primcall name args)
 (define-cps-type $values args)
 (define-cps-type $prompt escape? tag handler)
 
+;; The root of a higher-order CPS term is $cont containing a $kfun.  The
+;; root of a first-order CPS term is a $program.
+(define-cps-type $program funs)
+
 (define label-counter (make-parameter #f))
 (define var-counter (make-parameter #f))
 
@@ -257,13 +266,14 @@
 
 (define-syntax build-cps-exp
   (syntax-rules (unquote
-                 $void $const $prim $fun $call $callk $primcall $values $prompt)
+                 $void $const $prim $fun $closure
+                 $call $callk $primcall $values $prompt)
     ((_ (unquote exp)) exp)
     ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
-    ((_ ($fun free body))
-     (make-$fun free (build-cps-cont body)))
+    ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
+    ((_ ($closure k nfree)) (make-$closure k nfree))
     ((_ ($call proc (unquote args))) (make-$call proc args))
     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
     ((_ ($call proc args)) (make-$call proc args))
@@ -280,7 +290,7 @@
      (make-$prompt escape? tag handler))))
 
 (define-syntax build-cps-term
-  (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+  (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
     ((_ (unquote exp))
      exp)
     ((_ ($letk (unquote conts) body))
@@ -303,6 +313,12 @@
              ($const val))))))
     ((_ ($letrec names gensyms funs body))
      (make-$letrec names gensyms funs (build-cps-term body)))
+    ((_ ($program (unquote conts)))
+     (make-$program conts))
+    ((_ ($program (cont ...)))
+     (make-$program (list (build-cps-cont cont) ...)))
+    ((_ ($program conts))
+     (make-$program conts))
     ((_ ($continue k src exp))
      (make-$continue k src (build-cps-exp exp)))))
 
@@ -375,9 +391,13 @@
      (build-cps-exp ($prim name)))
     (('fun free body)
      (build-cps-exp ($fun free ,(parse-cps body))))
+    (('closure k nfree)
+     (build-cps-exp ($closure k nfree)))
     (('letrec ((name sym fun) ...) body)
      (build-cps-term
        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+    (('program (cont ...))
+     (build-cps-term ($program ,(map parse-cps cont))))
     (('call proc arg ...)
      (build-cps-exp ($call proc arg)))
     (('callk k proc arg ...)
@@ -432,11 +452,15 @@
      `(prim ,name))
     (($ $fun free body)
      `(fun ,free ,(unparse-cps body)))
+    (($ $closure k nfree)
+     `(closure ,k ,nfree))
     (($ $letrec names syms funs body)
      `(letrec ,(map (lambda (name sym fun)
                       (list name sym (unparse-cps fun)))
                     names syms funs)
         ,(unparse-cps body)))
+    (($ $program conts)
+     `(program ,(map unparse-cps conts)))
     (($ $call proc args)
      `(call ,proc ,@args))
     (($ $callk k proc args)
@@ -541,21 +565,45 @@
          (cont-folder tail seed ...))))))
 
 (define (compute-max-label-and-var fun)
-  ((make-global-cont-folder max-label max-var)
-   (lambda (label cont max-label max-var)
-     (values (max label max-label)
-             (match cont
-               (($ $kargs names vars body)
-                (let lp ((body body) (max-var (fold max max-var vars)))
-                  (match body
-                    (($ $letk conts body) (lp body max-var))
-                    (($ $letrec names vars funs body)
-                     (lp body (fold max max-var vars)))
-                    (_ max-var))))
-               (($ $kfun src meta self)
-                (max self max-var))
-               (_ max-var))))
-   fun -1 -1))
+  (match fun
+    (($ $cont)
+     ((make-global-cont-folder max-label max-var)
+      (lambda (label cont max-label max-var)
+        (values (max label max-label)
+                (match cont
+                  (($ $kargs names vars body)
+                   (let lp ((body body) (max-var (fold max max-var vars)))
+                     (match body
+                       (($ $letk conts body) (lp body max-var))
+                       (($ $letrec names vars funs body)
+                        (lp body (fold max max-var vars)))
+                       (_ max-var))))
+                  (($ $kfun src meta self)
+                   (max self max-var))
+                  (_ max-var))))
+      fun -1 -1))
+    (($ $program conts)
+     (define (fold/2 proc in s0 s1)
+      (if (null? in)
+          (values s0 s1)
+          (let-values (((s0 s1) (proc (car in) s0 s1)))
+            (fold/2 proc (cdr in) s0 s1))))
+     (let lp ((conts conts) (max-label -1) (max-var -1))
+       (if (null? conts)
+           (values max-label max-var)
+           (call-with-values (lambda ()
+                               ((make-local-cont-folder max-label max-var)
+                                (lambda (label cont max-label max-var)
+                                  (values (max label max-label)
+                                          (match cont
+                                            (($ $kargs names vars body)
+                                             (fold max max-var vars))
+                                            (($ $kfun src meta self)
+                                             (max self max-var))
+                                            (_ max-var))))
+                                (car conts) max-label max-var))
+             (lambda (max-label max-var)
+               (lp (cdr conts) max-label max-var))))))))
 
 (define (fold-conts proc seed fun)
   ((make-global-cont-folder seed) proc fun seed))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 08e511d4e..6d84f0826 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -34,249 +34,226 @@
   #:use-module ((srfi srfi-1) #:select (fold
                                         lset-union lset-difference
                                         list-index))
-  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
   #:export (convert-closures))
 
-(define (union s1 s2)
-  (lset-union eq? s1 s2))
+;; free := var ...
 
-(define (difference s1 s2)
-  (lset-difference eq? s1 s2))
-
-;; bound := sym ...
-;; free := sym ...
-
-(define (convert-free-var sym self bound k)
+(define (convert-free-var var self free k)
   "Convert one possibly free variable reference to a bound reference.
 
-If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
+If @var{var} is free (i.e., present in @var{free},), it is replaced
 by a closure reference via a @code{free-ref} primcall, and @var{k} is
-called with the new var.  Otherwise @var{sym} is bound, so @var{k} is
-called with @var{sym}.
-
-@var{k} should return two values: a term and a list of additional free
-values in the term."
-  (if (memq sym bound)
-      (k sym)
-      (let-fresh (k*) (sym*)
-        (receive (exp free) (k sym*)
-          (values (build-cps-term
-                    ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
-                      ($continue k* #f ($primcall 'free-ref (self sym)))))
-                  (cons sym free))))))
+called with the new var.  Otherwise @var{var} is bound, so @var{k} is
+called with @var{var}."
+  (cond
+   ((list-index (cut eq? <> var) free)
+    => (lambda (free-idx)
+         (let-fresh (k* kidx) (idx var*)
+           (build-cps-term
+             ($letk ((kidx ($kargs ('idx) (idx)
+                             ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+                               ($continue k* #f
+                                 ($primcall 'free-ref (self idx)))))))
+               ($continue kidx #f ($const free-idx)))))))
+   (else (k var))))
   
-(define (convert-free-vars syms self bound k)
+(define (convert-free-vars vars self free k)
   "Convert a number of possibly free references to bound references.
-@var{k} is called with the bound references, and should return two
-values: the term and a list of additional free variables in the term."
-  (match syms
+@var{k} is called with the bound references, and should return the
+term."
+  (match vars
     (() (k '()))
-    ((sym . syms)
-     (convert-free-var sym self bound
-                       (lambda (sym)
-                         (convert-free-vars syms self bound
-                                            (lambda (syms)
-                                              (k (cons sym syms)))))))))
+    ((var . vars)
+     (convert-free-var var self free
+                       (lambda (var)
+                         (convert-free-vars vars self free
+                                            (lambda (vars)
+                                              (k (cons var vars)))))))))
   
-(define (init-closure src v free outer-self outer-bound body)
+(define (init-closure src v free outer-self outer-free body)
   "Initialize the free variables @var{free} in a closure bound to
 @var{v}, and continue with @var{body}.  @var{outer-self} must be the
 label of the outer procedure, where the initialization will be
-performed, and @var{outer-bound} is the list of bound variables there."
+performed, and @var{outer-free} is the list of free variables there."
   (fold (lambda (free idx body)
-          (let-fresh (k) (idxsym)
+          (let-fresh (k) (idxvar)
             (build-cps-term
               ($letk ((k ($kargs () () ,body)))
                 ,(convert-free-var
-                  free outer-self outer-bound
+                  free outer-self outer-free
                   (lambda (free)
                     (values (build-cps-term
-                              ($letconst (('idx idxsym idx))
+                              ($letconst (('idx idxvar idx))
                                 ($continue k src
-                                  ($primcall 'free-set! (v idxsym free)))))
+                                  ($primcall 'free-set! (v idxvar free)))))
                             '())))))))
         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)
-     (receive (conts free) (cc* conts self bound)
-       (receive (body free*) (cc body self bound)
-         (values (build-cps-term ($letk ,conts ,body))
-                 (union free free*)))))
-
-    (($ $cont sym ($ $kargs names syms body))
-     (receive (body free) (cc body self (append syms bound))
-       (values (build-cps-cont (sym ($kargs names syms ,body)))
+(define (compute-free-vars exp)
+  "Compute the set of free variables for all $fun instances in
+@var{exp}."
+  (let ((table (make-hash-table)))
+    (define (union a b)
+      (lset-union eq? a b))
+    (define (difference a b)
+      (lset-difference eq? a b))
+    (define (visit-cont cont bound)
+      (match cont
+        (($ $cont label ($ $kargs names vars body))
+         (visit-term body (append vars bound)))
+        (($ $cont label ($ $kfun src meta self tail clause))
+         (let ((free (if clause
+                         (visit-cont clause (list self))
+                         '())))
+           (hashq-set! table label (cons free cont))
+           (difference free bound)))
+        (($ $cont label ($ $kclause arity body alternate))
+         (let ((free (visit-cont body bound)))
+           (if alternate
+               (union (visit-cont alternate bound) free)
                free)))
+        (($ $cont) '())))
+    (define (visit-term term bound)
+      (match term
+        (($ $letk conts body)
+         (fold (lambda (cont free)
+                 (union (visit-cont cont bound) free))
+               (visit-term body bound)
+               conts))
+        (($ $letrec names vars (($ $fun () cont) ...) body)
+         (let ((bound (append vars bound)))
+           (fold (lambda (cont free)
+                   (union (visit-cont cont bound) free))
+                 (visit-term body bound)
+                 cont)))
+        (($ $continue k src ($ $fun () body))
+         (visit-cont body bound))
+        (($ $continue k src exp)
+         (visit-exp exp bound))))
+    (define (visit-exp exp bound)
+      (define (adjoin var free)
+        (if (or (memq var bound) (memq var free))
+            free
+            (cons var free)))
+      (match exp
+        ((or ($ $void) ($ $const) ($ $prim)) '())
+        (($ $call proc args)
+         (fold adjoin (adjoin proc '()) args))
+        (($ $callk k* proc args)
+         (fold adjoin (adjoin proc '()) args))
+        (($ $primcall name args)
+         (fold adjoin '() args))
+        (($ $values args)
+         (fold adjoin '() args))
+        (($ $prompt escape? tag handler)
+         (adjoin tag '()))))
 
-    (($ $cont sym ($ $kfun src meta self tail clause))
-     (receive (clause free) (if clause
-                                (cc clause self (list self))
-                                (values #f '()))
-       (values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
-               free)))
+    (let ((free (visit-cont exp '())))
+      (unless (null? free)
+        (error "Expected no free vars in toplevel thunk" free exp))
+      table)))
 
-    (($ $cont sym ($ $kclause arity body alternate))
-     (receive (body free) (cc body self bound)
-       (receive (alternate free*) (if alternate
-                                      (cc alternate self bound)
-                                      (values #f '()))
-         (values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
-                 (union free free*)))))
-
-    (($ $cont)
-     ;; Other kinds of continuations don't bind values and don't have
-     ;; bodies.
-     (values exp '()))
-
-    ;; Remove letrec.
-    (($ $letrec names syms funs body)
-     (let ((bound (append bound syms)))
-       (receive (body free) (cc body self bound)
-         (let lp ((in (map list names syms funs))
-                  (bindings (lambda (body) body))
-                  (body body)
-                  (free free))
-           (match in
-             (() (values (bindings body) free))
-             (((name sym ($ $fun () (and fun-body
-                                         ($ $cont _ ($ $kfun src))))) . in)
-              (receive (fun-body fun-free) (cc fun-body #f '())
-                (lp in
-                    (lambda (body)
-                      (let-fresh (k) ()
-                        (build-cps-term
-                          ($letk ((k ($kargs (name) (sym) ,(bindings body))))
-                            ($continue k src
-                              ($fun fun-free ,fun-body))))))
-                    (init-closure src sym fun-free self bound body)
-                    (union free (difference fun-free bound))))))))))
-
-    (($ $continue k src
-        (or ($ $void)
-            ($ $const)
-            ($ $prim)))
-     (values exp '()))
-
-    (($ $continue k src ($ $fun () body))
-     (receive (body free) (cc body #f '())
-       (match free
-         (()
-          (values (build-cps-term
-                    ($continue k src ($fun free ,body)))
-                  free))
-         (_
-          (values
-           (let-fresh (kinit) (v)
-             (build-cps-term
-               ($letk ((kinit ($kargs (v) (v)
-                                ,(init-closure
-                                  src v free self bound
-                                  (build-cps-term
-                                    ($continue k src ($values (v))))))))
-                 ($continue kinit src ($fun free ,body)))))
-           (difference free bound))))))
-
-    (($ $continue k src ($ $call proc args))
-     (convert-free-vars (cons proc args) self bound
-                        (match-lambda
-                         ((proc . args)
-                          (values (build-cps-term
-                                    ($continue k src ($call proc args)))
-                                  '())))))
-
-    (($ $continue k src ($ $callk k* proc args))
-     (convert-free-vars (cons proc args) self bound
-                        (match-lambda
-                         ((proc . args)
-                          (values (build-cps-term
-                                    ($continue k src ($callk k* proc args)))
-                                  '())))))
-
-    (($ $continue k src ($ $primcall name args))
-     (convert-free-vars args self bound
-                        (lambda (args)
-                          (values (build-cps-term
-                                    ($continue k src ($primcall name args)))
-                                  '()))))
-
-    (($ $continue k src ($ $values args))
-     (convert-free-vars args self bound
-                        (lambda (args)
-                          (values (build-cps-term
-                                    ($continue k src ($values args)))
-                                  '()))))
-
-    (($ $continue k src ($ $prompt escape? tag handler))
-     (convert-free-var
-      tag self bound
-      (lambda (tag)
-        (values (build-cps-term
-                  ($continue k src ($prompt escape? tag handler)))
-                '()))))
-
-    (_ (error "what" exp))))
-
-;; Convert the slot arguments of 'free-ref' primcalls from symbols to
-;; indices.
-(define (convert-to-indices body free)
-  (define (free-index sym)
-    (or (list-index (cut eq? <> sym) free)
-        (error "free variable not found!" sym free)))
-  (define (visit-term term)
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ($letk ,(map visit-cont conts) ,(visit-term body)))
-      (($ $continue k src ($ $primcall 'free-ref (closure sym)))
-       ,(let-fresh () (idx)
+(define (convert-one label table)
+  (match (hashq-ref table label)
+    ((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
+     (define (visit-cont cont)
+       (rewrite-cps-cont cont
+         (($ $cont label ($ $kargs names vars body))
+          (label ($kargs names vars ,(visit-term body))))
+         (($ $cont label ($ $kfun src meta self tail clause))
+          (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+         (($ $cont label ($ $kclause arity body alternate))
+          (label ($kclause ,arity ,(visit-cont body)
+                         ,(and alternate (visit-cont alternate)))))
+         (($ $cont) ,cont)))
+     (define (visit-term term)
+       (match term
+         (($ $letk conts body)
           (build-cps-term
-            ($letconst (('idx idx (free-index sym)))
-              ($continue k src ($primcall 'free-ref (closure idx)))))))
-      (($ $continue k src ($ $fun free body))
-       ($continue k src
-         ($fun free ,(convert-to-indices body free))))
-      (($ $continue)
-       ,term)))
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont sym ($ $kargs names syms body))
-       (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kclause arity body alternate))
-       (sym ($kclause ,arity ,(visit-cont body)
-                      ,(and alternate (visit-cont alternate)))))
-      ;; Other kinds of continuations don't bind values and don't have
-      ;; bodies.
-      (($ $cont)
-       ,cont)))
+            ($letk ,(map visit-cont conts) ,(visit-term body))))
 
-  (rewrite-cps-cont body
-    (($ $cont sym ($ $kfun src meta self tail clause))
-     (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
+         ;; Remove letrec.
+         (($ $letrec names vars funs body)
+          (let lp ((in (map list names vars funs))
+                   (bindings (lambda (body) body))
+                   (body (visit-term body)))
+            (match in
+              (() (bindings body))
+              (((name var ($ $fun ()
+                             (and fun-body
+                                  ($ $cont kfun ($ $kfun src))))) . in)
+               (match (hashq-ref table kfun)
+                 ((fun-free . _)
+                  (lp in
+                      (lambda (body)
+                        (let-fresh (k) ()
+                          (build-cps-term
+                            ($letk ((k ($kargs (name) (var) ,(bindings body))))
+                              ($continue k src
+                                ($closure kfun (length fun-free)))))))
+                      (init-closure src var fun-free self free body))))))))
+
+         (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
+          term)
+
+         (($ $continue k src ($ $fun () ($ $cont kfun)))
+          (match (hashq-ref table kfun)
+            ((() . _)
+             (build-cps-term ($continue k src ($closure kfun 0))))
+            ((fun-free . _)
+             (let-fresh (kinit) (v)
+               (build-cps-term
+                 ($letk ((kinit ($kargs (v) (v)
+                                  ,(init-closure
+                                    src v fun-free self free
+                                    (build-cps-term
+                                      ($continue k src ($values (v))))))))
+                   ($continue kinit src
+                     ($closure kfun (length fun-free)))))))))
+
+         (($ $continue k src ($ $call proc args))
+          (convert-free-vars (cons proc args) self free
+                             (match-lambda
+                              ((proc . args)
+                               (build-cps-term
+                                 ($continue k src ($call proc args)))))))
+
+         (($ $continue k src ($ $callk k* proc args))
+          (convert-free-vars (cons proc args) self free
+                             (match-lambda
+                              ((proc . args)
+                               (build-cps-term
+                                 ($continue k src ($callk k* proc args)))))))
+
+         (($ $continue k src ($ $primcall name args))
+          (convert-free-vars args self free
+                             (lambda (args)
+                               (build-cps-term
+                                 ($continue k src ($primcall name args))))))
+
+         (($ $continue k src ($ $values args))
+          (convert-free-vars args self free
+                             (lambda (args)
+                               (build-cps-term
+                                 ($continue k src ($values args))))))
+
+         (($ $continue k src ($ $prompt escape? tag handler))
+          (convert-free-var tag self free
+                            (lambda (tag)
+                              (build-cps-term
+                                ($continue k src
+                                  ($prompt escape? tag handler))))))))
+     (visit-cont fun))))
 
 (define (convert-closures fun)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
   (with-fresh-name-state fun
-    (receive (body free) (cc fun #f '())
-      (unless (null? free)
-        (error "Expected no free vars in toplevel thunk" fun body free))
-      (convert-to-indices body free))))
+    (let* ((table (compute-free-vars fun))
+           (labels (sort (hash-map->list (lambda (k v) k) table) <)))
+      (build-cps-term
+        ($program ,(map (cut convert-one <> table) labels))))))
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index eb873d398..e3e31a0be 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -245,10 +245,10 @@
          (emit-load-constant asm dst *unspecified*))
         (($ $const exp)
          (emit-load-constant asm dst exp))
-        (($ $fun () ($ $cont k))
+        (($ $closure k 0)
          (emit-load-static-procedure asm dst k))
-        (($ $fun free ($ $cont k))
-         (emit-make-closure asm dst k (length free)))
+        (($ $closure k nfree)
+         (emit-make-closure asm dst k nfree))
         (($ $primcall 'current-module)
          (emit-current-module asm dst))
         (($ $primcall 'cached-toplevel-box (scope name bound?))
@@ -474,43 +474,18 @@
       (($ $cont k ($ $kfun src meta self tail clause))
        (compile-entry)))))
 
-(define (visit-funs proc exp)
-  (match exp
-    (($ $continue _ _ exp)
-     (visit-funs proc exp))
-
-    (($ $fun free body)
-     (visit-funs proc body))
-
-    (($ $letk conts body)
-     (visit-funs proc body)
-     (for-each (lambda (cont) (visit-funs proc cont)) conts))
-
-    (($ $cont sym ($ $kargs names syms body))
-     (visit-funs proc body))
-
-    (($ $cont sym ($ $kclause arity body alternate))
-     (visit-funs proc body)
-     (when alternate
-       (visit-funs proc alternate)))
-
-    (($ $cont sym ($ $kfun src meta self tail clause))
-     (proc exp)
-     (when clause
-       (visit-funs proc clause)))
-
-    (_ (values))))
-
 (define (compile-bytecode exp env opts)
   (let* ((exp (fix-arities exp))
          (exp (optimize exp opts))
          (exp (convert-closures exp))
+         ;; first-order optimization should go here
          (exp (reify-primitives exp))
          (exp (renumber exp))
          (asm (make-assembler)))
-    (visit-funs (lambda (fun)
-                  (compile-fun fun asm))
-                exp)
+    (match exp
+      (($ $program funs)
+       (for-each (lambda (fun) (compile-fun fun asm))
+                 funs)))
     (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
             env
             env)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index efafd745d..6bc8d5af5 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -851,7 +851,7 @@ body continuation in the prompt."
           (define (use! sym)
             (add-use! sym label))
           (match exp
-            ((or ($ $void) ($ $const) ($ $prim)) #f)
+            ((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
             (($ $call proc args)
              (use! proc)
              (for-each use! args))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 50d1db801..a4d7099ed 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -33,16 +33,16 @@
   #:export (reify-primitives))
 
 (define (module-box src module name public? bound? val-proc)
-  (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
+  (let-fresh (kbox) (module-var name-var public?-var bound?-var box)
     (build-cps-term
-      ($letconst (('module module-sym module)
-                  ('name name-sym name)
-                  ('public? public?-sym public?)
-                  ('bound? bound?-sym bound?))
+      ($letconst (('module module-var module)
+                  ('name name-var name)
+                  ('public? public?-var public?)
+                  ('bound? bound?-var bound?))
         ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
           ($continue kbox src
             ($primcall 'cached-module-box
-                       (module-sym name-sym public?-sym bound?-sym))))))))
+                       (module-var name-var public?-var bound?-var))))))))
 
 (define (primitive-module name)
   (case name
@@ -81,11 +81,11 @@
                   ($continue k src ($primcall 'box-ref (box)))))))
 
 (define (builtin-ref idx k src)
-  (let-fresh () (idx-sym)
+  (let-fresh () (idx-var)
     (build-cps-term
-      ($letconst (('idx idx-sym idx))
+      ($letconst (('idx idx-var idx))
         ($continue k src
-          ($primcall 'builtin-ref (idx-sym)))))))
+          ($primcall 'builtin-ref (idx-var)))))))
 
 (define (reify-clause ktail)
   (let-fresh (kclause kbody kthrow) (wna false str eol throw)
@@ -105,63 +105,72 @@
                         ,(primitive-ref 'throw kthrow #f)))))
                  ,#f)))))
 
-;; FIXME: Operate on one function at a time, for efficiency.
-(define (reify-primitives fun)
-  (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
-      (define (visit-fun term)
-        (rewrite-cps-exp term
-          (($ $fun free body)
-           ($fun free ,(visit-cont body)))))
-      (define (visit-cont cont)
-        (rewrite-cps-cont cont
-          (($ $cont sym ($ $kargs names syms body))
-           (sym ($kargs names syms ,(visit-term body))))
-          (($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
-           ;; A case-lambda with no clauses.  Reify a clause.
-           (sym ($kfun src meta self ,tail ,(reify-clause ktail))))
-          (($ $cont sym ($ $kfun src meta self tail clause))
-           (sym ($kfun src meta self ,tail ,(visit-cont clause))))
-          (($ $cont sym ($ $kclause arity body alternate))
-           (sym ($kclause ,arity ,(visit-cont body)
-                          ,(and alternate (visit-cont alternate)))))
-          (($ $cont)
-           ,cont)))
-      (define (visit-term term)
-        (rewrite-cps-term term
-          (($ $letk conts body)
-           ($letk ,(map visit-cont conts) ,(visit-term body)))
-          (($ $continue k src exp)
-           ,(match exp
-              (($ $prim name)
-               (match (vector-ref conts k)
-                 (($ $kargs (_))
-                  (cond
-                   ((builtin-name->index name)
-                    => (lambda (idx)
-                         (builtin-ref idx k src)))
-                   (else (primitive-ref name k src))))
-                 (_ (build-cps-term ($continue k src ($void))))))
-              (($ $fun)
-               (build-cps-term ($continue k src ,(visit-fun exp))))
-              (($ $primcall 'call-thunk/no-inline (proc))
-               (build-cps-term
-                 ($continue k src ($call proc ()))))
-              (($ $primcall name args)
-               (cond
-                ((or (prim-instruction name) (branching-primitive? name))
-                 ;; Assume arities are correct.
-                 term)
-                (else
-                 (let-fresh (k*) (v)
-                   (build-cps-term
-                     ($letk ((k* ($kargs (v) (v)
-                                   ($continue k src ($call v args)))))
-                       ,(cond
-                         ((builtin-name->index name)
-                          => (lambda (idx)
-                               (builtin-ref idx k* src)))
-                         (else (primitive-ref name k* src)))))))))
-              (_ term)))))
+(define (reify-primitives/1 fun single-value-conts)
+  (define (visit-clause cont)
+    (rewrite-cps-cont cont
+      (($ $cont label ($ $kclause arity body alternate))
+       (label ($kclause ,arity ,(visit-cont body)
+                      ,(and alternate (visit-clause alternate)))))))
+  (define (visit-cont cont)
+    (rewrite-cps-cont cont
+      (($ $cont label ($ $kargs (name) (var) body))
+       ,(begin
+          (bitvector-set! single-value-conts label #t)
+          (build-cps-cont
+            (label ($kargs (name) (var) ,(visit-term body))))))
+      (($ $cont label ($ $kargs names vars body))
+       (label ($kargs names vars ,(visit-term body))))
+      (($ $cont)
+       ,cont)))
+  (define (visit-term term)
+    (match term
+      (($ $letk conts body)
+       ;; Visit continuations before their uses.
+       (let ((conts (map visit-cont conts)))
+         (build-cps-term
+           ($letk ,conts ,(visit-term body)))))
+      (($ $continue k src exp)
+       (match exp
+         (($ $prim name)
+          (if (bitvector-ref single-value-conts k)
+              (cond
+               ((builtin-name->index name)
+                => (lambda (idx)
+                     (builtin-ref idx k src)))
+               (else (primitive-ref name k src)))
+              (build-cps-term ($continue k src ($void)))))
+         (($ $primcall 'call-thunk/no-inline (proc))
+          (build-cps-term
+            ($continue k src ($call proc ()))))
+         (($ $primcall name args)
+          (cond
+           ((or (prim-instruction name) (branching-primitive? name))
+            ;; Assume arities are correct.
+            term)
+           (else
+            (let-fresh (k*) (v)
+              (build-cps-term
+                ($letk ((k* ($kargs (v) (v)
+                              ($continue k src ($call v args)))))
+                  ,(cond
+                    ((builtin-name->index name)
+                     => (lambda (idx)
+                          (builtin-ref idx k* src)))
+                    (else (primitive-ref name k* src)))))))))
+         (_ term)))))
 
-      (visit-cont fun))))
+  (rewrite-cps-cont fun
+    (($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
+     ;; A case-lambda with no clauses.  Reify a clause.
+     (label ($kfun src meta self ,tail ,(reify-clause ktail))))
+    (($ $cont label ($ $kfun src meta self tail clause))
+     (label ($kfun src meta self ,tail ,(visit-clause clause))))))
+
+(define (reify-primitives term)
+  (with-fresh-name-state term
+    (let ((single-value-conts (make-bitvector (label-counter) #f)))
+      (rewrite-cps-term term
+        (($ $program procs)
+         ($program ,(map (lambda (cont)
+                           (reify-primitives/1 cont single-value-conts))
+                         procs)))))))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 0621ec92e..ab27653f6 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -169,99 +169,112 @@
                  (set! queue (cons body queue))))
               (($ $continue) #f)))
 
-          (collect-conts fun)
           (match fun
             (($ $cont kfun)
+             (collect-conts fun)
              (set! next-label (sort-conts kfun labels next-label))
              (visit-cont fun)
-             (for-each compute-names-in-fun (reverse queue)))))
+             (for-each compute-names-in-fun (reverse queue)))
+            (($ $program conts)
+             (for-each compute-names-in-fun conts))))
 
         (compute-names-in-fun fun)
         (values labels vars next-label next-var)))))
 
-(define (renumber fun)
-  (call-with-values (lambda () (compute-new-labels-and-vars fun))
+(define (apply-renumbering term labels vars)
+  (define (relabel label) (vector-ref labels label))
+  (define (rename var) (vector-ref vars var))
+  (define (rename-kw-arity arity)
+    (match arity
+      (($ $arity req opt rest kw aok?)
+       (make-$arity req opt rest
+                    (map (match-lambda
+                          ((kw kw-name kw-var)
+                           (list kw kw-name (rename kw-var))))
+                         kw)
+                    aok?))))
+  (define (must-visit-cont cont)
+    (or (visit-cont cont)
+        (error "internal error -- failed to visit cont")))
+  (define (visit-conts conts)
+    (match conts
+      (() '())
+      ((cont . conts)
+       (cond
+        ((visit-cont cont)
+         => (lambda (cont)
+              (cons cont (visit-conts conts))))
+        (else (visit-conts conts))))))
+  (define (visit-cont cont)
+    (match cont
+      (($ $cont label cont)
+       (let ((label (relabel label)))
+         (and
+          label
+          (rewrite-cps-cont cont
+            (($ $kargs names vars body)
+             (label ($kargs names (map rename vars) ,(visit-term body))))
+            (($ $kfun src meta self tail clause)
+             (label
+              ($kfun src meta (rename self) ,(must-visit-cont tail)
+                ,(and clause (must-visit-cont clause)))))
+            (($ $ktail)
+             (label ($ktail)))
+            (($ $kclause arity body alternate)
+             (label
+              ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
+                        ,(and alternate (must-visit-cont alternate)))))
+            (($ $kreceive ($ $arity req () rest () #f) kargs)
+             (label ($kreceive req rest (relabel kargs))))
+            (($ $kif kt kf)
+             (label ($kif (relabel kt) (relabel kf))))))))))
+  (define (visit-term term)
+    (rewrite-cps-term term
+      (($ $letk conts body)
+       ,(match (visit-conts conts)
+          (() (visit-term body))
+          (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
+      (($ $letrec names vars funs body)
+       ($letrec names (map rename vars) (map visit-fun funs)
+         ,(visit-term body)))
+      (($ $continue k src exp)
+       ($continue (relabel k) src ,(visit-exp exp)))))
+  (define (visit-exp exp)
+    (match exp
+      ((or ($ $void) ($ $const) ($ $prim))
+       exp)
+      (($ $closure k nfree)
+       (build-cps-exp ($closure (relabel k) nfree)))
+      (($ $fun)
+       (visit-fun exp))
+      (($ $values args)
+       (let ((args (map rename args)))
+         (build-cps-exp ($values args))))
+      (($ $call proc args)
+       (let ((args (map rename args)))
+         (build-cps-exp ($call (rename proc) args))))
+      (($ $callk k proc args)
+       (let ((args (map rename args)))
+         (build-cps-exp ($callk (relabel k) (rename proc) args))))
+      (($ $primcall name args)
+       (let ((args (map rename args)))
+         (build-cps-exp ($primcall name args))))
+      (($ $prompt escape? tag handler)
+       (build-cps-exp
+         ($prompt escape? (rename tag) (relabel handler))))))
+  (define (visit-fun fun)
+    (rewrite-cps-exp fun
+      (($ $fun free body)
+       ($fun (map rename free) ,(must-visit-cont body)))))
+
+  (match term
+    (($ $cont)
+     (must-visit-cont term))
+    (($ $program conts)
+     (build-cps-term
+       ($program ,(map must-visit-cont conts))))))
+
+(define (renumber term)
+  (call-with-values (lambda () (compute-new-labels-and-vars term))
     (lambda (labels vars nlabels nvars)
-      (define (relabel label) (vector-ref labels label))
-      (define (rename var) (vector-ref vars var))
-      (define (rename-kw-arity arity)
-        (match arity
-          (($ $arity req opt rest kw aok?)
-           (make-$arity req opt rest
-                        (map (match-lambda
-                              ((kw kw-name kw-var)
-                               (list kw kw-name (rename kw-var))))
-                             kw)
-                        aok?))))
-      (define (must-visit-cont cont)
-        (or (visit-cont cont)
-            (error "internal error -- failed to visit cont")))
-      (define (visit-conts conts)
-        (match conts
-          (() '())
-          ((cont . conts)
-           (cond
-            ((visit-cont cont)
-             => (lambda (cont)
-                  (cons cont (visit-conts conts))))
-            (else (visit-conts conts))))))
-      (define (visit-cont cont)
-        (match cont
-          (($ $cont label cont)
-           (let ((label (relabel label)))
-             (and
-              label
-              (rewrite-cps-cont cont
-                (($ $kargs names vars body)
-                 (label ($kargs names (map rename vars) ,(visit-term body))))
-                (($ $kfun src meta self tail clause)
-                 (label
-                  ($kfun src meta (rename self) ,(must-visit-cont tail)
-                    ,(and clause (must-visit-cont clause)))))
-                (($ $ktail)
-                 (label ($ktail)))
-                (($ $kclause arity body alternate)
-                 (label
-                  ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
-                            ,(and alternate (must-visit-cont alternate)))))
-                (($ $kreceive ($ $arity req () rest () #f) kargs)
-                 (label ($kreceive req rest (relabel kargs))))
-                (($ $kif kt kf)
-                 (label ($kif (relabel kt) (relabel kf))))))))))
-      (define (visit-term term)
-        (rewrite-cps-term term
-          (($ $letk conts body)
-           ,(match (visit-conts conts)
-              (() (visit-term body))
-              (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
-          (($ $letrec names vars funs body)
-           ($letrec names (map rename vars) (map visit-fun funs)
-                    ,(visit-term body)))
-          (($ $continue k src exp)
-           ($continue (relabel k) src ,(visit-exp exp)))))
-      (define (visit-exp exp)
-        (match exp
-          ((or ($ $void) ($ $const) ($ $prim))
-           exp)
-          (($ $fun)
-           (visit-fun exp))
-          (($ $values args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($values args))))
-          (($ $call proc args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($call (rename proc) args))))
-          (($ $callk k proc args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($callk (relabel k) (rename proc) args))))
-          (($ $primcall name args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($primcall name args))))
-          (($ $prompt escape? tag handler)
-           (build-cps-exp
-             ($prompt escape? (rename tag) (relabel handler))))))
-      (define (visit-fun fun)
-        (rewrite-cps-exp fun
-          (($ $fun free body)
-           ($fun (map rename free) ,(must-visit-cont body)))))
-      (values (must-visit-cont fun) nlabels nvars))))
+      (values (apply-renumbering term labels vars) nlabels nvars))))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 9f1899fd4..47e628443 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -442,7 +442,7 @@ are comparable with eqv?.  A tmp slot may be used."
                 ;; are finished with the scan, we kill uses of the
                 ;; terminator, but leave its definitions.
                 (match (find-expression body)
-                  ((or ($ $void) ($ $const) ($ $prim) ($ $fun)
+                  ((or ($ $void) ($ $const) ($ $prim) ($ $closure)
                        ($ $primcall) ($ $prompt)
                        ;; If $values has more than one argument, it may
                        ;; use a temporary, which would invalidate our