From 828ed94469b4c8cf69db08e6aeb12b399b67ed20 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 28 Mar 2014 16:29:16 +0100
Subject: [PATCH] Replace all let-gensyms uses with let-fresh

* .dir-locals.el: Add with-fresh-name-state.
* module/language/cps.scm (fresh-label, fresh-var): Signal an error if
  the counters are not initialized.
  (with-fresh-name-state): New macro.
  (make-cont-folder): New macro, generates an n-ary folder.
  (compute-max-label-and-var): New function, uses make-cont-folder.
  (fold-conts): Use make-cont-folder.
  (let-gensyms): Remove.

* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/dce.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/specialize-primcalls.scm: Use let-fresh instead of
  let-gensyms, and wrap in a with-fresh-name-state as needed.

* module/language/tree-il/compile-cps.scm: Remove hack to avoid
  importing let-gensyms from (language tree-il).
---
 .dir-locals.el                               |   1 +
 module/language/cps.scm                      | 127 +++++++----
 module/language/cps/arities.scm              |  28 +--
 module/language/cps/closure-conversion.scm   |  25 +--
 module/language/cps/constructors.scm         |  20 +-
 module/language/cps/dce.scm                  | 209 ++++++++++---------
 module/language/cps/elide-values.scm         |  16 +-
 module/language/cps/reify-primitives.scm     | 117 ++++++-----
 module/language/cps/specialize-primcalls.scm | 153 +++++++-------
 module/language/tree-il/compile-cps.scm      |   2 +-
 10 files changed, 378 insertions(+), 320 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 520244a37..2efca6481 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -13,6 +13,7 @@
      (eval . (put 'with-statprof       'scheme-indent-function 1))
      (eval . (put 'let-gensyms         'scheme-indent-function 1))
      (eval . (put 'let-fresh           'scheme-indent-function 2))
+     (eval . (put 'with-fresh-name-state 'scheme-indent-function 1))
      (eval . (put 'build-cps-term      'scheme-indent-function 0))
      (eval . (put 'build-cps-exp       'scheme-indent-function 0))
      (eval . (put 'build-cps-cont      'scheme-indent-function 0))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index cb7c4fbc3..1efc0a508 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -107,6 +107,7 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:export (;; Helper.
             $arity
             make-$arity
@@ -126,7 +127,8 @@
             ;; Fresh names.
             label-counter var-counter
             fresh-label fresh-var
-            let-fresh let-gensyms
+            with-fresh-name-state compute-max-label-and-var
+            let-fresh
 
             ;; Building macros.
             build-cps-term build-cps-cont build-cps-exp
@@ -195,14 +197,16 @@
 (define var-counter (make-parameter #f))
 
 (define (fresh-label)
-  (let ((count (label-counter)))
+  (let ((count (or (label-counter)
+                   (error "fresh-label outside with-fresh-name-state"))))
     (label-counter (1+ count))
     count))
 
 ;; FIXME: Currently vars and labels need to be unique, so we use the
 ;; label counter.
 (define (fresh-var)
-  (let ((count (label-counter)))
+  (let ((count (or (label-counter)
+                   (error "fresh-var outside with-fresh-name-state"))))
     (label-counter (1+ count))
     count))
 
@@ -211,11 +215,17 @@
         (var (fresh-var)) ...)
     body ...))
 
-(define-syntax let-gensyms
-  (syntax-rules ()
-    ((_ (sym ...) body body* ...)
-     (let ((sym (gensym (symbol->string 'sym))) ...)
-       body body* ...))))
+;; FIXME: Same FIXME as above.
+(define-syntax-rule (with-fresh-name-state fun body ...)
+  (begin
+    (when (or (label-counter) (var-counter))
+      (error "with-fresh-name-state should not be called recursively"))
+    (call-with-values (lambda ()
+                        (compute-max-label-and-var fun))
+      (lambda (max-label max-var)
+        (parameterize ((label-counter (1+ (max max-label max-var)))
+                       (var-counter (1+ (max max-label max-var))))
+          body ...)))))
 
 (define-syntax build-arity
   (syntax-rules (unquote)
@@ -432,42 +442,73 @@
     (_
      (error "unexpected cps" exp))))
 
+(define-syntax-rule (make-cont-folder seed ...)
+  (lambda (proc fun seed ...)
+    (define (fold-values proc in seed ...)
+      (if (null? in)
+          (values seed ...)
+          (let-values (((seed ...) (proc (car in) seed ...)))
+            (fold-values proc (cdr in) seed ...))))
+
+    (define (cont-folder cont seed ...)
+      (match cont
+        (($ $cont k cont)
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (match cont
+             (($ $kargs names syms body)
+              (term-folder body seed ...))
+
+             (($ $kentry self tail clauses)
+              (let-values (((seed ...) (cont-folder tail seed ...)))
+                (fold-values cont-folder clauses seed ...)))
+
+             (($ $kclause arity body)
+              (cont-folder body seed ...))
+
+             (_ (values seed ...)))))))
+
+    (define (fun-folder fun seed ...)
+      (match fun
+        (($ $fun src meta free body)
+         (cont-folder body seed ...))))
+
+    (define (term-folder term seed ...)
+      (match term
+        (($ $letk conts body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (fold-values cont-folder conts seed ...)))
+
+        (($ $continue k src exp)
+         (match exp
+           (($ $fun) (fun-folder exp seed ...))
+           (_ (values seed ...))))
+
+        (($ $letrec names syms funs body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (fold-values fun-folder funs seed ...)))))
+
+    (fun-folder fun seed ...)))
+
+(define (compute-max-label-and-var fun)
+  (define (max* var max-var)
+    (if (number? var)
+        (max var max-var)
+        max-var))
+  ((make-cont-folder max-label max-var)
+   (lambda (label cont max-label max-var)
+     (values (max label max-label)
+             (match cont
+               (($ $kargs names vars)
+                (fold max* max-var vars))
+               (($ $kentry self)
+                (max* self max-var))
+               (_ max-var))))
+   fun
+   -1
+   -1))
+
 (define (fold-conts proc seed fun)
-  (define (cont-folder cont seed)
-    (match cont
-      (($ $cont k cont)
-       (let ((seed (proc k cont seed)))
-         (match cont
-           (($ $kargs names syms body)
-            (term-folder body seed))
-
-           (($ $kentry self tail clauses)
-            (fold cont-folder (cont-folder tail seed) clauses))
-
-           (($ $kclause arity body)
-            (cont-folder body seed))
-
-           (_ seed))))))
-
-  (define (fun-folder fun seed)
-    (match fun
-      (($ $fun src meta free body)
-       (cont-folder body seed))))
-
-  (define (term-folder term seed)
-    (match term
-      (($ $letk conts body)
-       (fold cont-folder (term-folder body seed) conts))
-
-      (($ $continue k src exp)
-       (match exp
-         (($ $fun) (fun-folder exp seed))
-         (_ seed)))
-
-      (($ $letrec names syms funs body)
-       (fold fun-folder (term-folder body seed) funs))))
-
-  (fun-folder fun seed))
+  ((make-cont-folder seed) proc fun seed))
 
 (define (fold-local-conts proc seed cont)
   (define (cont-folder cont seed)
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 1cd87040b..b6e94257a 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -41,7 +41,7 @@
         (($ $letk conts body)
          ($letk ,(map visit-cont conts) ,(visit-term body)))
         (($ $letrec names syms funs body)
-         ($letrec names syms (map fix-arities funs) ,(visit-term body)))
+         ($letrec names syms (map fix-arities* funs) ,(visit-term body)))
         (($ $continue k src exp)
          ,(visit-exp k src exp))))
 
@@ -50,7 +50,7 @@
         (0
          (rewrite-cps-term (lookup-cont k conts)
            (($ $ktail)
-            ,(let-gensyms (kvoid kunspec unspec)
+            ,(let-fresh (kvoid kunspec) (unspec)
                (build-cps-term
                  ($letk* ((kunspec ($kargs (unspec) (unspec)
                                      ($continue k src
@@ -62,7 +62,7 @@
             ,(match arity
                (($ $arity () () rest () #f)
                 (if rest
-                    (let-gensyms (knil)
+                    (let-fresh (knil) ()
                       (build-cps-term
                         ($letk ((knil ($kargs () ()
                                         ($continue kargs src ($const '())))))
@@ -70,7 +70,7 @@
                     (build-cps-term
                       ($continue kargs src ,exp))))
                (_
-                (let-gensyms (kvoid kvalues void)
+                (let-fresh (kvoid kvalues) (void)
                   (build-cps-term
                     ($letk* ((kvalues ($kargs ('void) (void)
                                         ($continue k src
@@ -82,7 +82,7 @@
            (($ $kargs () () _)
             ($continue k src ,exp))
            (_
-            ,(let-gensyms (k*)
+            ,(let-fresh (k*) ()
                (build-cps-term
                  ($letk ((k* ($kargs () () ($continue k src ($void)))))
                    ($continue k* src ,exp)))))))
@@ -93,7 +93,7 @@
                (($values (sym))
                 ($continue ktail src ($primcall 'return (sym))))
                (_
-                ,(let-gensyms (k* v)
+                ,(let-fresh (k*) (v)
                    (build-cps-term
                      ($letk ((k* ($kargs (v) (v)
                                    ($continue k src
@@ -103,7 +103,7 @@
             ,(match arity
                (($ $arity (_) () rest () #f)
                 (if rest
-                    (let-gensyms (kval val nil)
+                    (let-fresh (kval) (val nil)
                       (build-cps-term
                         ($letk ((kval ($kargs ('val) (val)
                                         ($letconst (('nil nil '()))
@@ -112,14 +112,14 @@
                           ($continue kval src ,exp))))
                     (build-cps-term ($continue kargs src ,exp))))
                (_
-                (let-gensyms (kvalues value)
+                (let-fresh (kvalues) (value)
                   (build-cps-term
                     ($letk ((kvalues ($kargs ('value) (value)
                                        ($continue k src
                                          ($primcall 'values (value))))))
                       ($continue kvalues src ,exp)))))))
            (($ $kargs () () _)
-            ,(let-gensyms (k* drop)
+            ,(let-fresh (k*) (drop)
                (build-cps-term
                  ($letk ((k* ($kargs ('drop) (drop)
                                ($continue k src ($values ())))))
@@ -135,7 +135,7 @@
              ($ $values (_)))
          ,(adapt-exp 1 k src exp))
         (($ $fun)
-         ,(adapt-exp 1 k src (fix-arities exp)))
+         ,(adapt-exp 1 k src (fix-arities* exp)))
         ((or ($ $call) ($ $callk))
          ;; In general, calls have unknown return arity.  For that
          ;; reason every non-tail call has a $kreceive continuation to
@@ -158,7 +158,7 @@
                               (if (and inst (not (eq? inst name)))
                                   (build-cps-exp ($primcall inst args))
                                   exp)))
-                 (let-gensyms (k* p*)
+                 (let-fresh (k*) (p*)
                    (build-cps-term
                      ($letk ((k* ($kargs ('prim) (p*)
                                    ($continue k src ($call p* args)))))
@@ -183,7 +183,11 @@
       (($ $cont sym ($ $kentry self tail clauses))
        (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
 
-(define (fix-arities fun)
+(define (fix-arities* fun)
   (rewrite-cps-exp fun
     (($ $fun src meta free body)
      ($fun src meta free ,(fix-clause-arities body)))))
+
+(define (fix-arities fun)
+  (with-fresh-name-state fun
+    (fix-arities* fun)))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index c03b409a3..9c238a50e 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -60,7 +60,7 @@ called with @var{sym}.
 values in the term."
   (if (memq sym bound)
       (k sym)
-      (let-gensyms (k* sym*)
+      (let-fresh (k*) (sym*)
         (receive (exp free) (k sym*)
           (values (build-cps-term
                     ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
@@ -86,7 +86,7 @@ values: the term and a list of additional free variables in the term."
 label of the outer procedure, where the initialization will be
 performed, and @var{outer-bound} is the list of bound variables there."
   (fold (lambda (free idx body)
-          (let-gensyms (k idxsym)
+          (let-fresh (k) (idxsym)
             (build-cps-term
               ($letk ((k ($kargs () () ,body)))
                 ,(convert-free-var
@@ -157,7 +157,7 @@ convert functions to flat closures."
               (receive (fun-body fun-free) (cc fun-body #f '())
                 (lp in
                     (lambda (body)
-                      (let-gensyms (k)
+                      (let-fresh (k) ()
                         (build-cps-term
                           ($letk ((k ($kargs (name) (sym) ,(bindings body))))
                             ($continue k src
@@ -180,7 +180,7 @@ convert functions to flat closures."
                   free))
          (_
           (values
-           (let-gensyms (kinit v)
+           (let-fresh (kinit) (v)
              (build-cps-term
                ($letk ((kinit ($kargs (v) (v)
                                 ,(init-closure
@@ -241,7 +241,7 @@ convert functions to flat closures."
       (($ $letk conts body)
        ($letk ,(map visit-cont conts) ,(visit-term body)))
       (($ $continue k src ($ $primcall 'free-ref (closure sym)))
-       ,(let-gensyms (idx)
+       ,(let-fresh () (idx)
           (build-cps-term
             ($letconst (('idx idx (free-index sym)))
               ($continue k src ($primcall 'free-ref (closure idx)))))))
@@ -268,10 +268,11 @@ convert functions to flat closures."
 (define (convert-closures exp)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
-  (match exp
-    (($ $fun src meta () body)
-     (receive (body free) (cc body #f '())
-       (unless (null? free)
-         (error "Expected no free vars in toplevel thunk" exp body free))
-       (build-cps-exp
-         ($fun src meta free ,(convert-to-indices body free)))))))
+  (with-fresh-name-state exp
+    (match exp
+      (($ $fun src meta () body)
+       (receive (body free) (cc body #f '())
+         (unless (null? free)
+           (error "Expected no free vars in toplevel thunk" exp body free))
+         (build-cps-exp
+           ($fun src meta free ,(convert-to-indices body free))))))))
diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm
index d7ff0abc5..c7f7d94ac 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -29,7 +29,7 @@
   #:use-module (language cps)
   #:export (inline-constructors))
 
-(define (inline-constructors fun)
+(define (inline-constructors* fun)
   (define (visit-cont cont)
     (rewrite-cps-cont cont
       (($ $cont sym ($ $kargs names syms body))
@@ -46,10 +46,10 @@
        ($letk ,(map visit-cont conts)
          ,(visit-term body)))
       (($ $letrec names syms funs body)
-       ($letrec names syms (map inline-constructors funs)
+       ($letrec names syms (map inline-constructors* funs)
                 ,(visit-term body)))
       (($ $continue k src ($ $primcall 'list args))
-       ,(let-gensyms (kvalues val)
+       ,(let-fresh (kvalues) (val)
           (build-cps-term
             ($letk ((kvalues ($kargs ('val) (val)
                                ($continue k src
@@ -60,21 +60,21 @@
                     (build-cps-term
                       ($continue k src ($const '()))))
                    ((arg . args)
-                    (let-gensyms (ktail tail)
+                    (let-fresh (ktail) (tail)
                       (build-cps-term
                         ($letk ((ktail ($kargs ('tail) (tail)
                                          ($continue k src
                                            ($primcall 'cons (arg tail))))))
                           ,(lp args ktail)))))))))))
       (($ $continue k src ($ $primcall 'vector args))
-       ,(let-gensyms (kalloc vec len init)
+       ,(let-fresh (kalloc) (vec len init)
           (define (initialize args n)
             (match args
               (()
                (build-cps-term
                  ($continue k src ($primcall 'values (vec)))))
               ((arg . args)
-               (let-gensyms (knext idx)
+               (let-fresh (knext) (idx)
                  (build-cps-term
                    ($letk ((knext ($kargs () ()
                                     ,(initialize args (1+ n)))))
@@ -89,10 +89,14 @@
                 ($continue kalloc src
                   ($primcall 'make-vector (len init))))))))
       (($ $continue k src (and fun ($ $fun)))
-       ($continue k src ,(inline-constructors fun)))
+       ($continue k src ,(inline-constructors* fun)))
       (($ $continue)
        ,term)))
 
   (rewrite-cps-exp fun
     (($ $fun src meta free body)
      ($fun src meta free ,(visit-cont body)))))
+
+(define (inline-constructors fun)
+  (with-fresh-name-state fun
+    (inline-constructors* fun)))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 8b16bd1e9..6c61051d9 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -174,108 +174,109 @@
     (values fun-data-table live-vars)))
 
 (define (eliminate-dead-code fun)
-  (call-with-values (lambda () (compute-live-code fun))
-    (lambda (fun-data-table live-vars)
-      (define (value-live? sym)
-        (hashq-ref live-vars sym))
-      (define (make-adaptor name k defs)
-        (let* ((names (map (lambda (_) 'tmp) defs))
-               (syms (map (lambda (_) (gensym "tmp")) defs))
-               (live (filter-map (lambda (def sym)
-                                   (and (value-live? def)
-                                        sym))
-                                 defs syms)))
-          (build-cps-cont
-            (name ($kargs names syms
-                    ($continue k #f ($values live)))))))
-      (define (visit-fun fun)
-        (match (hashq-ref fun-data-table fun)
-          (($ $fun-data cfa effects contv live-conts defs)
-           (define (must-visit-cont cont)
-             (match (visit-cont cont)
-               ((cont) cont)
-               (conts (error "cont must be reachable" cont conts))))
-           (define (visit-cont cont)
-             (match cont
-               (($ $cont sym cont)
-                (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
-                  (#f '())
-                  (n
-                   (match cont
-                     (($ $kargs names syms body)
-                      (match (filter-map (lambda (name sym)
-                                           (and (value-live? sym)
-                                                (cons name sym)))
-                                         names syms)
-                        (((names . syms) ...)
-                         (list
-                          (build-cps-cont
-                            (sym ($kargs names syms
-                                   ,(visit-term body n))))))))
-                     (($ $kentry self tail clauses)
-                      (list
-                       (build-cps-cont
-                         (sym ($kentry self ,tail
-                                ,(visit-conts clauses))))))
-                     (($ $kclause arity body)
-                      (list
-                       (build-cps-cont
-                         (sym ($kclause ,arity
-                                ,(must-visit-cont body))))))
-                     (($ $kreceive ($ $arity req () rest () #f) kargs)
-                      (let ((defs (vector-ref defs n)))
-                        (if (and-map value-live? defs)
-                            (list (build-cps-cont (sym ,cont)))
-                            (let-gensyms (adapt)
-                              (list (make-adaptor adapt kargs defs)
-                                    (build-cps-cont
-                                      (sym ($kreceive req rest adapt))))))))
-                     (_ (list (build-cps-cont (sym ,cont))))))))))
-           (define (visit-conts conts)
-             (append-map visit-cont conts))
-           (define (visit-term term term-k-idx)
-             (match term
-               (($ $letk conts body)
-                (let ((body (visit-term body term-k-idx)))
-                  (match (visit-conts conts)
-                    (() body)
-                    (conts (build-cps-term ($letk ,conts ,body))))))
-               (($ $letrec names syms funs body)
-                (let ((body (visit-term body term-k-idx)))
-                  (match (filter-map
-                          (lambda (name sym fun)
-                            (and (value-live? sym)
-                                 (list name sym (visit-fun fun))))
-                          names syms funs)
-                    (() body)
-                    (((names syms funs) ...)
-                     (build-cps-term
-                       ($letrec names syms funs ,body))))))
-               (($ $continue k src ($ $values args))
-                (match (vector-ref defs term-k-idx)
-                  (#f term)
-                  (defs
-                    (let ((args (filter-map (lambda (use def)
-                                              (and (value-live? def) use))
-                                            args defs)))
-                      (build-cps-term
-                        ($continue k src ($values args)))))))
-               (($ $continue k src exp)
-                (if (bitvector-ref live-conts term-k-idx)
-                    (rewrite-cps-term exp
-                      (($ $fun) ($continue k src ,(visit-fun exp)))
-                      (_
-                       ,(match (vector-ref defs term-k-idx)
-                          ((or #f ((? value-live?) ...))
-                           (build-cps-term
-                             ($continue k src ,exp)))
-                          (syms
-                           (let-gensyms (adapt)
+  (with-fresh-name-state fun
+    (call-with-values (lambda () (compute-live-code fun))
+      (lambda (fun-data-table live-vars)
+        (define (value-live? sym)
+          (hashq-ref live-vars sym))
+        (define (make-adaptor name k defs)
+          (let* ((names (map (lambda (_) 'tmp) defs))
+                 (syms (map (lambda (_) (gensym "tmp")) defs))
+                 (live (filter-map (lambda (def sym)
+                                     (and (value-live? def)
+                                          sym))
+                                   defs syms)))
+            (build-cps-cont
+              (name ($kargs names syms
+                      ($continue k #f ($values live)))))))
+        (define (visit-fun fun)
+          (match (hashq-ref fun-data-table fun)
+            (($ $fun-data cfa effects contv live-conts defs)
+             (define (must-visit-cont cont)
+               (match (visit-cont cont)
+                 ((cont) cont)
+                 (conts (error "cont must be reachable" cont conts))))
+             (define (visit-cont cont)
+               (match cont
+                 (($ $cont sym cont)
+                  (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
+                    (#f '())
+                    (n
+                     (match cont
+                       (($ $kargs names syms body)
+                        (match (filter-map (lambda (name sym)
+                                             (and (value-live? sym)
+                                                  (cons name sym)))
+                                           names syms)
+                          (((names . syms) ...)
+                           (list
+                            (build-cps-cont
+                              (sym ($kargs names syms
+                                     ,(visit-term body n))))))))
+                       (($ $kentry self tail clauses)
+                        (list
+                         (build-cps-cont
+                           (sym ($kentry self ,tail
+                                  ,(visit-conts clauses))))))
+                       (($ $kclause arity body)
+                        (list
+                         (build-cps-cont
+                           (sym ($kclause ,arity
+                                  ,(must-visit-cont body))))))
+                       (($ $kreceive ($ $arity req () rest () #f) kargs)
+                        (let ((defs (vector-ref defs n)))
+                          (if (and-map value-live? defs)
+                              (list (build-cps-cont (sym ,cont)))
+                              (let-fresh (adapt) ()
+                                (list (make-adaptor adapt kargs defs)
+                                      (build-cps-cont
+                                        (sym ($kreceive req rest adapt))))))))
+                       (_ (list (build-cps-cont (sym ,cont))))))))))
+             (define (visit-conts conts)
+               (append-map visit-cont conts))
+             (define (visit-term term term-k-idx)
+               (match term
+                 (($ $letk conts body)
+                  (let ((body (visit-term body term-k-idx)))
+                    (match (visit-conts conts)
+                      (() body)
+                      (conts (build-cps-term ($letk ,conts ,body))))))
+                 (($ $letrec names syms funs body)
+                  (let ((body (visit-term body term-k-idx)))
+                    (match (filter-map
+                            (lambda (name sym fun)
+                              (and (value-live? sym)
+                                   (list name sym (visit-fun fun))))
+                            names syms funs)
+                      (() body)
+                      (((names syms funs) ...)
+                       (build-cps-term
+                         ($letrec names syms funs ,body))))))
+                 (($ $continue k src ($ $values args))
+                  (match (vector-ref defs term-k-idx)
+                    (#f term)
+                    (defs
+                      (let ((args (filter-map (lambda (use def)
+                                                (and (value-live? def) use))
+                                              args defs)))
+                        (build-cps-term
+                          ($continue k src ($values args)))))))
+                 (($ $continue k src exp)
+                  (if (bitvector-ref live-conts term-k-idx)
+                      (rewrite-cps-term exp
+                        (($ $fun) ($continue k src ,(visit-fun exp)))
+                        (_
+                         ,(match (vector-ref defs term-k-idx)
+                            ((or #f ((? value-live?) ...))
                              (build-cps-term
-                               ($letk (,(make-adaptor adapt k syms))
-                                 ($continue adapt src ,exp))))))))
-                    (build-cps-term ($continue k src ($values ())))))))
-           (rewrite-cps-exp fun
-             (($ $fun src meta free body)
-              ($fun src meta free ,(must-visit-cont body)))))))
-      (visit-fun fun))))
+                               ($continue k src ,exp)))
+                            (syms
+                             (let-fresh (adapt) ()
+                               (build-cps-term
+                                 ($letk (,(make-adaptor adapt k syms))
+                                   ($continue adapt src ,exp))))))))
+                      (build-cps-term ($continue k src ($values ())))))))
+             (rewrite-cps-exp fun
+               (($ $fun src meta free body)
+                ($fun src meta free ,(must-visit-cont body)))))))
+        (visit-fun fun)))))
diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index d6590aa1f..e7b583605 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -35,7 +35,7 @@
   #:use-module (language cps dfg)
   #:export (elide-values))
 
-(define (elide-values fun)
+(define (elide-values* fun)
   (let ((conts (build-local-cont-table
                 (match fun (($ $fun src meta free body) body)))))
     (define (visit-cont cont)
@@ -54,7 +54,7 @@
          ($letk ,(map visit-cont conts)
            ,(visit-term body)))
         (($ $letrec names syms funs body)
-         ($letrec names syms (map elide-values funs)
+         ($letrec names syms (map elide-values* funs)
                   ,(visit-term body)))
         (($ $continue k src ($ $primcall 'values vals))
          ,(rewrite-cps-term (lookup-cont k conts)
@@ -64,9 +64,9 @@
              ,(cond
                ((and (not rest) (= (length vals) (length req)))
                 (build-cps-term
-                 ($continue kargs src ($values vals))))
+                  ($continue kargs src ($values vals))))
                ((and rest (>= (length vals) (length req)))
-                (let-gensyms (krest rest)
+                (let-fresh (krest) (rest)
                   (let ((vals* (append (list-head vals (length req))
                                        (list rest))))
                     (build-cps-term
@@ -80,7 +80,7 @@
                               (build-cps-term ($continue k src
                                                 ($const '()))))
                              ((v . tail)
-                              (let-gensyms (krest rest)
+                              (let-fresh (krest) (rest)
                                 (build-cps-term
                                   ($letk ((krest ($kargs ('rest) (rest)
                                                    ($continue k src
@@ -95,10 +95,14 @@
                     (build-cps-term
                       ($continue k src ($values vals))))))))
         (($ $continue k src (and fun ($ $fun)))
-         ($continue k src ,(elide-values fun)))
+         ($continue k src ,(elide-values* fun)))
         (($ $continue)
          ,term)))
 
     (rewrite-cps-exp fun
       (($ $fun src meta free body)
        ($fun src meta free ,(visit-cont body))))))
+
+(define (elide-values fun)
+  (with-fresh-name-state fun
+    (elide-values* fun)))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index e16579808..410a66bf7 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -33,7 +33,7 @@
   #:export (reify-primitives))
 
 (define (module-box src module name public? bound? val-proc)
-  (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+  (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
     (build-cps-term
       ($letconst (('module module-sym module)
                   ('name name-sym name)
@@ -81,14 +81,14 @@
                   ($continue k src ($primcall 'box-ref (box)))))))
 
 (define (builtin-ref idx k src)
-  (let-gensyms (idx-sym)
+  (let-fresh () (idx-sym)
     (build-cps-term
       ($letconst (('idx idx-sym idx))
         ($continue k src
           ($primcall 'builtin-ref (idx-sym)))))))
 
 (define (reify-clause ktail)
-  (let-gensyms (kclause kbody wna false str eol kthrow throw)
+  (let-fresh (kclause kbody kthrow) (wna false str eol throw)
     (build-cps-cont
       (kclause ($kclause ('() '() #f '() #f)
                  (kbody
@@ -106,59 +106,60 @@
 
 ;; FIXME: Operate on one function at a time, for efficiency.
 (define (reify-primitives fun)
-  (let ((conts (build-cont-table fun)))
-    (define (visit-fun term)
-      (rewrite-cps-exp term
-        (($ $fun src meta free body)
-         ($fun src meta 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 ($ $kentry self (and tail ($ $cont ktail)) ()))
-         ;; A case-lambda with no clauses.  Reify a clause.
-         (sym ($kentry self ,tail (,(reify-clause ktail)))))
-        (($ $cont sym ($ $kentry self tail clauses))
-         (sym ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym ($ $kclause arity body))
-         (sym ($kclause ,arity ,(visit-cont body))))
-        (($ $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 (lookup-cont k conts)
-               (($ $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-gensyms (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)))))
+  (with-fresh-name-state fun
+    (let ((conts (build-cont-table fun)))
+      (define (visit-fun term)
+        (rewrite-cps-exp term
+          (($ $fun src meta free body)
+           ($fun src meta 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 ($ $kentry self (and tail ($ $cont ktail)) ()))
+           ;; A case-lambda with no clauses.  Reify a clause.
+           (sym ($kentry self ,tail (,(reify-clause ktail)))))
+          (($ $cont sym ($ $kentry self tail clauses))
+           (sym ($kentry self ,tail ,(map visit-cont clauses))))
+          (($ $cont sym ($ $kclause arity body))
+           (sym ($kclause ,arity ,(visit-cont body))))
+          (($ $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 (lookup-cont k conts)
+                 (($ $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)))))
 
-    (visit-fun fun)))
+      (visit-fun fun))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index f5d61bd00..692c27a5f 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,81 +31,82 @@
   #:export (specialize-primcalls))
 
 (define (specialize-primcalls fun)
-  (let ((dfg (compute-dfg fun #:global? #t)))
-    (define (immediate-u8? sym)
-      (call-with-values (lambda () (find-constant-value sym dfg))
-        (lambda (has-const? val)
-          (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
-    (define (visit-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont sym ($ $kargs names syms body))
-         (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kentry self tail clauses))
-         (sym ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym ($ $kclause arity body))
-         (sym ($kclause ,arity ,(visit-cont body))))
-        (($ $cont)
-         ,cont)))
-    (define (visit-term term)
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ($letk ,(map visit-cont conts)
-           ,(visit-term body)))
-        (($ $letrec names syms funs body)
-         ($letrec names syms (map visit-fun funs)
-                  ,(visit-term body)))
-        (($ $continue k src (and fun ($ $fun)))
-         ($continue k src ,(visit-fun fun)))
-        (($ $continue k src ($ $primcall name args))
-         ,(visit-primcall k src name args))
-        (($ $continue)
-         ,term)))
-    (define (visit-primcall k src name args)
-      ;; If we introduce a VM op from a primcall without a VM op, we
-      ;; will need to ensure that the return arity matches.  Rely on the
-      ;; elide-values pass to clean up.
-      (define-syntax-rule (adapt-void exp)
-        (let-gensyms (k* val kvoid)
-          (build-cps-term
-            ($letk ((k* ($kargs ('val) (val)
-                          ($continue k src ($primcall 'values (val)))))
-                    (kvoid ($kargs () ()
-                             ($continue k* src ($void)))))
-              ($continue kvoid src exp)))))
-      (define-syntax-rule (adapt-val exp)
-        (let-gensyms (k* val)
-          (build-cps-term
-            ($letk ((k* ($kargs ('val) (val)
-                          ($continue k src ($primcall 'values (val))))))
-              ($continue k* src exp)))))
-      (match (cons name args)
-        (('make-vector (? immediate-u8? n) init)
-         (adapt-val ($primcall 'make-vector/immediate (n init))))
-        (('vector-ref v (? immediate-u8? n))
-         (build-cps-term
-           ($continue k src ($primcall 'vector-ref/immediate (v n)))))
-        (('vector-set! v (? immediate-u8? n) x)
-         (build-cps-term
-           ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
-        (('allocate-struct v (? immediate-u8? n))
-         (adapt-val ($primcall 'allocate-struct/immediate (v n))))
-        (('struct-ref s (? immediate-u8? n))
-         (adapt-val ($primcall 'struct-ref/immediate (s n))))
-        (('struct-set! s (? immediate-u8? n) x)
-         ;; Unhappily, and undocumentedly, struct-set! returns the value
-         ;; that was set.  There is code that relies on this.  Hackety
-         ;; hack...
-         (let-gensyms (k*)
+  (with-fresh-name-state fun
+    (let ((dfg (compute-dfg fun #:global? #t)))
+      (define (immediate-u8? sym)
+        (call-with-values (lambda () (find-constant-value sym dfg))
+          (lambda (has-const? val)
+            (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
+      (define (visit-cont cont)
+        (rewrite-cps-cont cont
+          (($ $cont sym ($ $kargs names syms body))
+           (sym ($kargs names syms ,(visit-term body))))
+          (($ $cont sym ($ $kentry self tail clauses))
+           (sym ($kentry self ,tail ,(map visit-cont clauses))))
+          (($ $cont sym ($ $kclause arity body))
+           (sym ($kclause ,arity ,(visit-cont body))))
+          (($ $cont)
+           ,cont)))
+      (define (visit-term term)
+        (rewrite-cps-term term
+          (($ $letk conts body)
+           ($letk ,(map visit-cont conts)
+             ,(visit-term body)))
+          (($ $letrec names syms funs body)
+           ($letrec names syms (map visit-fun funs)
+                    ,(visit-term body)))
+          (($ $continue k src (and fun ($ $fun)))
+           ($continue k src ,(visit-fun fun)))
+          (($ $continue k src ($ $primcall name args))
+           ,(visit-primcall k src name args))
+          (($ $continue)
+           ,term)))
+      (define (visit-primcall k src name args)
+        ;; If we introduce a VM op from a primcall without a VM op, we
+        ;; will need to ensure that the return arity matches.  Rely on the
+        ;; elide-values pass to clean up.
+        (define-syntax-rule (adapt-void exp)
+          (let-fresh (k* kvoid) (val)
+            (build-cps-term
+              ($letk ((k* ($kargs ('val) (val)
+                            ($continue k src ($primcall 'values (val)))))
+                      (kvoid ($kargs () ()
+                               ($continue k* src ($void)))))
+                ($continue kvoid src exp)))))
+        (define-syntax-rule (adapt-val exp)
+          (let-fresh (k*) (val)
+            (build-cps-term
+              ($letk ((k* ($kargs ('val) (val)
+                            ($continue k src ($primcall 'values (val))))))
+                ($continue k* src exp)))))
+        (match (cons name args)
+          (('make-vector (? immediate-u8? n) init)
+           (adapt-val ($primcall 'make-vector/immediate (n init))))
+          (('vector-ref v (? immediate-u8? n))
            (build-cps-term
-             ($letk ((k* ($kargs () ()
-                           ($continue k src ($primcall 'values (x))))))
-               ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
-        (_ 
-         (build-cps-term ($continue k src ($primcall name args))))))
+             ($continue k src ($primcall 'vector-ref/immediate (v n)))))
+          (('vector-set! v (? immediate-u8? n) x)
+           (build-cps-term
+             ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
+          (('allocate-struct v (? immediate-u8? n))
+           (adapt-val ($primcall 'allocate-struct/immediate (v n))))
+          (('struct-ref s (? immediate-u8? n))
+           (adapt-val ($primcall 'struct-ref/immediate (s n))))
+          (('struct-set! s (? immediate-u8? n) x)
+           ;; Unhappily, and undocumentedly, struct-set! returns the value
+           ;; that was set.  There is code that relies on this.  Hackety
+           ;; hack...
+           (let-fresh (k*) ()
+             (build-cps-term
+               ($letk ((k* ($kargs () ()
+                             ($continue k src ($primcall 'values (x))))))
+                 ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
+          (_ 
+           (build-cps-term ($continue k src ($primcall name args))))))
 
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun src meta free body)
-         ($fun src meta free ,(visit-cont body)))))
+      (define (visit-fun fun)
+        (rewrite-cps-exp fun
+          (($ $fun src meta free body)
+           ($fun src meta free ,(visit-cont body)))))
 
-    (visit-fun fun)))
+      (visit-fun fun))))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 347e59778..0fc186294 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -58,7 +58,7 @@
   #:use-module (language cps primitives)
   #:use-module (language tree-il analyze)
   #:use-module (language tree-il optimize)
-  #:use-module ((language tree-il) #:hide (let-gensyms))
+  #:use-module (language tree-il)
   #:export (compile-cps))
 
 ;;; Guile's semantics are that a toplevel lambda captures a reference on