X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/92afe25d5c162c29d971c2c36bd04a5b9d0b29c5..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/tree-il/compile-cps.scm

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 67f1ec15c..0cea636ea 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -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
@@ -75,48 +75,54 @@
 ;;; doesn't work for files auto-compiled for use with `load'.
 ;;;
 (define current-topbox-scope (make-parameter #f))
+(define scope-counter (make-parameter #f))
+
+(define (fresh-scope-id)
+  (let ((scope-id (scope-counter)))
+    (scope-counter (1+ scope-id))
+    scope-id))
 
 (define (toplevel-box src name bound? val-proc)
-  (let-gensyms (name-sym bound?-sym kbox box)
+  (let-fresh (kbox) (name-sym bound?-sym box)
     (build-cps-term
       ($letconst (('name name-sym name)
                   ('bound? bound?-sym bound?))
-        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+        ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
           ,(match (current-topbox-scope)
              (#f
               (build-cps-term
-                ($continue kbox
+                ($continue kbox src
                   ($primcall 'resolve
                              (name-sym bound?-sym)))))
-             (scope
-              (let-gensyms (scope-sym)
+             (scope-id
+              (let-fresh () (scope-sym)
                 (build-cps-term
-                  ($letconst (('scope scope-sym scope))
-                    ($continue kbox
+                  ($letconst (('scope scope-sym scope-id))
+                    ($continue kbox src
                       ($primcall 'cached-toplevel-box
                                  (scope-sym name-sym bound?-sym)))))))))))))
 
 (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)
                   ('public? public?-sym public?)
                   ('bound? bound?-sym bound?))
-        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
-          ($continue kbox
+        ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+          ($continue kbox src
             ($primcall 'cached-module-box
                        (module-sym name-sym public?-sym bound?-sym))))))))
 
-(define (capture-toplevel-scope src scope k)
-  (let-gensyms (module scope-sym kmodule)
+(define (capture-toplevel-scope src scope-id k)
+  (let-fresh (kmodule) (module scope-sym)
     (build-cps-term
-      ($letconst (('scope scope-sym scope))
-        ($letk ((kmodule src ($kargs ('module) (module)
-                               ($continue k
-                                 ($primcall 'cache-current-module!
-                                            (module scope-sym))))))
-          ($continue kmodule
+      ($letconst (('scope scope-sym scope-id))
+        ($letk ((kmodule ($kargs ('module) (module)
+                           ($continue k src
+                             ($primcall 'cache-current-module!
+                                        (module scope-sym))))))
+          ($continue kmodule src
             ($primcall 'current-module ())))))))
 
 (define (fold-formals proc seed arity gensyms inits)
@@ -149,45 +155,52 @@
               (error "too many inits"))
             seed)
            (((key name var) . kw)
-            (unless (eq? var (car gensyms))
-              (error "unexpected keyword arg order"))
-            (proc name var (car inits)
+            ;; Could be that var is not a gensym any more.
+            (when (symbol? var)
+              (unless (eq? var (car gensyms))
+                (error "unexpected keyword arg order")))
+            (proc name (car gensyms) (car inits)
                   (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
        (fold-req req gensyms seed)))))
 
-(define (unbound? src sym kt kf)
+(define (unbound? src var kt kf)
   (define tc8-iflag 4)
   (define unbound-val 9)
   (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
-  (let-gensyms (unbound ktest)
+  (let-fresh () (unbound)
     (build-cps-term
-      ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
-        ($letk ((ktest src ($kif kt kf)))
-          ($continue ktest
-            ($primcall 'eq? (sym unbound))))))))
+      ($letconst (('unbound unbound
+                            (pointer->scm (make-pointer unbound-bits))))
+        ($continue kf src
+          ($branch kt ($primcall 'eq? (var unbound))))))))
 
 (define (init-default-value name sym subst init body)
-  (match (assq-ref subst sym)
-    ((subst-sym box?)
+  (match (hashq-ref subst sym)
+    ((orig-var subst-var box?)
      (let ((src (tree-il-src init)))
        (define (maybe-box k make-body)
          (if box?
-             (let-gensyms (kbox phi)
+             (let-fresh (kbox) (phi)
                (build-cps-term
-                 ($letk ((kbox src ($kargs (name) (phi)
-                                     ($continue k ($primcall 'box (phi))))))
+                 ($letk ((kbox ($kargs (name) (phi)
+                                 ($continue k src ($primcall 'box (phi))))))
                    ,(make-body kbox))))
              (make-body k)))
-       (let-gensyms (knext kbound kunbound)
+       (let-fresh (knext kbound kunbound kreceive krest) (val rest)
          (build-cps-term
-           ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+           ($letk ((knext ($kargs (name) (subst-var) ,body)))
              ,(maybe-box
                knext
                (lambda (k)
                  (build-cps-term
-                   ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
-                           (kunbound src ($kargs () () ,(convert init k subst))))
-                     ,(unbound? src sym kunbound kbound))))))))))))
+                   ($letk ((kbound ($kargs () () ($continue k src
+                                                   ($values (orig-var)))))
+                           (krest ($kargs (name 'rest) (val rest)
+                                    ($continue k src ($values (val)))))
+                           (kreceive ($kreceive (list name) 'rest krest))
+                           (kunbound ($kargs () ()
+                                       ,(convert init kreceive subst))))
+                     ,(unbound? src orig-var kunbound kbound))))))))))))
 
 ;; exp k-name alist -> term
 (define (convert exp k subst)
@@ -195,20 +208,20 @@
   (define (convert-arg exp k)
     (match exp
       (($ <lexical-ref> src name sym)
-       (match (assq-ref subst sym)
-         ((box #t)
-          (let-gensyms (kunboxed unboxed)
+       (match (hashq-ref subst sym)
+         ((orig-var box #t)
+          (let-fresh (kunboxed) (unboxed)
             (build-cps-term
-              ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
-                ($continue kunboxed ($primcall 'box-ref (box)))))))
-         ((subst #f) (k subst))
-         (#f (k sym))))
+              ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+                ($continue kunboxed src ($primcall 'box-ref (box)))))))
+         ((orig-var subst-var #f) (k subst-var))
+         (var (k var))))
       (else
-       (let ((src (tree-il-src exp)))
-         (let-gensyms (karg arg)
-           (build-cps-term
-             ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
-               ,(convert exp karg subst))))))))
+       (let-fresh (kreceive karg) (arg rest)
+         (build-cps-term
+           ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
+                   (kreceive ($kreceive '(arg) 'rest karg)))
+             ,(convert exp kreceive subst)))))))
   ;; (exp ...) ((v-name ...) -> term) -> term
   (define (convert-args exps k)
     (match exps
@@ -220,80 +233,86 @@
              (lambda (names)
                (k (cons name names)))))))))
   (define (box-bound-var name sym body)
-    (match (assq-ref subst sym)
-      ((box #t)
-       (let-gensyms (k)
+    (match (hashq-ref subst sym)
+      ((orig-var subst-var #t)
+       (let-fresh (k) ()
          (build-cps-term
-           ($letk ((k #f ($kargs (name) (box) ,body)))
-             ($continue k ($primcall 'box (sym)))))))
+           ($letk ((k ($kargs (name) (subst-var) ,body)))
+             ($continue k #f ($primcall 'box (orig-var)))))))
       (else body)))
+  (define (bound-var sym)
+    (match (hashq-ref subst sym)
+      ((var . _) var)
+      ((? exact-integer? var) var)))
 
   (match exp
     (($ <lexical-ref> src name sym)
-     (match (assq-ref subst sym)
-       ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
-       ((subst #f) (build-cps-term ($continue k ($var subst))))
-       (#f (build-cps-term ($continue k ($var sym))))))
+     (rewrite-cps-term (hashq-ref subst sym)
+       ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
+       ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
+       (var ($continue k src ($values (var))))))
 
     (($ <void> src)
-     (build-cps-term ($continue k ($void))))
+     (build-cps-term ($continue k src ($const *unspecified*))))
 
     (($ <const> src exp)
-     (build-cps-term ($continue k ($const exp))))
+     (build-cps-term ($continue k src ($const exp))))
 
     (($ <primitive-ref> src name)
-     (build-cps-term ($continue k ($prim name))))
+     (build-cps-term ($continue k src ($prim name))))
 
     (($ <lambda> fun-src meta body)
      (let ()
        (define (convert-clauses body ktail)
          (match body
-           (#f '())
+           (#f #f)
            (($ <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))))
+                                       (map (match-lambda
+                                             ((kw name sym) 
+                                              (list kw name (bound-var sym))))
+                                            (if kw (cdr kw) '()))
+                                       (and kw (car kw))))
                    (names (fold-formals (lambda (name sym init names)
                                           (cons name names))
                                         '()
                                         arity gensyms inits)))
-              (cons
-               (let-gensyms (kclause kargs)
-                 (build-cps-cont
-                   (kclause
-                    src
-                    ($kclause ,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)))))))
-               (convert-clauses alternate ktail))))))
+              (let ((bound-vars (map bound-var gensyms)))
+                (let-fresh (kclause kargs) ()
+                  (build-cps-cont
+                    (kclause
+                     ($kclause ,arity
+                       (kargs
+                        ($kargs names bound-vars
+                          ,(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)))
+                       ,(convert-clauses alternate ktail))))))))))
        (if (current-topbox-scope)
-           (let-gensyms (kentry self ktail)
-             (build-cps-term
-               ($continue k
-                 ($fun meta '()
-                   (kentry fun-src
-                           ($kentry self (ktail #f ($ktail))
-                                    ,(convert-clauses body ktail)))))))
-           (let-gensyms (scope kscope)
+           (let-fresh (kfun ktail) (self)
              (build-cps-term
-               ($letk ((kscope fun-src
-                               ($kargs () ()
-                                 ,(parameterize ((current-topbox-scope scope))
-                                    (convert exp k subst)))))
-                 ,(capture-toplevel-scope fun-src scope kscope)))))))
+               ($continue k fun-src
+                 ($fun '()
+                   (kfun ($kfun fun-src meta self (ktail ($ktail))
+                             ,(convert-clauses body ktail)))))))
+           (let ((scope-id (fresh-scope-id)))
+             (let-fresh (kscope) ()
+               (build-cps-term
+                 ($letk ((kscope
+                          ($kargs () ()
+                            ,(parameterize ((current-topbox-scope scope-id))
+                               (convert exp k subst)))))
+                   ,(capture-toplevel-scope fun-src scope-id kscope))))))))
 
     (($ <module-ref> src mod name public?)
      (module-box
       src mod name public? #t
       (lambda (box)
-        (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+        (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
 
     (($ <module-set> src mod name public? exp)
      (convert-arg exp
@@ -301,13 +320,14 @@
          (module-box
           src mod name public? #f
           (lambda (box)
-            (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+            (build-cps-term
+              ($continue k src ($primcall 'box-set! (box val)))))))))
 
     (($ <toplevel-ref> src name)
      (toplevel-box
       src name #t
       (lambda (box)
-        (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+        (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
 
     (($ <toplevel-set> src name exp)
      (convert-arg exp
@@ -315,29 +335,44 @@
          (toplevel-box
           src name #f
           (lambda (box)
-            (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+            (build-cps-term
+              ($continue k src ($primcall 'box-set! (box val)))))))))
 
     (($ <toplevel-define> src name exp)
      (convert-arg exp
        (lambda (val)
-         (let-gensyms (kname name-sym)
+         (let-fresh (kname) (name-sym)
            (build-cps-term
              ($letconst (('name name-sym name))
-               ($continue k ($primcall 'define! (name-sym val)))))))))
+               ($continue k src ($primcall 'define! (name-sym val)))))))))
 
     (($ <call> src proc args)
      (convert-args (cons proc args)
        (match-lambda
         ((proc . args)
-         (build-cps-term ($continue k ($call proc args)))))))
+         (build-cps-term ($continue k src ($call proc args)))))))
 
     (($ <primcall> src name args)
      (cond
       ((branching-primitive? name)
-       (convert (make-conditional src exp (make-const #f #t)
-                                  (make-const #f #f))
-                k subst))
-      ((and (eq? name 'vector)
+       (convert-args args
+         (lambda (args)
+           (let-fresh (kt kf) ()
+             (build-cps-term
+               ($letk ((kt ($kargs () () ($continue k src ($const #t))))
+                       (kf ($kargs () () ($continue k src ($const #f)))))
+                 ($continue kf src
+                   ($branch kt ($primcall name args)))))))))
+      ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
+       (convert-args args
+         (lambda (args)
+           (let-fresh (kt kf) ()
+             (build-cps-term
+               ($letk ((kt ($kargs () () ($continue k src ($const #f))))
+                       (kf ($kargs () () ($continue k src ($const #t)))))
+                 ($continue kf src
+                   ($branch kt ($values args)))))))))
+      ((and (eq? name 'list)
             (and-map (match-lambda
                       ((or ($ <const>)
                            ($ <void>)
@@ -345,41 +380,27 @@
                            ($ <lexical-ref>)) #t)
                       (_ #f))
                      args))
-       ;; Some macros generate calls to "vector" with like 300
-       ;; arguments.  Since we eventually compile to make-vector and
-       ;; vector-set!, it reduces live variable pressure to allocate the
-       ;; vector first, then set values as they are produced, if we can
-       ;; prove that no value can capture the continuation.  (More on
-       ;; that caveat here:
-       ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
-       ;;
-       ;; Normally we would do this transformation in the compiler, but
-       ;; it's quite tricky there and quite easy here, so hold your nose
-       ;; while we drop some smelly code.
-       (convert (let ((len (length args)))
-                  (let-gensyms (v)
-                    (make-let src
-                              (list 'v)
-                              (list v)
-                              (list (make-primcall src 'make-vector
-                                                   (list (make-const #f len)
-                                                         (make-const #f #f))))
-                              (fold (lambda (arg n tail)
-                                      (make-seq
-                                       src
-                                       (make-primcall
-                                        src 'vector-set!
-                                        (list (make-lexical-ref src 'v v)
-                                              (make-const #f n)
-                                              arg))
-                                       tail))
-                                    (make-lexical-ref src 'v v)
-                                    (reverse args) (reverse (iota len))))))
-        k subst))
+       ;; See note below in `canonicalize' about `vector'.  The same
+       ;; thing applies to `list'.
+       (let lp ((args args) (k k))
+         (match args
+           (()
+            (build-cps-term
+              ($continue k src ($const '()))))
+           ((arg . args)
+            (let-fresh (ktail) (tail)
+              (build-cps-term
+                ($letk ((ktail ($kargs ('tail) (tail)
+                                 ,(convert-arg arg
+                                    (lambda (head)
+                                      (build-cps-term
+                                        ($continue k src
+                                          ($primcall 'cons (head tail)))))))))
+                  ,(lp args ktail))))))))
       (else
        (convert-args args
          (lambda (args)
-           (build-cps-term ($continue k ($primcall name args))))))))
+           (build-cps-term ($continue k src ($primcall name args))))))))
 
     ;; Prompts with inline handlers.
     (($ <prompt> src escape-only? tag body
@@ -399,86 +420,50 @@
      ;; Otherwise we do a no-inline call to body, continuing to krest.
      (convert-arg tag
        (lambda (tag)
-         (let ((hnames (append hreq (if hrest (list hrest) '()))))
-           (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+         (let ((hnames (append hreq (if hrest (list hrest) '())))
+               (bound-vars (map bound-var hsyms)))
+           (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
              (build-cps-term
-               ($letk* ((khbody hsrc ($kargs hnames hsyms
-                                       ,(fold box-bound-var
-                                              (convert hbody k subst)
-                                              hnames hsyms)))
-                        (khargs hsrc ($ktrunc hreq hrest khbody))
-                        (kpop src
-                              ($kargs ('rest) (vals)
+               ;; FIXME: Attach hsrc to $kreceive.
+               ($letk* ((khbody ($kargs hnames bound-vars
+                                  ,(fold box-bound-var
+                                         (convert hbody k subst)
+                                         hnames hsyms)))
+                        (khargs ($kreceive hreq hrest khbody))
+                        (kpop ($kargs ('rest) (vals)
                                 ($letk ((kret
-                                         src
                                          ($kargs () ()
                                            ($letk ((kprim
-                                                    src
                                                     ($kargs ('prim) (prim)
-                                                      ($continue k
+                                                      ($continue k src
                                                         ($primcall 'apply
                                                                    (prim vals))))))
-                                             ($continue kprim
+                                             ($continue kprim src
                                                ($prim 'values))))))
-                                  ($continue kret
+                                  ($continue kret src
                                     ($primcall 'unwind ())))))
-                        (krest src ($ktrunc '() 'rest kpop)))
+                        (krest ($kreceive '() 'rest kpop)))
                  ,(if escape-only?
                       (build-cps-term
-                        ($letk ((kbody (tree-il-src body) 
-                                       ($kargs () ()
+                        ($letk ((kbody ($kargs () ()
                                          ,(convert body krest subst))))
-                          ($continue kbody ($prompt #t tag khargs kpop))))
+                          ($continue kbody src ($prompt #t tag khargs))))
                       (convert-arg body
                         (lambda (thunk)
                           (build-cps-term
-                            ($letk ((kbody (tree-il-src body) 
-                                           ($kargs () ()
-                                             ($continue krest
+                            ($letk ((kbody ($kargs () ()
+                                             ($continue krest (tree-il-src body)
                                                ($primcall 'call-thunk/no-inline
                                                           (thunk))))))
-                              ($continue kbody
-                                ($prompt #f tag khargs kpop))))))))))))))
-
-    ;; Eta-convert prompts without inline handlers.
-    (($ <prompt> src escape-only? tag body handler)
-     (let-gensyms (h args)
-       (convert
-        (make-let
-         src (list 'h) (list h) (list handler)
-         (make-seq
-          src
-          (make-conditional
-           src
-           (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
-           (make-void src)
-           (make-primcall
-            src 'scm-error
-            (list
-             (make-const #f 'wrong-type-arg)
-             (make-const #f "call-with-prompt")
-             (make-const #f "Wrong type (expecting procedure): ~S")
-             (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
-             (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
-          (make-prompt
-           src escape-only? tag body
-           (make-lambda
-            src '()
-            (make-lambda-case
-             src '() #f 'args #f '() (list args)
-             (make-primcall
-              src 'apply
-              (list (make-lexical-ref #f 'h h)
-                    (make-lexical-ref #f 'args args)))
-             #f)))))
-        k
-        subst)))
+                              ($continue kbody (tree-il-src body)
+                                ($prompt #f tag khargs))))))))))))))
 
     (($ <abort> src tag args ($ <const> _ ()))
      (convert-args (cons tag args)
        (lambda (args*)
          (build-cps-term
-           ($continue k ($primcall 'abort-to-prompt args*))))))
+           ($continue k src
+             ($primcall 'abort-to-prompt args*))))))
 
     (($ <abort> src tag args tail)
      (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
@@ -487,132 +472,154 @@
                            (list tail))
        (lambda (args*)
          (build-cps-term
-           ($continue k ($primcall 'apply args*))))))
+           ($continue k src ($primcall 'apply args*))))))
 
     (($ <conditional> src test consequent alternate)
-     (let-gensyms (kif kt kf)
+     (let-fresh (kt kf) ()
        (build-cps-term
-         ($letk* ((kt (tree-il-src consequent) ($kargs () ()
-                                                 ,(convert consequent k subst)))
-                  (kf (tree-il-src alternate) ($kargs () ()
-                                                ,(convert alternate k subst)))
-                  (kif src ($kif kt kf)))
+         ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
+                  (kf ($kargs () () ,(convert alternate k subst))))
            ,(match test
               (($ <primcall> src (? branching-primitive? name) args)
                (convert-args args
                  (lambda (args)
-                   (build-cps-term ($continue kif ($primcall name args))))))
+                   (build-cps-term
+                     ($continue kf src
+                       ($branch kt ($primcall name args)))))))
               (_ (convert-arg test
                    (lambda (test)
-                     (build-cps-term ($continue kif ($var test)))))))))))
+                     (build-cps-term
+                       ($continue kf src
+                         ($branch kt ($values (test)))))))))))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg exp
        (lambda (exp)
-         (match (assq-ref subst gensym)
-           ((box #t)
+         (match (hashq-ref subst gensym)
+           ((orig-var box #t)
             (build-cps-term
-              ($continue k ($primcall 'box-set! (box exp)))))))))
+              ($continue k src ($primcall 'box-set! (box exp)))))))))
 
     (($ <seq> src head tail)
-     (let-gensyms (ktrunc kseq)
+     (let-fresh (kreceive kseq) (vals)
        (build-cps-term
-         ($letk* ((kseq (tree-il-src tail) ($kargs () ()
-                                             ,(convert tail k subst)))
-                  (ktrunc src ($ktrunc '() #f kseq)))
-           ,(convert head ktrunc subst)))))
+         ($letk* ((kseq ($kargs ('vals) (vals)
+                          ,(convert tail k subst)))
+                  (kreceive ($kreceive '() 'vals kseq)))
+           ,(convert head kreceive 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-gensyms (klet)
+          (let-fresh (kreceive klet) (rest)
             (build-cps-term
-              ($letk ((klet src ($kargs (name) (sym)
-                                  ,(box-bound-var name sym
-                                                  (lp names syms vals)))))
-                ,(convert val klet subst))))))))
+              ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
+                               ,(box-bound-var name sym
+                                               (lp names syms vals))))
+                       (kreceive ($kreceive (list name) 'rest klet)))
+                ,(convert val kreceive subst))))))))
 
     (($ <fix> src names gensyms funs body)
      ;; Some letrecs can be contified; that happens later.
      (if (current-topbox-scope)
-         (let-gensyms (self)
+         (let-fresh () (self)
            (build-cps-term
              ($letrec names
-                      gensyms
+                      (map bound-var gensyms)
                       (map (lambda (fun)
                              (match (convert fun k subst)
-                               (($ $continue _ (and fun ($ $fun)))
+                               (($ $continue _ _ (and fun ($ $fun)))
                                 fun)))
                            funs)
                       ,(convert body k subst))))
-         (let-gensyms (scope kscope)
-           (build-cps-term
-             ($letk ((kscope src ($kargs () ()
-                                   ,(parameterize ((current-topbox-scope scope))
-                                      (convert exp k subst)))))
-               ,(capture-toplevel-scope src scope kscope))))))
+         (let ((scope-id (fresh-scope-id)))
+           (let-fresh (kscope) ()
+             (build-cps-term
+               ($letk ((kscope
+                        ($kargs () ()
+                          ,(parameterize ((current-topbox-scope scope-id))
+                             (convert exp k subst)))))
+                 ,(capture-toplevel-scope src scope-id kscope)))))))
 
     (($ <let-values> src exp
         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
-     (let ((names (append req (if rest (list rest) '()))))
-       (let-gensyms (ktrunc kargs)
+     (let ((names (append req (if rest (list rest) '())))
+           (bound-vars (map bound-var syms)))
+       (let-fresh (kreceive kargs) ()
          (build-cps-term
-           ($letk* ((kargs src ($kargs names syms
-                                 ,(fold box-bound-var
-                                        (convert body k subst)
-                                        names syms)))
-                    (ktrunc src ($ktrunc req rest kargs)))
-             ,(convert exp ktrunc subst))))))))
+           ($letk* ((kargs ($kargs names bound-vars
+                             ,(fold box-bound-var
+                                    (convert body k subst)
+                                    names syms)))
+                    (kreceive ($kreceive req rest kargs)))
+             ,(convert exp kreceive subst))))))))
 
 (define (build-subst exp)
-  "Compute a mapping from lexical gensyms to substituted gensyms.  The
-usual reason to replace one variable by another is assignment
-conversion.  Default argument values is the other reason.
-
-Returns a list of (ORIG-SYM SUBST-SYM BOXED?).  A true value for BOXED?
-indicates that the replacement variable is in a box."
-  (define (box-set-vars exp subst)
-    (match exp
-      (($ <lexical-set> src name sym exp)
-       (if (assq sym subst)
-           subst
-           (cons (list sym (gensym "b") #t) subst)))
-      (_ subst)))
-  (define (default-args exp subst)
-    (match exp
-      (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
-       (fold-formals (lambda (name sym init subst)
-                       (if init
-                           (let ((box? (match (assq-ref subst sym)
-                                         ((box #t) #t)
-                                         (#f #f)))
-                                 (subst-sym (gensym (symbol->string name))))
-                             (cons (list sym subst-sym box?) subst))
-                           subst))
-                     subst
-                     (make-$arity req (or opt '()) rest
-                                  (if kw (cdr kw) '()) (and kw (car kw)))
-                     gensyms
-                     inits))
-      (_ subst)))
-  (tree-il-fold box-set-vars default-args '() exp))
+  "Compute a mapping from lexical gensyms to CPS variable indexes.  CPS
+uses small integers to identify variables, instead of gensyms.
+
+This subst table serves an additional purpose of mapping variables to
+replacements.  The usual reason to replace one variable by another is
+assignment conversion.  Default argument values is the other reason.
+
+The result is a hash table mapping symbols to substitutions (in the case
+that a variable is substituted) or to indexes.  A substitution is a list
+of the form:
+
+  (ORIG-INDEX SUBST-INDEX BOXED?)
+
+A true value for BOXED?  indicates that the replacement variable is in a
+box.  If a variable is not substituted, the mapped value is a small
+integer."
+  (let ((table (make-hash-table)))
+    (define (down exp)
+      (match exp
+        (($ <lexical-set> src name sym exp)
+         (match (hashq-ref table sym)
+           ((orig subst #t) #t)
+           ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
+           ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
+        (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+         (fold-formals (lambda (name sym init seed)
+                         (hashq-set! table sym
+                                     (if init
+                                         (list (fresh-var) (fresh-var) #f)
+                                         (fresh-var))))
+                       #f
+                       (make-$arity req (or opt '()) rest
+                                    (if kw (cdr kw) '()) (and kw (car kw)))
+                       gensyms
+                       inits))
+        (($ <let> src names gensyms vals body)
+         (for-each (lambda (sym)
+                     (hashq-set! table sym (fresh-var)))
+                   gensyms))
+        (($ <fix> src names gensyms vals body)
+         (for-each (lambda (sym)
+                     (hashq-set! table sym (fresh-var)))
+                   gensyms))
+        (_ #t))
+      (values))
+    (define (up exp) (values))
+    ((make-tree-il-folder) exp down up)
+    table))
 
 (define (cps-convert/thunk exp)
-  (let ((src (tree-il-src exp)))
-    (let-gensyms (kinit init ktail kclause kbody)
-      (build-cps-exp
-        ($fun '() '()
-          (kinit src
-                 ($kentry init
-                   (ktail #f ($ktail))
-                   ((kclause src
-                            ($kclause ('() '() #f '() #f)
-                              (kbody src
-                                     ($kargs () ()
-                                       ,(convert exp ktail
-                                                 (build-subst exp))))))))))))))
+  (parameterize ((label-counter 0)
+                 (var-counter 0)
+                 (scope-counter 0))
+    (let ((src (tree-il-src exp)))
+      (let-fresh (kinit ktail kclause kbody) (init)
+        (build-cps-cont
+          (kinit ($kfun src '() init (ktail ($ktail))
+                   (kclause
+                    ($kclause ('() '() #f '() #f)
+                      (kbody ($kargs () ()
+                               ,(convert exp ktail
+                                         (build-subst exp))))
+                      ,#f)))))))))
 
 (define *comp-module* (make-fluid))
 
@@ -636,8 +643,103 @@ indicates that the replacement variable is in a box."
 
   (optimize x e opts))
 
+(define (canonicalize exp)
+  (post-order
+   (lambda (exp)
+     (match exp
+       (($ <primcall> src 'vector
+           (and args
+                ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
+                 ...)))
+        ;; Some macros generate calls to "vector" with like 300
+        ;; arguments.  Since we eventually compile to make-vector and
+        ;; vector-set!, it reduces live variable pressure to allocate the
+        ;; vector first, then set values as they are produced, if we can
+        ;; prove that no value can capture the continuation.  (More on
+        ;; that caveat here:
+        ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+        ;;
+        ;; Normally we would do this transformation in the compiler, but
+        ;; it's quite tricky there and quite easy here, so hold your nose
+        ;; while we drop some smelly code.
+        (let ((len (length args))
+              (v (gensym "v ")))
+          (make-let src
+                    (list 'v)
+                    (list v)
+                    (list (make-primcall src 'make-vector
+                                         (list (make-const #f len)
+                                               (make-const #f #f))))
+                    (fold (lambda (arg n tail)
+                            (make-seq
+                             src
+                             (make-primcall
+                              src 'vector-set!
+                              (list (make-lexical-ref src 'v v)
+                                    (make-const #f n)
+                                    arg))
+                             tail))
+                          (make-lexical-ref src 'v v)
+                          (reverse args) (reverse (iota len))))))
+
+       (($ <primcall> src 'struct-set! (struct index value))
+        ;; Unhappily, and undocumentedly, struct-set! returns the value
+        ;; that was set.  There is code that relies on this.  Hackety
+        ;; hack...
+        (let ((v (gensym "v ")))
+          (make-let src
+                    (list 'v)
+                    (list v)
+                    (list value)
+                    (make-seq src
+                              (make-primcall src 'struct-set!
+                                             (list struct
+                                                   index
+                                                   (make-lexical-ref src 'v v)))
+                              (make-lexical-ref src 'v v)))))
+
+       (($ <prompt> src escape-only? tag body
+           ($ <lambda> hsrc hmeta
+              ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+        exp)
+
+       ;; Eta-convert prompts without inline handlers.
+       (($ <prompt> src escape-only? tag body handler)
+        (let ((h (gensym "h "))
+              (args (gensym "args ")))
+          (make-let
+           src (list 'h) (list h) (list handler)
+           (make-seq
+            src
+            (make-conditional
+             src
+             (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+             (make-void src)
+             (make-primcall
+              src 'scm-error
+              (list
+               (make-const #f 'wrong-type-arg)
+               (make-const #f "call-with-prompt")
+               (make-const #f "Wrong type (expecting procedure): ~S")
+               (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+               (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+            (make-prompt
+             src escape-only? tag body
+             (make-lambda
+              src '()
+              (make-lambda-case
+               src '() #f 'args #f '() (list args)
+               (make-primcall
+                src 'apply
+                (list (make-lexical-ref #f 'h h)
+                      (make-lexical-ref #f 'args args)))
+               #f)))))))
+       (_ exp)))
+   exp))
+
 (define (compile-cps exp env opts)
-  (values (cps-convert/thunk (optimize-tree-il exp env opts))
+  (values (cps-convert/thunk
+           (canonicalize (optimize-tree-il exp env opts)))
           env
           env))