From 6e422a3599d0f293078576b1e77c74f408d80a14 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 7 Nov 2013 10:32:21 +0100
Subject: [PATCH] Source information goes on the $continue, not the $cont.

* module/language/cps.scm ($continue, $cont): Put source information on
  the $continue, not on the $cont.  Otherwise it is difficult for CPS
  conversion to preserve source information.
  ($fun): Add a src member to $fun.  Otherwise we might miss the source
  info for the start of the function.

* .dir-locals.el:
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Update the whole CPS world
  for this change.
---
 .dir-locals.el                             |   2 +-
 module/language/cps.scm                    |  75 ++-
 module/language/cps/arities.scm            | 134 ++--
 module/language/cps/closure-conversion.scm |  91 +--
 module/language/cps/compile-rtl.scm        | 746 ++++++++++-----------
 module/language/cps/constructors.scm       |  52 +-
 module/language/cps/contification.scm      |  72 +-
 module/language/cps/dfg.scm                |  34 +-
 module/language/cps/elide-values.scm       |  30 +-
 module/language/cps/reify-primitives.scm   |  80 ++-
 module/language/cps/slot-allocation.scm    |  12 +-
 module/language/cps/verify.scm             |  18 +-
 module/language/tree-il/compile-cps.scm    | 205 +++---
 13 files changed, 767 insertions(+), 784 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 94a21263b..0589229cd 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -21,7 +21,7 @@
      (eval . (put '$letk               'scheme-indent-function 1))
      (eval . (put '$letk*              'scheme-indent-function 1))
      (eval . (put '$letconst           'scheme-indent-function 1))
-     (eval . (put '$continue           'scheme-indent-function 1))
+     (eval . (put '$continue           'scheme-indent-function 2))
      (eval . (put '$kargs              'scheme-indent-function 2))
      (eval . (put '$kentry             'scheme-indent-function 2))
      (eval . (put '$kclause            'scheme-indent-function 1))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index d39124e70..4dc88eb2f 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -25,15 +25,15 @@
 ;;; and terms that call continuations.
 ;;;
 ;;; $letk binds a set of mutually recursive continuations, each one an
-;;; instance of $cont.  A $cont declares the name and source of a
-;;; continuation, and then contains as a subterm the particular
-;;; continuation instance: $kif for test continuations, $kargs for
-;;; continuations that bind values, etc.
+;;; instance of $cont.  A $cont declares the name of a continuation, and
+;;; then contains as a subterm the particular continuation instance:
+;;; $kif for test continuations, $kargs for continuations that bind
+;;; values, etc.
 ;;;
 ;;; $continue nodes call continuations.  The expression contained in the
 ;;; $continue node determines the value or values that are passed to the
 ;;; target continuation: $const to pass a constant value, $values to
-;;; pass multiple named values, etc.
+;;; pass multiple named values, etc.  $continue nodes also record the source at which 
 ;;;
 ;;; Additionally there is $letrec, a term that binds mutually recursive
 ;;; functions.  The contification pass will turn $letrec into $letk if
@@ -71,8 +71,8 @@
 ;;;     That's to say that a $fun can be matched like this:
 ;;;
 ;;;     (match f
-;;;       (($ $fun meta free
-;;;           ($ $cont kentry src
+;;;       (($ $fun src meta free
+;;;           ($ $cont kentry
 ;;;              ($ $kentry self ($ $cont ktail _ ($ $ktail))
 ;;;                 (($ $kclause arity
 ;;;                     ($ $cont kbody _ ($ $kargs names syms body)))
@@ -165,11 +165,11 @@
 
 ;; Terms.
 (define-cps-type $letk conts body)
-(define-cps-type $continue k exp)
+(define-cps-type $continue k src exp)
 (define-cps-type $letrec names syms funs body)
 
 ;; Continuations
-(define-cps-type $cont k src cont)
+(define-cps-type $cont k cont)
 (define-cps-type $kif kt kf)
 (define-cps-type $ktrunc arity k)
 (define-cps-type $kargs names syms body)
@@ -182,7 +182,7 @@
 (define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
-(define-cps-type $fun meta free body)
+(define-cps-type $fun src meta free body)
 (define-cps-type $call proc args)
 (define-cps-type $primcall name args)
 (define-cps-type $values args)
@@ -224,7 +224,7 @@
 (define-syntax build-cps-cont
   (syntax-rules (unquote)
     ((_ (unquote exp)) exp)
-    ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
+    ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
 
 (define-syntax build-cps-exp
   (syntax-rules (unquote
@@ -234,7 +234,8 @@
     ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
-    ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
+    ((_ ($fun src meta free body))
+     (make-$fun src meta free (build-cps-cont body)))
     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
     ((_ ($call proc args)) (make-$call proc args))
     ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
@@ -262,12 +263,14 @@
     ((_ ($letconst ((name sym val) tail ...) body))
      (let-gensyms (kconst)
        (build-cps-term
-         ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
-           ($continue kconst ($const val))))))
+         ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
+           ($continue kconst (let ((props (source-properties val)))
+                               (and (pair? props) props))
+             ($const val))))))
     ((_ ($letrec names gensyms funs body))
      (make-$letrec names gensyms funs (build-cps-term body)))
-    ((_ ($continue k exp))
-     (make-$continue k (build-cps-exp exp)))))
+    ((_ ($continue k src exp))
+     (make-$continue k src (build-cps-exp exp)))))
 
 (define-syntax-rule (rewrite-cps-term x (pat body) ...)
   (match x
@@ -287,20 +290,20 @@
     ;; Continuations.
     (('letconst k (name sym c) body)
      (build-cps-term
-       ($letk ((k (src exp) ($kargs (name) (sym)
-                              ,(parse-cps body))))
-         ($continue k ($const c)))))
+       ($letk ((k ($kargs (name) (sym)
+                    ,(parse-cps body))))
+         ($continue k (src exp) ($const c)))))
     (('let k (name sym val) body)
      (build-cps-term
-      ($letk ((k (src exp) ($kargs (name) (sym)
-                             ,(parse-cps body))))
+      ($letk ((k ($kargs (name) (sym)
+                   ,(parse-cps body))))
         ,(parse-cps val))))
     (('letk (cont ...) body)
      (build-cps-term
        ($letk ,(map parse-cps cont) ,(parse-cps body))))
     (('k sym body)
      (build-cps-cont
-       (sym (src exp) ,(parse-cps body))))
+       (sym ,(parse-cps body))))
     (('kif kt kf)
      (build-cont-body ($kif kt kf)))
     (('ktrunc req rest k)
@@ -322,7 +325,7 @@
 
     ;; Calls.
     (('continue k exp)
-     (build-cps-term ($continue k ,(parse-cps exp))))
+     (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
     (('var sym)
      (build-cps-exp ($var sym)))
     (('void)
@@ -332,7 +335,7 @@
     (('prim name)
      (build-cps-exp ($prim name)))
     (('fun meta free body)
-     (build-cps-exp ($fun meta free ,(parse-cps body))))
+     (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
     (('letrec ((name sym fun) ...) body)
      (build-cps-term
        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
@@ -350,16 +353,16 @@
 (define (unparse-cps exp)
   (match exp
     ;; Continuations.
-    (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
-        ($ $continue k ($ $const c)))
+    (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
+        ($ $continue k src ($ $const c)))
      `(letconst ,k (,name ,sym ,c)
                 ,(unparse-cps body)))
-    (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+    (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
      `(let ,k (,name ,sym ,(unparse-cps val))
            ,(unparse-cps body)))
     (($ $letk conts body)
      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
-    (($ $cont sym src body)
+    (($ $cont sym body)
      `(k ,sym ,(unparse-cps body)))
     (($ $kif kt kf)
      `(kif ,kt ,kf))
@@ -377,7 +380,7 @@
      `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
 
     ;; Calls.
-    (($ $continue k exp)
+    (($ $continue k src exp)
      `(continue ,k ,(unparse-cps exp)))
     (($ $var sym)
      `(var ,sym))
@@ -387,7 +390,7 @@
      `(const ,val))
     (($ $prim name)
      `(prim ,name))
-    (($ $fun meta free body)
+    (($ $fun src meta free body)
      `(fun ,meta ,free ,(unparse-cps body)))
     (($ $letrec names syms funs body)
      `(letrec ,(map (lambda (name sym fun)
@@ -408,8 +411,8 @@
 (define (fold-conts proc seed fun)
   (define (cont-folder cont seed)
     (match cont
-      (($ $cont k src cont)
-       (let ((seed (proc k src cont seed)))
+      (($ $cont k cont)
+       (let ((seed (proc k cont seed)))
          (match cont
            (($ $kargs names syms body)
             (term-folder body seed))
@@ -424,7 +427,7 @@
 
   (define (fun-folder fun seed)
     (match fun
-      (($ $fun meta free body)
+      (($ $fun src meta free body)
        (cont-folder body seed))))
 
   (define (term-folder term seed)
@@ -432,7 +435,7 @@
       (($ $letk conts body)
        (fold cont-folder (term-folder body seed) conts))
 
-      (($ $continue k exp)
+      (($ $continue k src exp)
        (match exp
          (($ $fun) (fun-folder exp seed))
          (_ seed)))
@@ -445,8 +448,8 @@
 (define (fold-local-conts proc seed cont)
   (define (cont-folder cont seed)
     (match cont
-      (($ $cont k src cont)
-       (let ((seed (proc k src cont seed)))
+      (($ $cont k cont)
+       (let ((seed (proc k cont seed)))
          (match cont
            (($ $kargs names syms body)
             (term-folder body seed))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index fb888fdbe..430d69720 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -35,105 +35,105 @@
 (define (fix-clause-arities clause)
   (let ((conts (build-local-cont-table clause))
         (ktail (match clause
-                 (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+                 (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
     (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 fix-arities funs) ,(visit-term body)))
-        (($ $continue k exp)
-         ,(visit-exp k exp))))
+        (($ $continue k src exp)
+         ,(visit-exp k src exp))))
 
-    (define (adapt-exp nvals k exp)
+    (define (adapt-exp nvals k src exp)
       (match nvals
         (0
          (rewrite-cps-term (lookup-cont k conts)
            (($ $ktail)
             ,(let-gensyms (kvoid kunspec unspec)
                (build-cps-term
-                 ($letk* ((kunspec #f ($kargs (unspec) (unspec)
-                                        ($continue k
-                                          ($primcall 'return (unspec)))))
-                          (kvoid #f ($kargs () ()
-                                      ($continue kunspec ($void)))))
-                   ($continue kvoid ,exp)))))
+                 ($letk* ((kunspec ($kargs (unspec) (unspec)
+                                     ($continue k src
+                                       ($primcall 'return (unspec)))))
+                          (kvoid ($kargs () ()
+                                   ($continue kunspec src ($void)))))
+                   ($continue kvoid src ,exp)))))
            (($ $ktrunc arity kargs)
             ,(rewrite-cps-term arity
                (($ $arity () () #f () #f)
-                ($continue kargs ,exp))
+                ($continue kargs src ,exp))
                (_
                 ,(let-gensyms (kvoid kvalues void)
                    (build-cps-term
-                     ($letk* ((kvalues #f ($kargs ('void) (void)
-                                            ($continue k
-                                              ($primcall 'values (void)))))
-                              (kvoid #f ($kargs () ()
-                                          ($continue kvalues
-                                            ($void)))))
-                       ($continue kvoid ,exp)))))))
+                     ($letk* ((kvalues ($kargs ('void) (void)
+                                         ($continue k src
+                                           ($primcall 'values (void)))))
+                              (kvoid ($kargs () ()
+                                       ($continue kvalues src
+                                         ($void)))))
+                       ($continue kvoid src ,exp)))))))
            (($ $kargs () () _)
-            ($continue k ,exp))
+            ($continue k src ,exp))
            (_
             ,(let-gensyms (k*)
                (build-cps-term
-                 ($letk ((k* #f ($kargs () () ($continue k ($void)))))
-                   ($continue k* ,exp)))))))
+                 ($letk ((k* ($kargs () () ($continue k src ($void)))))
+                   ($continue k* src ,exp)))))))
         (1
          (rewrite-cps-term (lookup-cont k conts)
            (($ $ktail)
             ,(rewrite-cps-term exp
                (($var sym)
-                ($continue ktail ($primcall 'return (sym))))
+                ($continue ktail src ($primcall 'return (sym))))
                (_
                 ,(let-gensyms (k* v)
                    (build-cps-term
-                     ($letk ((k* #f ($kargs (v) (v)
-                                      ($continue k
-                                        ($primcall 'return (v))))))
-                       ($continue k* ,exp)))))))
+                     ($letk ((k* ($kargs (v) (v)
+                                   ($continue k src
+                                     ($primcall 'return (v))))))
+                       ($continue k* src ,exp)))))))
            (($ $ktrunc arity kargs)
             ,(rewrite-cps-term arity
                (($ $arity (_) () #f () #f)
-                ($continue kargs ,exp))
+                ($continue kargs src ,exp))
                (_
                 ,(let-gensyms (kvalues value)
                    (build-cps-term
-                     ($letk ((kvalues #f ($kargs ('value) (value)
-                                           ($continue k
-                                             ($primcall 'values (value))))))
-                       ($continue kvalues ,exp)))))))
+                     ($letk ((kvalues ($kargs ('value) (value)
+                                        ($continue k src
+                                          ($primcall 'values (value))))))
+                       ($continue kvalues src ,exp)))))))
            (($ $kargs () () _)
             ,(let-gensyms (k* drop)
                (build-cps-term
-                 ($letk ((k* #f ($kargs ('drop) (drop)
-                                  ($continue k ($values ())))))
-                   ($continue k* ,exp)))))
+                 ($letk ((k* ($kargs ('drop) (drop)
+                               ($continue k src ($values ())))))
+                   ($continue k* src ,exp)))))
            (_
-            ($continue k ,exp))))))
+            ($continue k src ,exp))))))
 
-    (define (visit-exp k exp)
+    (define (visit-exp k src exp)
       (rewrite-cps-term exp
         ((or ($ $void)
              ($ $const)
              ($ $prim)
              ($ $var))
-         ,(adapt-exp 1 k exp))
+         ,(adapt-exp 1 k src exp))
         (($ $fun)
-         ,(adapt-exp 1 k (fix-arities exp)))
+         ,(adapt-exp 1 k src (fix-arities exp)))
         (($ $call)
          ;; In general, calls have unknown return arity.  For that
          ;; reason every non-tail call has an implicit adaptor
          ;; continuation to adapt the return to the target
          ;; continuation, and we don't need to do any adapting here.
-         ($continue k ,exp))
+         ($continue k src ,exp))
         (($ $primcall 'return (arg))
          ;; Primcalls to return are in tail position.
-         ($continue ktail ,exp))
+         ($continue ktail src ,exp))
         (($ $primcall (? (lambda (name)
                            (and (not (prim-rtl-instruction name))
                                 (not (branching-primitive? name))))))
-         ($continue k ,exp))
+         ($continue k src ,exp))
         (($ $primcall 'struct-set! (obj pos val))
          ;; Unhappily, and undocumentedly, struct-set! returns the value
          ;; that was set.  There is code that relies on this.  Hackety
@@ -142,63 +142,63 @@
             (($ $ktail)
              ,(let-gensyms (kvoid)
                 (build-cps-term
-                  ($letk* ((kvoid #f ($kargs () ()
-                                       ($continue ktail
-                                         ($primcall 'return (val))))))
-                    ($continue kvoid ,exp)))))
+                  ($letk* ((kvoid ($kargs () ()
+                                    ($continue ktail src
+                                      ($primcall 'return (val))))))
+                    ($continue kvoid src ,exp)))))
             (($ $ktrunc arity kargs)
              ,(rewrite-cps-term arity
                 (($ $arity () () #f () #f)
-                 ($continue kargs ,exp))
+                 ($continue kargs src ,exp))
                 (_
                  ,(let-gensyms (kvoid)
                     (build-cps-term
-                      ($letk* ((kvoid #f ($kargs () ()
-                                           ($continue k
-                                             ($primcall 'values (val))))))
-                        ($continue kvoid ,exp)))))))
+                      ($letk* ((kvoid ($kargs () ()
+                                        ($continue k src
+                                          ($primcall 'values (val))))))
+                        ($continue kvoid src ,exp)))))))
             (($ $kargs () () _)
-             ($continue k ,exp))
+             ($continue k src ,exp))
             (_
              ,(let-gensyms (k*)
                 (build-cps-term
-                  ($letk ((k* #f ($kargs () () ($continue k ($var val)))))
-                    ($continue k* ,exp)))))))
+                  ($letk ((k* ($kargs () () ($continue k src ($var val)))))
+                    ($continue k* src ,exp)))))))
         (($ $primcall name args)
          ,(match (prim-arity name)
             ((out . in)
              (if (= in (length args))
-                 (adapt-exp out k
+                 (adapt-exp out k src
                             (let ((inst (prim-rtl-instruction name)))
                               (if (and inst (not (eq? inst name)))
                                   (build-cps-exp ($primcall inst args))
                                   exp)))
                  (let-gensyms (k* p*)
                    (build-cps-term
-                     ($letk ((k* #f ($kargs ('prim) (p*)
-                                      ($continue k ($call p* args)))))
-                       ($continue k* ($prim name)))))))))
+                     ($letk ((k* ($kargs ('prim) (p*)
+                                   ($continue k src ($call p* args)))))
+                       ($continue k* src ($prim name)))))))))
         (($ $values)
          ;; Values nodes are inserted by CPS optimization passes, so
          ;; we assume they are correct.
-         ($continue k ,exp))
+         ($continue k src ,exp))
         (($ $prompt)
-         ($continue k ,exp))))
+         ($continue k src ,exp))))
 
     (define (visit-cont cont)
       (rewrite-cps-cont cont
-        (($ $cont sym src ($ $kargs names syms body))
-         (sym src ($kargs names syms ,(visit-term body))))
-        (($ $cont sym src ($ $kclause arity body))
-         (sym src ($kclause ,arity ,(visit-cont body))))
+        (($ $cont sym ($ $kargs names syms body))
+         (sym ($kargs names syms ,(visit-term body))))
+        (($ $cont sym ($ $kclause arity body))
+         (sym ($kclause ,arity ,(visit-cont body))))
         (($ $cont)
          ,cont)))
 
     (rewrite-cps-cont clause
-      (($ $cont sym src ($ $kentry self tail clauses))
-       (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
+      (($ $cont sym ($ $kentry self tail clauses))
+       (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
 
 (define (fix-arities fun)
   (rewrite-cps-exp fun
-    (($ $fun meta free body)
-     ($fun meta free ,(fix-clause-arities body)))))
+    (($ $fun src meta free body)
+     ($fun src meta free ,(fix-clause-arities body)))))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 05d9bdb40..3cea53aa9 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -63,8 +63,8 @@ values in the term."
       (let-gensyms (k* sym*)
         (receive (exp free) (k sym*)
           (values (build-cps-term
-                    ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
-                      ($continue k* ($primcall 'free-ref (self sym)))))
+                    ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
+                      ($continue k* #f ($primcall 'free-ref (self sym)))))
                   (cons sym free))))))
   
 (define (convert-free-vars syms self bound k)
@@ -88,13 +88,13 @@ performed, and @var{outer-bound} is the list of bound variables there."
   (fold (lambda (free idx body)
           (let-gensyms (k idxsym)
             (build-cps-term
-              ($letk ((k src ($kargs () () ,body)))
+              ($letk ((k ($kargs () () ,body)))
                 ,(convert-free-var
                   free outer-self outer-bound
                   (lambda (free)
                     (values (build-cps-term
                               ($letconst (('idx idxsym idx))
-                                ($continue k
+                                ($continue k src
                                   ($primcall 'free-set! (v idxsym free)))))
                             '())))))))
         body
@@ -123,19 +123,19 @@ convert functions to flat closures."
          (values (build-cps-term ($letk ,conts ,body))
                  (union free free*)))))
 
-    (($ $cont sym src ($ $kargs names syms body))
+    (($ $cont sym ($ $kargs names syms body))
      (receive (body free) (cc body self (append syms bound))
-       (values (build-cps-cont (sym src ($kargs names syms ,body)))
+       (values (build-cps-cont (sym ($kargs names syms ,body)))
                free)))
 
-    (($ $cont sym src ($ $kentry self tail clauses))
+    (($ $cont sym ($ $kentry self tail clauses))
      (receive (clauses free) (cc* clauses self (list self))
-       (values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
+       (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
                free)))
 
-    (($ $cont sym src ($ $kclause arity body))
+    (($ $cont sym ($ $kclause arity body))
      (receive (body free) (cc body self bound)
-       (values (build-cps-cont (sym src ($kclause ,arity ,body)))
+       (values (build-cps-cont (sym ($kclause ,arity ,body)))
                free)))
 
     (($ $cont)
@@ -153,76 +153,76 @@ convert functions to flat closures."
                   (free free))
            (match in
              (() (values (bindings body) free))
-             (((name sym ($ $fun meta () fun-body)) . in)
+             (((name sym ($ $fun src meta () fun-body)) . in)
               (receive (fun-body fun-free) (cc fun-body #f '())
                 (lp in
                     (lambda (body)
                       (let-gensyms (k)
                         (build-cps-term
-                          ($letk ((k #f ($kargs (name) (sym) ,(bindings body))))
-                            ($continue k
-                              ($fun meta fun-free ,fun-body))))))
-                    (init-closure #f sym fun-free self bound body)
+                          ($letk ((k ($kargs (name) (sym) ,(bindings body))))
+                            ($continue k src
+                              ($fun src meta fun-free ,fun-body))))))
+                    (init-closure src sym fun-free self bound body)
                     (union free (difference fun-free bound))))))))))
 
-    (($ $continue k ($ $var sym))
+    (($ $continue k src ($ $var sym))
      (convert-free-var sym self bound
                        (lambda (sym)
-                         (values (build-cps-term ($continue k ($var sym)))
+                         (values (build-cps-term ($continue k src ($var sym)))
                                  '()))))
 
-    (($ $continue k
+    (($ $continue k src
         (or ($ $void)
             ($ $const)
             ($ $prim)))
      (values exp '()))
 
-    (($ $continue k ($ $fun meta () body))
+    (($ $continue k src ($ $fun src* meta () body))
      (receive (body free) (cc body #f '())
        (match free
          (()
           (values (build-cps-term
-                    ($continue k ($fun meta free ,body)))
+                    ($continue k src ($fun src* meta free ,body)))
                   free))
          (_
           (values
            (let-gensyms (kinit v)
              (build-cps-term
-               ($letk ((kinit #f ($kargs (v) (v)
-                                   ,(init-closure #f v free self bound
-                                                  (build-cps-term
-                                                    ($continue k ($var v)))))))
-                 ($continue kinit ($fun meta free ,body)))))
+               ($letk ((kinit ($kargs (v) (v)
+                                ,(init-closure src v free self bound
+                                               (build-cps-term
+                                                 ($continue k src ($var v)))))))
+                 ($continue kinit src ($fun src* meta free ,body)))))
            (difference free bound))))))
 
-    (($ $continue k ($ $call proc args))
+    (($ $continue k src ($ $call proc args))
      (convert-free-vars (cons proc args) self bound
                         (match-lambda
                          ((proc . args)
                           (values (build-cps-term
-                                    ($continue k ($call proc args)))
+                                    ($continue k src ($call proc args)))
                                   '())))))
 
-    (($ $continue k ($ $primcall name args))
+    (($ $continue k src ($ $primcall name args))
      (convert-free-vars args self bound
                         (lambda (args)
                           (values (build-cps-term
-                                    ($continue k ($primcall name args)))
+                                    ($continue k src ($primcall name args)))
                                   '()))))
 
-    (($ $continue k ($ $values args))
+    (($ $continue k src ($ $values args))
      (convert-free-vars args self bound
                         (lambda (args)
                           (values (build-cps-term
-                                    ($continue k ($values args)))
+                                    ($continue k src ($values args)))
                                   '()))))
 
-    (($ $continue k ($ $prompt escape? tag handler pop))
+    (($ $continue k src ($ $prompt escape? tag handler pop))
      (convert-free-var
       tag self bound
       (lambda (tag)
         (values (build-cps-term
-                  ($continue k ($prompt escape? tag handler pop)))
+                  ($continue k src ($prompt escape? tag handler pop)))
                 '()))))
 
     (_ (error "what" exp))))
@@ -237,37 +237,38 @@ convert functions to flat closures."
     (rewrite-cps-term term
       (($ $letk conts body)
        ($letk ,(map visit-cont conts) ,(visit-term body)))
-      (($ $continue k ($ $primcall 'free-ref (closure sym)))
+      (($ $continue k src ($ $primcall 'free-ref (closure sym)))
        ,(let-gensyms (idx)
           (build-cps-term
             ($letconst (('idx idx (free-index sym)))
-              ($continue k ($primcall 'free-ref (closure idx)))))))
-      (($ $continue k ($ $fun meta free body))
-       ($continue k ($fun meta free ,(convert-to-indices body free))))
+              ($continue k src ($primcall 'free-ref (closure idx)))))))
+      (($ $continue k src ($ $fun src* meta free body))
+       ($continue k src
+         ($fun src* meta free ,(convert-to-indices body free))))
       (($ $continue)
        ,term)))
   (define (visit-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont sym src ($ $kargs names syms body))
-       (sym src ($kargs names syms ,(visit-term body))))
-      (($ $cont sym src ($ $kclause arity body))
-       (sym src ($kclause ,arity ,(visit-cont body))))
+      (($ $cont sym ($ $kargs names syms body))
+       (sym ($kargs names syms ,(visit-term body))))
+      (($ $cont sym ($ $kclause arity body))
+       (sym ($kclause ,arity ,(visit-cont body))))
       ;; Other kinds of continuations don't bind values and don't have
       ;; bodies.
       (($ $cont)
        ,cont)))
 
   (rewrite-cps-cont body
-    (($ $cont sym src ($ $kentry self tail clauses))
-     (sym src ($kentry self ,tail ,(map visit-cont clauses))))))
+    (($ $cont sym ($ $kentry self tail clauses))
+     (sym ($kentry self ,tail ,(map visit-cont clauses))))))
 
 (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 meta () body)
+    (($ $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 meta free ,(convert-to-indices body free)))))))
+         ($fun src meta free ,(convert-to-indices body free)))))))
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index a84280481..a3bef4689 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -76,413 +76,405 @@
     exp))
 
 (define (collect-conts f cfa)
-  (let ((srcv (make-vector (cfa-k-count cfa) #f))
-        (contv (make-vector (cfa-k-count cfa) #f)))
+  (let ((contv (make-vector (cfa-k-count cfa) #f)))
     (fold-local-conts
-     (lambda (k src cont tail)
+     (lambda (k cont tail)
        (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
          (when idx
-           (when src
-             (vector-set! srcv idx src))
            (vector-set! contv idx cont))))
      '()
      (match f
-       (($ $fun meta free entry)
+       (($ $fun src meta free entry)
         entry)))
-    (values srcv contv)))
+    contv))
 
 (define (compile-fun f asm)
   (let* ((dfg (compute-dfg f #:global? #f))
          (cfa (analyze-control-flow f dfg))
-         (allocation (allocate-slots f dfg)))
-    (call-with-values (lambda () (collect-conts f cfa))
-      (lambda (srcv contv)
-        (define (lookup-cont k)
-          (vector-ref contv (cfa-k-idx cfa k)))
+         (allocation (allocate-slots f dfg))
+         (contv (collect-conts f cfa)))
+    (define (lookup-cont k)
+      (vector-ref contv (cfa-k-idx cfa k)))
 
-        (define (maybe-emit-source n)
-          (let ((src (vector-ref srcv n)))
-            (when src
-              (emit-source asm src))))
+    (define (immediate-u8? val)
+      (and (integer? val) (exact? val) (<= 0 val 255)))
 
-        (define (emit-label-and-maybe-source n)
-          (emit-label asm (cfa-k-sym cfa n))
-          (maybe-emit-source n))
+    (define (maybe-immediate-u8 sym)
+      (call-with-values (lambda ()
+                          (lookup-maybe-constant-value sym allocation))
+        (lambda (has-const? val)
+          (and has-const? (immediate-u8? val) val))))
 
-        (define (immediate-u8? val)
-          (and (integer? val) (exact? val) (<= 0 val 255)))
+    (define (slot sym)
+      (lookup-slot sym allocation))
 
-        (define (maybe-immediate-u8 sym)
-          (call-with-values (lambda ()
-                              (lookup-maybe-constant-value sym allocation))
-            (lambda (has-const? val)
-              (and has-const? (immediate-u8? val) val))))
+    (define (constant sym)
+      (lookup-constant-value sym allocation))
 
-        (define (slot sym)
-          (lookup-slot sym allocation))
+    (define (maybe-mov dst src)
+      (unless (= dst src)
+        (emit-mov asm dst src)))
 
-        (define (constant sym)
-          (lookup-constant-value sym allocation))
+    (define (maybe-load-constant slot src)
+      (call-with-values (lambda ()
+                          (lookup-maybe-constant-value src allocation))
+        (lambda (has-const? val)
+          (and has-const?
+               (begin
+                 (emit-load-constant asm slot val)
+                 #t)))))
 
-        (define (maybe-mov dst src)
-          (unless (= dst src)
-            (emit-mov asm dst src)))
+    (define (compile-entry meta)
+      (match (vector-ref contv 0)
+        (($ $kentry self tail clauses)
+         (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+         (let lp ((n 1)
+                  (ks (map (match-lambda (($ $cont k) k)) clauses)))
+           (match ks
+             (()
+              (unless (= n (vector-length contv))
+                (error "unexpected end of clauses"))
+              (emit-end-program asm))
+             ((k . ks)
+              (unless (eq? (cfa-k-sym cfa n) k)
+                (error "unexpected k" k))
+              (lp (compile-clause n (and (pair? ks) (car ks)))
+                  ks)))))))
 
-        (define (maybe-load-constant slot src)
-          (call-with-values (lambda ()
-                              (lookup-maybe-constant-value src allocation))
-            (lambda (has-const? val)
-              (and has-const?
-                   (begin
-                     (emit-load-constant asm slot val)
-                     #t)))))
+    (define (compile-clause n alternate)
+      (match (vector-ref contv n)
+        (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+         (let* ((kw-indices (map (match-lambda
+                                  ((key name sym)
+                                   (cons key (lookup-slot sym allocation))))
+                                 kw))
+                (k (cfa-k-sym cfa n))
+                (nlocals (lookup-nlocals k allocation)))
+           (emit-label asm k)
+           (emit-begin-kw-arity asm req opt rest kw-indices
+                                allow-other-keys? nlocals alternate)
+           (let ((next (compile-body (1+ n) nlocals)))
+             (emit-end-arity asm)
+             next)))))
 
-        (define (compile-entry meta)
-          (match (vector-ref contv 0)
-            (($ $kentry self tail clauses)
-             (emit-begin-program asm (cfa-k-sym cfa 0) meta)
-             (maybe-emit-source 0)
-             (let lp ((n 1)
-                      (ks (map (match-lambda (($ $cont k) k)) clauses)))
-               (match ks
-                 (()
-                  (unless (= n (vector-length contv))
-                    (error "unexpected end of clauses"))
-                  (emit-end-program asm))
-                 ((k . ks)
-                  (unless (eq? (cfa-k-sym cfa n) k)
-                    (error "unexpected k" k))
-                  (lp (compile-clause n (and (pair? ks) (car ks)))
-                      ks)))))))
+    (define (compile-body n nlocals)
+      (let compile-cont ((n n))
+        (if (= n (vector-length contv))
+            n
+            (match (vector-ref contv n)
+              (($ $kclause) n)
+              (($ $kargs _ _ term)
+               (emit-label asm (cfa-k-sym cfa n))
+               (let find-exp ((term term))
+                 (match term
+                   (($ $letk conts term)
+                    (find-exp term))
+                   (($ $continue k src exp)
+                    (when src
+                      (emit-source asm src))
+                    (compile-expression n k exp nlocals)
+                    (compile-cont (1+ n))))))
+              (_
+               (emit-label asm (cfa-k-sym cfa n))
+               (compile-cont (1+ n)))))))
 
-        (define (compile-clause n alternate)
-          (match (vector-ref contv n)
-            (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
-             (let ((kw-indices (map (match-lambda
-                                     ((key name sym)
-                                      (cons key (lookup-slot sym allocation))))
-                                    kw))
-                   (nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation)))
-               (emit-label-and-maybe-source n)
-               (emit-begin-kw-arity asm req opt rest kw-indices
-                                    allow-other-keys? nlocals alternate)
-               (let ((next (compile-body (1+ n) nlocals)))
-                 (emit-end-arity asm)
-                 next)))))
+    (define (compile-expression n k exp nlocals)
+      (let* ((label (cfa-k-sym cfa n))
+             (k-idx (cfa-k-idx cfa k))
+             (fallthrough? (= k-idx (1+ n))))
+        (define (maybe-emit-jump)
+          (unless (= k-idx (1+ n))
+            (emit-br asm k)))
+        (match (vector-ref contv k-idx)
+          (($ $ktail)
+           (compile-tail label exp))
+          (($ $kargs (name) (sym))
+           (let ((dst (slot sym)))
+             (when dst
+               (compile-value label exp dst nlocals)))
+           (maybe-emit-jump))
+          (($ $kargs () ())
+           (compile-effect label exp k nlocals)
+           (maybe-emit-jump))
+          (($ $kargs names syms)
+           (compile-values label exp syms)
+           (maybe-emit-jump))
+          (($ $kif kt kf)
+           (compile-test label exp kt kf
+                         (and (= k-idx (1+ n))
+                              (< (+ n 2) (cfa-k-count cfa))
+                              (cfa-k-sym cfa (+ n 2)))))
+          (($ $ktrunc ($ $arity req () rest () #f) k)
+           (compile-trunc label exp (length req) (and rest #t) nlocals)
+           (unless (and (= k-idx (1+ n))
+                        (< (+ n 2) (cfa-k-count cfa))
+                        (eq? (cfa-k-sym cfa (+ n 2)) k))
+             (emit-br asm k))))))
 
-        (define (compile-body n nlocals)
-          (let compile-cont ((n n))
-            (if (= n (vector-length contv))
-                n
-                (match (vector-ref contv n)
-                  (($ $kclause) n)
-                  (($ $kargs _ _ term)
-                   (emit-label-and-maybe-source n)
-                   (let find-exp ((term term))
-                     (match term
-                       (($ $letk conts term)
-                        (find-exp term))
-                       (($ $continue k exp)
-                        (compile-expression n k exp nlocals)
-                        (compile-cont (1+ n))))))
-                  (_
-                   (emit-label-and-maybe-source n)
-                   (compile-cont (1+ n)))))))
+    (define (compile-tail label exp)
+      ;; There are only three kinds of expressions in tail position:
+      ;; tail calls, multiple-value returns, and single-value returns.
+      (match exp
+        (($ $call proc args)
+         (for-each (match-lambda
+                    ((src . dst) (emit-mov asm dst src)))
+                   (lookup-parallel-moves label allocation))
+         (let ((tail-slots (cdr (iota (1+ (length args))))))
+           (for-each maybe-load-constant tail-slots args))
+         (emit-tail-call asm (1+ (length args))))
+        (($ $values args)
+         (let ((tail-slots (cdr (iota (1+ (length args))))))
+           (for-each (match-lambda
+                      ((src . dst) (emit-mov asm dst src)))
+                     (lookup-parallel-moves label allocation))
+           (for-each maybe-load-constant tail-slots args))
+         (emit-reset-frame asm (1+ (length args)))
+         (emit-return-values asm))
+        (($ $primcall 'return (arg))
+         (emit-return asm (slot arg)))))
 
-        (define (compile-expression n k exp nlocals)
-          (let* ((label (cfa-k-sym cfa n))
-                 (k-idx (cfa-k-idx cfa k))
-                 (fallthrough? (= k-idx (1+ n))))
-            (define (maybe-emit-jump)
-              (unless (= k-idx (1+ n))
-                (emit-br asm k)))
-            (match (vector-ref contv k-idx)
-              (($ $ktail)
-               (compile-tail label exp))
-              (($ $kargs (name) (sym))
-               (let ((dst (slot sym)))
-                 (when dst
-                   (compile-value label exp dst nlocals)))
-               (maybe-emit-jump))
-              (($ $kargs () ())
-               (compile-effect label exp k nlocals)
-               (maybe-emit-jump))
-              (($ $kargs names syms)
-               (compile-values label exp syms)
-               (maybe-emit-jump))
-              (($ $kif kt kf)
-               (compile-test label exp kt kf
-                             (and (= k-idx (1+ n))
-                                  (< (+ n 2) (cfa-k-count cfa))
-                                  (cfa-k-sym cfa (+ n 2)))))
-              (($ $ktrunc ($ $arity req () rest () #f) k)
-               (compile-trunc label exp (length req) (and rest #t) nlocals)
-               (unless (and (= k-idx (1+ n))
-                            (< (+ n 2) (cfa-k-count cfa))
-                            (eq? (cfa-k-sym cfa (+ n 2)) k))
-                 (emit-br asm k))))))
+    (define (compile-value label exp dst nlocals)
+      (match exp
+        (($ $var sym)
+         (maybe-mov dst (slot sym)))
+        ;; FIXME: Remove ($var sym), replace with ($values (sym))
+        (($ $values (arg))
+         (or (maybe-load-constant dst arg)
+             (maybe-mov dst (slot arg))))
+        (($ $void)
+         (emit-load-constant asm dst *unspecified*))
+        (($ $const exp)
+         (emit-load-constant asm dst exp))
+        (($ $fun src meta () ($ $cont k))
+         (emit-load-static-procedure asm dst k))
+        (($ $fun src meta free ($ $cont k))
+         (emit-make-closure asm dst k (length free)))
+        (($ $call proc args)
+         (let ((proc-slot (lookup-call-proc-slot label allocation))
+               (nargs (length args)))
+           (or (maybe-load-constant proc-slot proc)
+               (maybe-mov proc-slot (slot proc)))
+           (let lp ((n (1+ proc-slot)) (args args))
+             (match args
+               (()
+                (emit-call asm proc-slot (+ nargs 1))
+                (emit-receive asm dst proc-slot nlocals))
+               ((arg . args)
+                (or (maybe-load-constant n arg)
+                    (maybe-mov n (slot arg)))
+                (lp (1+ n) args))))))
+        (($ $primcall 'current-module)
+         (emit-current-module asm dst))
+        (($ $primcall 'cached-toplevel-box (scope name bound?))
+         (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+                                   (constant bound?)))
+        (($ $primcall 'cached-module-box (mod name public? bound?))
+         (emit-cached-module-box asm dst (constant mod) (constant name)
+                                 (constant public?) (constant bound?)))
+        (($ $primcall 'resolve (name bound?))
+         (emit-resolve asm dst (constant bound?) (slot name)))
+        (($ $primcall 'free-ref (closure idx))
+         (emit-free-ref asm dst (slot closure) (constant idx)))
+        (($ $primcall 'make-vector (length init))
+         (cond
+          ((maybe-immediate-u8 length)
+           => (lambda (length)
+                (emit-constant-make-vector asm dst length (slot init))))
+          (else
+           (emit-make-vector asm dst (slot length) (slot init)))))
+        (($ $primcall 'vector-ref (vector index))
+         (cond
+          ((maybe-immediate-u8 index)
+           => (lambda (index)
+                (emit-constant-vector-ref asm dst (slot vector) index)))
+          (else
+           (emit-vector-ref asm dst (slot vector) (slot index)))))
+        (($ $primcall 'builtin-ref (name))
+         (emit-builtin-ref asm dst (constant name)))
+        (($ $primcall 'bv-u8-ref (bv idx))
+         (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-u16-ref (bv idx))
+         (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-s16-ref (bv idx))
+         (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-u32-ref (bv idx val))
+         (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-s32-ref (bv idx val))
+         (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-u64-ref (bv idx val))
+         (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-s64-ref (bv idx val))
+         (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-f32-ref (bv idx val))
+         (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall 'bv-f64-ref (bv idx val))
+         (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
+        (($ $primcall name args)
+         ;; FIXME: Inline all the cases.
+         (let ((inst (prim-rtl-instruction name)))
+           (emit-text asm `((,inst ,dst ,@(map slot args))))))))
 
-        (define (compile-tail label exp)
-          ;; There are only three kinds of expressions in tail position:
-          ;; tail calls, multiple-value returns, and single-value returns.
-          (match exp
-            (($ $call proc args)
-             (for-each (match-lambda
-                        ((src . dst) (emit-mov asm dst src)))
-                       (lookup-parallel-moves label allocation))
-             (let ((tail-slots (cdr (iota (1+ (length args))))))
-               (for-each maybe-load-constant tail-slots args))
-             (emit-tail-call asm (1+ (length args))))
-            (($ $values args)
-             (let ((tail-slots (cdr (iota (1+ (length args))))))
-               (for-each (match-lambda
-                          ((src . dst) (emit-mov asm dst src)))
-                         (lookup-parallel-moves label allocation))
-               (for-each maybe-load-constant tail-slots args))
-             (emit-reset-frame asm (1+ (length args)))
-             (emit-return-values asm))
-            (($ $primcall 'return (arg))
-             (emit-return asm (slot arg)))))
+    (define (compile-effect label exp k nlocals)
+      (match exp
+        (($ $values ()) #f)
+        (($ $prompt escape? tag handler pop)
+         (match (lookup-cont handler)
+           (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+            (let ((receive-args (gensym "handler"))
+                  (nreq (length req))
+                  (proc-slot (lookup-call-proc-slot label allocation)))
+              (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+              (emit-br asm k)
+              (emit-label asm receive-args)
+              (emit-receive-values asm proc-slot (->bool rest) nreq)
+              (when rest
+                (emit-bind-rest asm (+ proc-slot 1 nreq)))
+              (for-each (match-lambda
+                         ((src . dst) (emit-mov asm dst src)))
+                        (lookup-parallel-moves handler allocation))
+              (emit-reset-frame asm nlocals)
+              (emit-br asm khandler-body)))))
+        (($ $primcall 'cache-current-module! (sym scope))
+         (emit-cache-current-module! asm (slot sym) (constant scope)))
+        (($ $primcall 'free-set! (closure idx value))
+         (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+        (($ $primcall 'box-set! (box value))
+         (emit-box-set! asm (slot box) (slot value)))
+        (($ $primcall 'struct-set! (struct index value))
+         (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+        (($ $primcall 'vector-set! (vector index value))
+         (call-with-values (lambda ()
+                             (lookup-maybe-constant-value index allocation))
+           (lambda (has-const? index-val)
+             (if (and has-const? (integer? index-val) (exact? index-val)
+                      (<= 0 index-val 255))
+                 (emit-constant-vector-set! asm (slot vector) index-val
+                                            (slot value))
+                 (emit-vector-set! asm (slot vector) (slot index)
+                                   (slot value))))))
+        (($ $primcall 'variable-set! (var val))
+         (emit-box-set! asm (slot var) (slot val)))
+        (($ $primcall 'set-car! (pair value))
+         (emit-set-car! asm (slot pair) (slot value)))
+        (($ $primcall 'set-cdr! (pair value))
+         (emit-set-cdr! asm (slot pair) (slot value)))
+        (($ $primcall 'define! (sym value))
+         (emit-define! asm (slot sym) (slot value)))
+        (($ $primcall 'push-fluid (fluid val))
+         (emit-push-fluid asm (slot fluid) (slot val)))
+        (($ $primcall 'pop-fluid ())
+         (emit-pop-fluid asm))
+        (($ $primcall 'wind (winder unwinder))
+         (emit-wind asm (slot winder) (slot unwinder)))
+        (($ $primcall 'bv-u8-set! (bv idx val))
+         (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-u16-set! (bv idx val))
+         (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-s16-set! (bv idx val))
+         (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-u32-set! (bv idx val))
+         (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-s32-set! (bv idx val))
+         (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-u64-set! (bv idx val))
+         (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-s64-set! (bv idx val))
+         (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-f32-set! (bv idx val))
+         (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'bv-f64-set! (bv idx val))
+         (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
+        (($ $primcall 'unwind ())
+         (emit-unwind asm))))
 
-        (define (compile-value label exp dst nlocals)
-          (match exp
-            (($ $var sym)
-             (maybe-mov dst (slot sym)))
-            ;; FIXME: Remove ($var sym), replace with ($values (sym))
-            (($ $values (arg))
-             (or (maybe-load-constant dst arg)
-                 (maybe-mov dst (slot arg))))
-            (($ $void)
-             (emit-load-constant asm dst *unspecified*))
-            (($ $const exp)
-             (emit-load-constant asm dst exp))
-            (($ $fun meta () ($ $cont k))
-             (emit-load-static-procedure asm dst k))
-            (($ $fun meta free ($ $cont k))
-             (emit-make-closure asm dst k (length free)))
-            (($ $call proc args)
-             (let ((proc-slot (lookup-call-proc-slot label allocation))
-                   (nargs (length args)))
-               (or (maybe-load-constant proc-slot proc)
-                   (maybe-mov proc-slot (slot proc)))
-               (let lp ((n (1+ proc-slot)) (args args))
-                 (match args
-                   (()
-                    (emit-call asm proc-slot (+ nargs 1))
-                    (emit-receive asm dst proc-slot nlocals))
-                   ((arg . args)
-                    (or (maybe-load-constant n arg)
-                        (maybe-mov n (slot arg)))
-                    (lp (1+ n) args))))))
-            (($ $primcall 'current-module)
-             (emit-current-module asm dst))
-            (($ $primcall 'cached-toplevel-box (scope name bound?))
-             (emit-cached-toplevel-box asm dst (constant scope) (constant name)
-                                       (constant bound?)))
-            (($ $primcall 'cached-module-box (mod name public? bound?))
-             (emit-cached-module-box asm dst (constant mod) (constant name)
-                                     (constant public?) (constant bound?)))
-            (($ $primcall 'resolve (name bound?))
-             (emit-resolve asm dst (constant bound?) (slot name)))
-            (($ $primcall 'free-ref (closure idx))
-             (emit-free-ref asm dst (slot closure) (constant idx)))
-            (($ $primcall 'make-vector (length init))
-             (cond
-              ((maybe-immediate-u8 length)
-               => (lambda (length)
-                    (emit-constant-make-vector asm dst length (slot init))))
-              (else
-               (emit-make-vector asm dst (slot length) (slot init)))))
-            (($ $primcall 'vector-ref (vector index))
-             (cond
-              ((maybe-immediate-u8 index)
-               => (lambda (index)
-                    (emit-constant-vector-ref asm dst (slot vector) index)))
-              (else
-               (emit-vector-ref asm dst (slot vector) (slot index)))))
-            (($ $primcall 'builtin-ref (name))
-             (emit-builtin-ref asm dst (constant name)))
-            (($ $primcall 'bv-u8-ref (bv idx))
-             (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-u16-ref (bv idx))
-             (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-s16-ref (bv idx))
-             (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-u32-ref (bv idx val))
-             (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-s32-ref (bv idx val))
-             (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-u64-ref (bv idx val))
-             (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-s64-ref (bv idx val))
-             (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-f32-ref (bv idx val))
-             (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall 'bv-f64-ref (bv idx val))
-             (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
-            (($ $primcall name args)
-             ;; FIXME: Inline all the cases.
-             (let ((inst (prim-rtl-instruction name)))
-               (emit-text asm `((,inst ,dst ,@(map slot args))))))))
+    (define (compile-values label exp syms)
+      (match exp
+        (($ $values args)
+         (for-each (match-lambda
+                    ((src . dst) (emit-mov asm dst src)))
+                   (lookup-parallel-moves label allocation))
+         (for-each maybe-load-constant (map slot syms) args))))
 
-        (define (compile-effect label exp k nlocals)
-          (match exp
-            (($ $values ()) #f)
-            (($ $prompt escape? tag handler pop)
-             (match (lookup-cont handler)
-               (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
-                (let ((receive-args (gensym "handler"))
-                      (nreq (length req))
-                      (proc-slot (lookup-call-proc-slot label allocation)))
-                  (emit-prompt asm (slot tag) escape? proc-slot receive-args)
-                  (emit-br asm k)
-                  (emit-label asm receive-args)
-                  (emit-receive-values asm proc-slot (->bool rest) nreq)
-                  (when rest
-                    (emit-bind-rest asm (+ proc-slot 1 nreq)))
-                  (for-each (match-lambda
-                             ((src . dst) (emit-mov asm dst src)))
-                            (lookup-parallel-moves handler allocation))
-                  (emit-reset-frame asm nlocals)
-                  (emit-br asm khandler-body)))))
-            (($ $primcall 'cache-current-module! (sym scope))
-             (emit-cache-current-module! asm (slot sym) (constant scope)))
-            (($ $primcall 'free-set! (closure idx value))
-             (emit-free-set! asm (slot closure) (slot value) (constant idx)))
-            (($ $primcall 'box-set! (box value))
-             (emit-box-set! asm (slot box) (slot value)))
-            (($ $primcall 'struct-set! (struct index value))
-             (emit-struct-set! asm (slot struct) (slot index) (slot value)))
-            (($ $primcall 'vector-set! (vector index value))
-             (call-with-values (lambda ()
-                                 (lookup-maybe-constant-value index allocation))
-               (lambda (has-const? index-val)
-                 (if (and has-const? (integer? index-val) (exact? index-val)
-                          (<= 0 index-val 255))
-                     (emit-constant-vector-set! asm (slot vector) index-val
-                                                (slot value))
-                     (emit-vector-set! asm (slot vector) (slot index)
-                                       (slot value))))))
-            (($ $primcall 'variable-set! (var val))
-             (emit-box-set! asm (slot var) (slot val)))
-            (($ $primcall 'set-car! (pair value))
-             (emit-set-car! asm (slot pair) (slot value)))
-            (($ $primcall 'set-cdr! (pair value))
-             (emit-set-cdr! asm (slot pair) (slot value)))
-            (($ $primcall 'define! (sym value))
-             (emit-define! asm (slot sym) (slot value)))
-            (($ $primcall 'push-fluid (fluid val))
-             (emit-push-fluid asm (slot fluid) (slot val)))
-            (($ $primcall 'pop-fluid ())
-             (emit-pop-fluid asm))
-            (($ $primcall 'wind (winder unwinder))
-             (emit-wind asm (slot winder) (slot unwinder)))
-            (($ $primcall 'bv-u8-set! (bv idx val))
-             (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-u16-set! (bv idx val))
-             (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-s16-set! (bv idx val))
-             (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-u32-set! (bv idx val))
-             (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-s32-set! (bv idx val))
-             (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-u64-set! (bv idx val))
-             (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-s64-set! (bv idx val))
-             (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-f32-set! (bv idx val))
-             (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'bv-f64-set! (bv idx val))
-             (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
-            (($ $primcall 'unwind ())
-             (emit-unwind asm))))
+    (define (compile-test label exp kt kf next-label)
+      (define (unary op sym)
+        (cond
+         ((eq? kt next-label)
+          (op asm (slot sym) #t kf))
+         (else
+          (op asm (slot sym) #f kt)
+          (unless (eq? kf next-label)
+            (emit-br asm kf)))))
+      (define (binary op a b)
+        (cond
+         ((eq? kt next-label)
+          (op asm (slot a) (slot b) #t kf))
+         (else
+          (op asm (slot a) (slot b) #f kt)
+          (unless (eq? kf next-label)
+            (emit-br asm kf)))))
+      (match exp
+        (($ $var sym) (unary emit-br-if-true sym))
+        (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+        (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+        (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+        (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+        (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+        (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+        (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
+        (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
+        (($ $primcall 'string? (a)) (unary emit-br-if-string a))
+        (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
+        ;; Add more TC7 tests here.  Keep in sync with
+        ;; *branching-primcall-arities* in (language cps primitives) and
+        ;; the set of macro-instructions in assembly.scm.
+        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+        (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+        (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+        (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+        (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+        (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+        (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+        (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
 
-        (define (compile-values label exp syms)
-          (match exp
-            (($ $values args)
-             (for-each (match-lambda
-                        ((src . dst) (emit-mov asm dst src)))
-                       (lookup-parallel-moves label allocation))
-             (for-each maybe-load-constant (map slot syms) args))))
+    (define (compile-trunc label exp nreq rest? nlocals)
+      (match exp
+        (($ $call proc args)
+         (let ((proc-slot (lookup-call-proc-slot label allocation))
+               (nargs (length args)))
+           (or (maybe-load-constant proc-slot proc)
+               (maybe-mov proc-slot (slot proc)))
+           (let lp ((n (1+ proc-slot)) (args args))
+             (match args
+               (()
+                (emit-call asm proc-slot (+ nargs 1))
+                ;; FIXME: Only allow more values if there is a rest arg.
+                ;; Express values truncation by the presence of an
+                ;; unused rest arg instead of implicitly.
+                (emit-receive-values asm proc-slot #t nreq)
+                (when rest?
+                  (emit-bind-rest asm (+ proc-slot 1 nreq)))
+                (for-each (match-lambda
+                           ((src . dst) (emit-mov asm dst src)))
+                          (lookup-parallel-moves label allocation))
+                (emit-reset-frame asm nlocals))
+               ((arg . args)
+                (or (maybe-load-constant n arg)
+                    (maybe-mov n (slot arg)))
+                (lp (1+ n) args))))))))
 
-        (define (compile-test label exp kt kf next-label)
-          (define (unary op sym)
-            (cond
-             ((eq? kt next-label)
-              (op asm (slot sym) #t kf))
-             (else
-              (op asm (slot sym) #f kt)
-              (unless (eq? kf next-label)
-                (emit-br asm kf)))))
-          (define (binary op a b)
-            (cond
-             ((eq? kt next-label)
-              (op asm (slot a) (slot b) #t kf))
-             (else
-              (op asm (slot a) (slot b) #f kt)
-              (unless (eq? kf next-label)
-                (emit-br asm kf)))))
-          (match exp
-            (($ $var sym) (unary emit-br-if-true sym))
-            (($ $primcall 'null? (a)) (unary emit-br-if-null a))
-            (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
-            (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
-            (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
-            (($ $primcall 'char? (a)) (unary emit-br-if-char a))
-            (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
-            (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
-            (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
-            (($ $primcall 'string? (a)) (unary emit-br-if-string a))
-            (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
-            ;; Add more TC7 tests here.  Keep in sync with
-            ;; *branching-primcall-arities* in (language cps primitives) and
-            ;; the set of macro-instructions in assembly.scm.
-            (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
-            (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
-            (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
-            (($ $primcall '< (a b)) (binary emit-br-if-< a b))
-            (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
-            (($ $primcall '= (a b)) (binary emit-br-if-= a b))
-            (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
-            (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
-
-        (define (compile-trunc label exp nreq rest? nlocals)
-          (match exp
-            (($ $call proc args)
-             (let ((proc-slot (lookup-call-proc-slot label allocation))
-                   (nargs (length args)))
-               (or (maybe-load-constant proc-slot proc)
-                   (maybe-mov proc-slot (slot proc)))
-               (let lp ((n (1+ proc-slot)) (args args))
-                 (match args
-                   (()
-                    (emit-call asm proc-slot (+ nargs 1))
-                    ;; FIXME: Only allow more values if there is a rest arg.
-                    ;; Express values truncation by the presence of an
-                    ;; unused rest arg instead of implicitly.
-                    (emit-receive-values asm proc-slot #t nreq)
-                    (when rest?
-                      (emit-bind-rest asm (+ proc-slot 1 nreq)))
-                    (for-each (match-lambda
-                               ((src . dst) (emit-mov asm dst src)))
-                              (lookup-parallel-moves label allocation))
-                    (emit-reset-frame asm nlocals))
-                   ((arg . args)
-                    (or (maybe-load-constant n arg)
-                        (maybe-mov n (slot arg)))
-                    (lp (1+ n) args))))))))
-
-        (match f
-          (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
-           (compile-entry (or meta '()))))))))
+    (match f
+      (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+       ;; FIXME: src on kentry instead?
+       (when src
+         (emit-source asm src))
+       (compile-entry (or meta '()))))))
 
 (define (visit-funs proc exp)
   (match exp
-    (($ $continue _ exp)
+    (($ $continue _ _ exp)
      (visit-funs proc exp))
 
-    (($ $fun meta free body)
+    (($ $fun src meta free body)
      (proc exp)
      (visit-funs proc body))
 
@@ -490,13 +482,13 @@
      (visit-funs proc body)
      (for-each (lambda (cont) (visit-funs proc cont)) conts))
 
-    (($ $cont sym src ($ $kargs names syms body))
+    (($ $cont sym ($ $kargs names syms body))
      (visit-funs proc body))
 
-    (($ $cont sym src ($ $kclause arity body))
+    (($ $cont sym ($ $kclause arity body))
      (visit-funs proc body))
 
-    (($ $cont sym src ($ $kentry self tail clauses))
+    (($ $cont sym ($ $kentry self tail clauses))
      (for-each (lambda (clause) (visit-funs proc clause)) clauses))
 
     (_ (values))))
diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm
index b8d4e9639..d7ff0abc5 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -32,12 +32,12 @@
 (define (inline-constructors fun)
   (define (visit-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont sym src ($ $kargs names syms body))
-       (sym src ($kargs names syms ,(visit-term body))))
-      (($ $cont sym src ($ $kentry self tail clauses))
-       (sym src ($kentry self ,tail ,(map visit-cont clauses))))
-      (($ $cont sym src ($ $kclause arity body))
-       (sym src ($kclause ,arity ,(visit-cont body))))
+      (($ $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)
@@ -48,51 +48,51 @@
       (($ $letrec names syms funs body)
        ($letrec names syms (map inline-constructors funs)
                 ,(visit-term body)))
-      (($ $continue k ($ $primcall 'list args))
+      (($ $continue k src ($ $primcall 'list args))
        ,(let-gensyms (kvalues val)
           (build-cps-term
-            ($letk ((kvalues #f ($kargs ('val) (val)
-                                  ($continue k
-                                    ($primcall 'values (val))))))
+            ($letk ((kvalues ($kargs ('val) (val)
+                               ($continue k src
+                                 ($primcall 'values (val))))))
               ,(let lp ((args args) (k kvalues))
                  (match args
                    (()
                     (build-cps-term
-                      ($continue k ($const '()))))
+                      ($continue k src ($const '()))))
                    ((arg . args)
                     (let-gensyms (ktail tail)
                       (build-cps-term
-                        ($letk ((ktail #f ($kargs ('tail) (tail)
-                                            ($continue k
-                                              ($primcall 'cons (arg tail))))))
+                        ($letk ((ktail ($kargs ('tail) (tail)
+                                         ($continue k src
+                                           ($primcall 'cons (arg tail))))))
                           ,(lp args ktail)))))))))))
-      (($ $continue k ($ $primcall 'vector args))
+      (($ $continue k src ($ $primcall 'vector args))
        ,(let-gensyms (kalloc vec len init)
           (define (initialize args n)
             (match args
               (()
                (build-cps-term
-                 ($continue k ($primcall 'values (vec)))))
+                 ($continue k src ($primcall 'values (vec)))))
               ((arg . args)
                (let-gensyms (knext idx)
                  (build-cps-term
-                   ($letk ((knext #f ($kargs () ()
-                                       ,(initialize args (1+ n)))))
+                   ($letk ((knext ($kargs () ()
+                                    ,(initialize args (1+ n)))))
                      ($letconst (('idx idx n))
-                       ($continue knext
+                       ($continue knext src
                          ($primcall 'vector-set! (vec idx arg))))))))))
           (build-cps-term
-            ($letk ((kalloc #f ($kargs ('vec) (vec)
-                                 ,(initialize args 0))))
+            ($letk ((kalloc ($kargs ('vec) (vec)
+                              ,(initialize args 0))))
               ($letconst (('len len (length args))
                           ('init init #f))
-                ($continue kalloc
+                ($continue kalloc src
                   ($primcall 'make-vector (len init))))))))
-      (($ $continue k (and fun ($ $fun)))
-       ($continue k ,(inline-constructors fun)))
+      (($ $continue k src (and fun ($ $fun)))
+       ($continue k src ,(inline-constructors fun)))
       (($ $continue)
        ,term)))
 
   (rewrite-cps-exp fun
-    (($ $fun meta free body)
-     ($fun meta free ,(visit-cont body)))))
+    (($ $fun src meta free body)
+     ($fun src meta free ,(visit-cont body)))))
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index da7320660..6e8fe621d 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -95,7 +95,7 @@
       ;; target continuation.  Otherwise return #f.
       (define (call-target use proc)
         (match (find-call (lookup-cont use cont-table))
-          (($ $continue k ($ $call proc* args))
+          (($ $continue k src ($ $call proc* args))
            (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
                 k))
           (_ #f)))
@@ -141,7 +141,7 @@
                 ;; bail.
                 (($ $kentry self tail clauses)
                  (match clauses
-                   ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
+                   ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
                     kargs)
                    (_ #f)))
                 (_ scope)))))
@@ -168,15 +168,15 @@
 
     (define (visit-fun term)
       (match term
-        (($ $fun meta free body)
+        (($ $fun src meta free body)
          (visit-cont body))))
     (define (visit-cont cont)
       (match cont
-        (($ $cont sym src ($ $kargs _ _ body))
+        (($ $cont sym ($ $kargs _ _ body))
          (visit-term body sym))
-        (($ $cont sym src ($ $kentry self tail clauses))
+        (($ $cont sym ($ $kentry self tail clauses))
          (for-each visit-cont clauses))
-        (($ $cont sym src ($ $kclause arity body))
+        (($ $cont sym ($ $kclause arity body))
          (visit-cont body))
         (($ $cont)
          #t)))
@@ -199,7 +199,7 @@
                 (if (null? rec)
                     '()
                     (list rec)))
-               (((and elt (n s ($ $fun meta free ($ $cont kentry))))
+               (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
                  . nsf)
                 (if (recursive? kentry)
                     (lp nsf (cons elt rec))
@@ -208,11 +208,11 @@
            (match component
              (((name sym fun) ...)
               (match fun
-                ((($ $fun meta free
-                     ($ $cont fun-k _
+                ((($ $fun src meta free
+                     ($ $cont fun-k
                         ($ $kentry self
-                           ($ $cont tail-k _ ($ $ktail))
-                           (($ $cont _ _ ($ $kclause arity body))
+                           ($ $cont tail-k ($ $ktail))
+                           (($ $cont _ ($ $kclause arity body))
                             ...))))
                   ...)
                  (unless (contify-funs term-k sym self tail-k arity body)
@@ -220,13 +220,13 @@
          (visit-term body term-k)
          (for-each visit-component
                    (split-components (map list names syms funs))))
-        (($ $continue k exp)
+        (($ $continue k src exp)
          (match exp
-           (($ $fun meta free
-               ($ $cont fun-k _
+           (($ $fun src meta free
+               ($ $cont fun-k
                   ($ $kentry self
-                     ($ $cont tail-k _ ($ $ktail))
-                     (($ $cont _ _ ($ $kclause arity body)) ...))))
+                     ($ $cont tail-k ($ $ktail))
+                     (($ $cont _ ($ $kclause arity body)) ...))))
             (if (and=> (bound-symbol k)
                        (lambda (sym)
                          (contify-fun term-k sym self tail-k arity body)))
@@ -238,7 +238,7 @@
     (values call-substs cont-substs fun-elisions cont-splices)))
 
 (define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
-  (define (contify-call proc args)
+  (define (contify-call src proc args)
     (and=> (assq-ref call-substs proc)
            (lambda (clauses)
              (let lp ((clauses clauses))
@@ -247,11 +247,11 @@
                  (((($ $arity req () #f () #f) . k) . clauses)
                   (if (= (length req) (length args))
                       (build-cps-term
-                        ($continue k
+                        ($continue k src
                           ($values args)))
                       (lp clauses)))
                  ((_ . clauses) (lp clauses)))))))
-  (define (continue k exp)
+  (define (continue k src exp)
     (define (lookup-return-cont k)
       (match (assq-ref cont-substs k)
         (#f k)
@@ -260,13 +260,13 @@
       ;; We are contifying this return.  It must be a call or a
       ;; primcall to values, return, or return-values.
       (if (eq? k k*)
-          (build-cps-term ($continue k ,exp))
+          (build-cps-term ($continue k src ,exp))
           (rewrite-cps-term exp
             (($ $primcall 'return (val))
-             ($continue k* ($primcall 'values (val))))
+             ($continue k* src ($primcall 'values (val))))
             (($ $values vals)
-             ($continue k* ($primcall 'values vals)))
-            (_ ($continue k* ,exp))))))
+             ($continue k* src ($primcall 'values vals)))
+            (_ ($continue k* src ,exp))))))
   (define (splice-continuations term-k term)
     (match (hashq-ref cont-splices term-k)
       (#f term)
@@ -283,19 +283,19 @@
               ,body)))))))
   (define (visit-fun term)
     (rewrite-cps-exp term
-      (($ $fun meta free body)
-       ($fun meta free ,(visit-cont body)))))
+      (($ $fun src meta free body)
+       ($fun src meta free ,(visit-cont body)))))
   (define (visit-cont cont)
     (rewrite-cps-cont cont
       (($ $cont (? (cut assq <> fun-elisions)))
        ;; This cont gets inlined in place of the $fun.
        ,#f)
-      (($ $cont sym src ($ $kargs names syms body))
-       (sym src ($kargs names syms ,(visit-term body sym))))
-      (($ $cont sym src ($ $kentry self tail clauses))
-       (sym src ($kentry self ,tail ,(map visit-cont clauses))))
-      (($ $cont sym src ($ $kclause arity body))
-       (sym src ($kclause ,arity ,(visit-cont body))))
+      (($ $cont sym ($ $kargs names syms body))
+       (sym ($kargs names syms ,(visit-term body sym))))
+      (($ $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 term-k)
@@ -324,7 +324,7 @@
          (((names syms funs) ...)
           ($letrec names syms (map visit-fun funs)
                    ,(visit-term body term-k)))))
-      (($ $continue k exp)
+      (($ $continue k src exp)
        (splice-continuations
         term-k
         (match exp
@@ -335,11 +335,11 @@
                  (($ $kargs (_) (_) body)
                   (visit-term body k))))
             (else
-             (continue k (visit-fun exp)))))
+             (continue k src (visit-fun exp)))))
           (($ $call proc args)
-           (or (contify-call proc args)
-               (continue k exp)))
-          (_ (continue k exp)))))))
+           (or (contify-call src proc args)
+               (continue k src exp)))
+          (_ (continue k src exp)))))))
   (visit-fun fun))
 
 (define (contify fun)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index faefcd3d9..4d38d5200 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -73,14 +73,14 @@
             print-dfa))
 
 (define (build-cont-table fun)
-  (fold-conts (lambda (k src cont table)
+  (fold-conts (lambda (k cont table)
                 (hashq-set! table k cont)
                 table)
               (make-hash-table)
               fun))
 
 (define (build-local-cont-table cont)
-  (fold-local-conts (lambda (k src cont table)
+  (fold-local-conts (lambda (k cont table)
                       (hashq-set! table k cont)
                       table)
                     (make-hash-table)
@@ -206,10 +206,10 @@
                                         (reachable-preds k-map block-preds))))
       (make-cfa k-map order preds)))
   (match fun
-    (($ $fun meta free
-        ($ $cont kentry src
+    (($ $fun src meta free
+        ($ $cont kentry
            (and entry
-                ($ $kentry self ($ $cont ktail _ tail) clauses))))
+                ($ $kentry self ($ $cont ktail tail) clauses))))
      (if reverse?
          (build-cfa ktail block-preds block-succs)
          (build-cfa kentry block-succs block-preds)))))
@@ -549,13 +549,13 @@
       (map (cut hashq-ref mapping <>)
            ((block-accessor blocks accessor) k))))
   (match fun
-    (($ $fun meta free
+    (($ $fun src meta free
         (and entry
-             ($ $cont kentry src ($ $kentry self ($ $cont ktail _ tail)))))
+             ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
      (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
        (lambda (var-map nvars)
          (define (fold-all-conts f seed)
-           (fold-local-conts (lambda (k src cont seed) (f k seed))
+           (fold-local-conts (lambda (k cont seed) (f k seed))
                              seed entry))
          (let* ((blocks (dfg-blocks dfg))
                 (order (reverse-post-order ktail
@@ -662,7 +662,7 @@
     (define (recur exp)
       (visit exp exp-k))
     (match exp
-      (($ $letk (($ $cont k src cont) ...) body)
+      (($ $letk (($ $cont k cont) ...) body)
        ;; Set up recursive environment before visiting cont bodies.
        (for-each (lambda (cont k)
                    (declare-block! k cont exp-k))
@@ -688,7 +688,7 @@
        (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
        (visit body exp-k))
 
-      (($ $continue k exp)
+      (($ $continue k src exp)
        (use-k! k)
        (match exp
          (($ $var sym)
@@ -726,10 +726,10 @@
          (_ #f)))))
 
   (match fun
-    (($ $fun meta free
-        ($ $cont kentry src
+    (($ $fun src meta free
+        ($ $cont kentry
            (and entry
-                ($ $kentry self ($ $cont ktail _ tail) clauses))))
+                ($ $kentry self ($ $cont ktail tail) clauses))))
      (declare-block! kentry entry #f 0)
      (add-def! #f self kentry)
 
@@ -737,8 +737,8 @@
 
      (for-each
       (match-lambda
-       (($ $cont kclause _
-           (and clause ($ $kclause arity ($ $cont kbody _ body))))
+       (($ $cont kclause
+           (and clause ($ $kclause arity ($ $cont kbody body))))
         (declare-block! kclause clause kentry)
         (link-blocks! kentry kclause)
 
@@ -811,7 +811,7 @@
 
 (define (call-expression call)
   (match call
-    (($ $continue k exp) exp)))
+    (($ $continue k src exp) exp)))
 
 (define (find-expression term)
   (call-expression (find-call term)))
@@ -827,7 +827,7 @@
   (match (find-defining-expression sym dfg)
     (($ $const val)
      (values #t val))
-    (($ $continue k ($ $void))
+    (($ $continue k src ($ $void))
      (values #t *unspecified*))
     (else
      (values #f #f))))
diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index b738b1c41..0168ab87f 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -37,15 +37,15 @@
 
 (define (elide-values fun)
   (let ((conts (build-local-cont-table
-                (match fun (($ $fun meta free body) body)))))
+                (match fun (($ $fun src meta free body) body)))))
     (define (visit-cont cont)
       (rewrite-cps-cont cont
-        (($ $cont sym src ($ $kargs names syms body))
-         (sym src ($kargs names syms ,(visit-term body))))
-        (($ $cont sym src ($ $kentry self tail clauses))
-         (sym src ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym src ($ $kclause arity body))
-         (sym src ($kclause ,arity ,(visit-cont body))))
+        (($ $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)
@@ -56,27 +56,27 @@
         (($ $letrec names syms funs body)
          ($letrec names syms (map elide-values funs)
                   ,(visit-term body)))
-        (($ $continue k ($ $primcall 'values vals))
+        (($ $continue k src ($ $primcall 'values vals))
          ,(rewrite-cps-term (lookup-cont k conts)
             (($ $ktail)
-             ($continue k ($values vals)))
+             ($continue k src ($values vals)))
             (($ $ktrunc ($ $arity req () rest () #f) kargs)
              ,(if (or rest (< (length vals) (length req)))
                   term
                   (let ((vals (list-head vals (length req))))
                     (build-cps-term
-                      ($continue kargs ($values vals))))))
+                      ($continue kargs src ($values vals))))))
             (($ $kargs args)
              ,(if (< (length vals) (length args))
                   term
                   (let ((vals (list-head vals (length args))))
                     (build-cps-term
-                      ($continue k ($values vals))))))))
-        (($ $continue k (and fun ($ $fun)))
-         ($continue k ,(elide-values fun)))
+                      ($continue k src ($values vals))))))))
+        (($ $continue k src (and fun ($ $fun)))
+         ($continue k src ,(elide-values fun)))
         (($ $continue)
          ,term)))
 
     (rewrite-cps-exp fun
-      (($ $fun meta free body)
-       ($fun meta free ,(visit-cont body))))))
+      (($ $fun src meta free body)
+       ($fun src meta free ,(visit-cont body))))))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 2b1a1018a..68de29494 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -39,8 +39,8 @@
                   ('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))))))))
 
@@ -72,63 +72,61 @@
     ((class-of @slot-ref @slot-set!) '(oop goops))
     (else '(guile))))
 
-(define (primitive-ref name k)
+(define (primitive-ref name k src)
   (module-box #f (primitive-module name) name #f #t
               (lambda (box)
                 (build-cps-term
-                  ($continue k ($primcall 'box-ref (box)))))))
+                  ($continue k src ($primcall 'box-ref (box)))))))
 
-(define (builtin-ref idx k)
+(define (builtin-ref idx k src)
   (let-gensyms (idx-sym)
     (build-cps-term
       ($letconst (('idx idx-sym idx))
-        ($continue k
+        ($continue k src
           ($primcall 'builtin-ref (idx-sym)))))))
 
 (define (reify-clause ktail)
   (let-gensyms (kclause kbody wna false str eol kthrow throw)
     (build-cps-cont
-      (kclause #f ($kclause ('() '() #f '() #f)
-                   (kbody
-                    #f
-                    ($kargs () ()
-                      ($letconst (('wna wna 'wrong-number-of-args)
-                                  ('false false #f)
-                                  ('str str "Wrong number of arguments")
-                                  ('eol eol '()))
-                        ($letk ((kthrow
-                                 #f
-                                 ($kargs ('throw) (throw)
-                                   ($continue ktail
-                                     ($call throw
-                                            (wna false str eol false))))))
-                          ,(primitive-ref 'throw kthrow))))))))))
+      (kclause ($kclause ('() '() #f '() #f)
+                 (kbody
+                  ($kargs () ()
+                    ($letconst (('wna wna 'wrong-number-of-args)
+                                ('false false #f)
+                                ('str str "Wrong number of arguments")
+                                ('eol eol '()))
+                      ($letk ((kthrow
+                               ($kargs ('throw) (throw)
+                                 ($continue ktail #f
+                                   ($call throw
+                                          (wna false str eol false))))))
+                        ,(primitive-ref 'throw kthrow #f))))))))))
 
 ;; 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 meta free body)
-         ($fun meta free ,(visit-cont body)))))
+        (($ $fun src meta free body)
+         ($fun src meta free ,(visit-cont body)))))
     (define (visit-cont cont)
       (rewrite-cps-cont cont
-        (($ $cont sym src ($ $kargs names syms body))
-         (sym src ($kargs names syms ,(visit-term body))))
-        (($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ()))
+        (($ $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 src ($kentry self ,tail (,(reify-clause ktail)))))
-        (($ $cont sym src ($ $kentry self tail clauses))
-         (sym src ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym src ($ $kclause arity body))
-         (sym src ($kclause ,arity ,(visit-cont body))))
+         (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 exp)
+        (($ $continue k src exp)
          ,(match exp
             (($ $prim name)
              (match (lookup-cont k conts)
@@ -136,14 +134,14 @@
                 (cond
                  ((builtin-name->index name)
                   => (lambda (idx)
-                       (builtin-ref idx k)))
-                 (else (primitive-ref name k))))
-               (_ (build-cps-term ($continue k ($void))))))
+                       (builtin-ref idx k src)))
+                 (else (primitive-ref name k src))))
+               (_ (build-cps-term ($continue k src ($void))))))
             (($ $fun)
-             (build-cps-term ($continue k ,(visit-fun exp))))
+             (build-cps-term ($continue k src ,(visit-fun exp))))
             (($ $primcall 'call-thunk/no-inline (proc))
              (build-cps-term
-               ($continue k ($call proc ()))))
+               ($continue k src ($call proc ()))))
             (($ $primcall name args)
              (cond
               ((or (prim-rtl-instruction name) (branching-primitive? name))
@@ -152,13 +150,13 @@
               (else
                (let-gensyms (k* v)
                  (build-cps-term
-                   ($letk ((k* #f ($kargs (v) (v)
-                                    ($continue k ($call v args)))))
+                   ($letk ((k* ($kargs (v) (v)
+                                 ($continue k src ($call v args)))))
                      ,(cond
                        ((builtin-name->index name)
                         => (lambda (idx)
-                             (builtin-ref idx k*)))
-                       (else (primitive-ref name k*)))))))))
+                             (builtin-ref idx k* src)))
+                       (else (primitive-ref name k* src)))))))))
             (_ term)))))
 
     (visit-fun fun)))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index c0d21d9ec..580d0f97e 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -235,7 +235,7 @@ are comparable with eqv?.  A tmp slot may be used."
     (define nlocals (compute-slot live-slots #f))
     (define nargs
       (match clause
-        (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+        (($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms))))
          (length syms))))
 
     (define (allocate! sym k hint live-slots)
@@ -310,7 +310,7 @@ are comparable with eqv?.  A tmp slot may be used."
             live-slots))
 
       (match cont
-        (($ $kclause arity ($ $cont k src body))
+        (($ $kclause arity ($ $cont k body))
          (visit-cont body k live-slots))
 
         (($ $kargs names syms body)
@@ -328,12 +328,12 @@ are comparable with eqv?.  A tmp slot may be used."
         (($ $letk conts body)
          (let ((live-slots (visit-term body label live-slots)))
            (for-each (match-lambda
-                      (($ $cont k src cont)
+                      (($ $cont k cont)
                        (visit-cont cont k live-slots)))
                      conts))
          live-slots)
 
-        (($ $continue k exp)
+        (($ $continue k src exp)
          (visit-exp exp label k live-slots))))
 
     (define (visit-exp exp label k live-slots)
@@ -420,12 +420,12 @@ are comparable with eqv?.  A tmp slot may be used."
         (_ live-slots)))
 
     (match clause
-      (($ $cont k _ body)
+      (($ $cont k body)
        (visit-cont body k live-slots)
        (hashq-set! allocation k nlocals))))
 
   (match fun
-    (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
+    (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
      (let* ((dfa (compute-live-variables fun dfg))
             (allocation (make-hash-table))
             (slots (make-vector (dfa-var-count dfa) #f))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 76fad5109..3772f21d2 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -71,7 +71,7 @@
 
   (define (visit-clause clause k-env v-env)
     (match clause
-      (($ $cont kclause src*
+      (($ $cont kclause
           ($ $kclause 
              ($ $arity
                 ((? symbol? req) ...)
@@ -79,9 +79,7 @@
                 (and rest (or #f (? symbol?)))
                 (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
                 (or #f #t))
-             ($ $cont kbody src (and body ($ $kargs names syms _)))))
-       (check-src src*)
-       (check-src src)
+             ($ $cont kbody (and body ($ $kargs names syms _)))))
        (for-each (lambda (sym)
                    (unless (memq sym syms)
                      (error "bad keyword sym" sym)))
@@ -98,9 +96,9 @@
 
   (define (visit-fun fun k-env v-env)
     (match fun
-      (($ $fun meta ((? symbol? free) ...)
-          ($ $cont kbody src
-             ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses)))
+      (($ $fun src meta ((? symbol? free) ...)
+          ($ $cont kbody
+             ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
        (when (and meta (not (and (list? meta) (and-map pair? meta))))
          (error "meta should be alist" meta))
        (for-each (cut check-var <> v-env) free)
@@ -142,9 +140,8 @@
 
   (define (visit-term term k-env v-env)
     (match term
-      (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
+      (($ $letk (($ $cont (? symbol? k) cont) ...) body)
        (let ((k-env (add-env k k-env)))
-         (for-each check-src src)
          (for-each (cut visit-cont-body <> k-env v-env) cont)
          (visit-term body k-env v-env)))
 
@@ -155,8 +152,9 @@
          (for-each (cut visit-fun <> k-env v-env) fun)
          (visit-term body k-env v-env)))
 
-      (($ $continue k exp)
+      (($ $continue k src exp)
        (check-var k k-env)
+       (check-src src)
        (visit-expression exp k-env v-env))
 
       (_
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 493e1e760..c705694ab 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -81,18 +81,18 @@
     (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)
                 (build-cps-term
                   ($letconst (('scope scope-sym scope))
-                    ($continue kbox
+                    ($continue kbox src
                       ($primcall 'cached-toplevel-box
                                  (scope-sym name-sym bound?-sym)))))))))))))
 
@@ -103,8 +103,8 @@
                   ('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))))))))
 
@@ -112,11 +112,11 @@
   (let-gensyms (module scope-sym kmodule)
     (build-cps-term
       ($letconst (('scope scope-sym scope))
-        ($letk ((kmodule src ($kargs ('module) (module)
-                               ($continue k
-                                 ($primcall 'cache-current-module!
-                                            (module scope-sym))))))
-          ($continue kmodule
+        ($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)
@@ -162,8 +162,8 @@
   (let-gensyms (unbound ktest)
     (build-cps-term
       ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
-        ($letk ((ktest src ($kif kt kf)))
-          ($continue ktest
+        ($letk ((ktest ($kif kt kf)))
+          ($continue ktest src
             ($primcall 'eq? (sym unbound))))))))
 
 (define (init-default-value name sym subst init body)
@@ -174,19 +174,19 @@
          (if box?
              (let-gensyms (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)
          (build-cps-term
-           ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+           ($letk ((knext ($kargs (name) (subst-sym) ,body)))
              ,(maybe-box
                knext
                (lambda (k)
                  (build-cps-term
-                   ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
-                           (kunbound src ($kargs () () ,(convert init k subst))))
+                   ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
+                           (kunbound ($kargs () () ,(convert init k subst))))
                      ,(unbound? src sym kunbound kbound))))))))))))
 
 ;; exp k-name alist -> term
@@ -199,16 +199,15 @@
          ((box #t)
           (let-gensyms (kunboxed unboxed)
             (build-cps-term
-              ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
-                ($continue kunboxed ($primcall 'box-ref (box)))))))
+              ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+                ($continue kunboxed src ($primcall 'box-ref (box)))))))
          ((subst #f) (k subst))
          (#f (k sym))))
       (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-gensyms (karg arg)
+         (build-cps-term
+           ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
+             ,(convert exp karg subst)))))))
   ;; (exp ...) ((v-name ...) -> term) -> term
   (define (convert-args exps k)
     (match exps
@@ -224,25 +223,25 @@
       ((box #t)
        (let-gensyms (k)
          (build-cps-term
-           ($letk ((k #f ($kargs (name) (box) ,body)))
-             ($continue k ($primcall 'box (sym)))))))
+           ($letk ((k ($kargs (name) (box) ,body)))
+             ($continue k #f ($primcall 'box (sym)))))))
       (else body)))
 
   (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))))))
+       ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
+       ((subst #f) (build-cps-term ($continue k src ($var subst))))
+       (#f (build-cps-term ($continue k src ($var sym))))))
 
     (($ <void> src)
-     (build-cps-term ($continue k ($void))))
+     (build-cps-term ($continue k src ($void))))
 
     (($ <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 ()
@@ -260,10 +259,8 @@
                (let-gensyms (kclause kargs)
                  (build-cps-cont
                    (kclause
-                    src
                     ($kclause ,arity
                       (kargs
-                       src
                        ($kargs names gensyms
                          ,(fold-formals
                            (lambda (name sym init body)
@@ -276,15 +273,13 @@
        (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)))))))
+               ($continue k fun-src
+                 ($fun fun-src meta '()
+                       (kentry ($kentry self (ktail ($ktail))
+                                 ,(convert-clauses body ktail)))))))
            (let-gensyms (scope kscope)
              (build-cps-term
-               ($letk ((kscope fun-src
-                               ($kargs () ()
+               ($letk ((kscope ($kargs () ()
                                  ,(parameterize ((current-topbox-scope scope))
                                     (convert exp k subst)))))
                  ,(capture-toplevel-scope fun-src scope kscope)))))))
@@ -293,7 +288,7 @@
      (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 +296,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,7 +311,8 @@
          (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
@@ -323,13 +320,13 @@
          (let-gensyms (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
@@ -389,22 +386,21 @@
          (match args
            (()
             (build-cps-term
-              ($continue k ($const '()))))
+              ($continue k src ($const '()))))
            ((arg . args)
             (let-gensyms (ktail tail)
               (build-cps-term
-                ($letk ((ktail src
-                               ($kargs ('tail) (tail)
+                ($letk ((ktail ($kargs ('tail) (tail)
                                  ,(convert-arg arg
                                     (lambda (head)
                                       (build-cps-term
-                                        ($continue k
+                                        ($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
@@ -427,42 +423,38 @@
          (let ((hnames (append hreq (if hrest (list hrest) '()))))
            (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
              (build-cps-term
-               ($letk* ((khbody hsrc ($kargs hnames hsyms
-                                       ,(fold box-bound-var
-                                              (convert hbody k subst)
-                                              hnames hsyms)))
-                        (khargs hsrc ($ktrunc hreq hrest khbody))
-                        (kpop src
-                              ($kargs ('rest) (vals)
+               ;; FIXME: Attach hsrc to $ktrunc.
+               ($letk* ((khbody ($kargs hnames hsyms
+                                  ,(fold box-bound-var
+                                         (convert hbody k subst)
+                                         hnames hsyms)))
+                        (khargs ($ktrunc 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 ($ktrunc '() '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 kpop))))
                       (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
+                              ($continue kbody (tree-il-src body)
                                 ($prompt #f tag khargs kpop))))))))))))))
 
     ;; Eta-convert prompts without inline handlers.
@@ -503,7 +495,8 @@
      (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)
@@ -512,24 +505,24 @@
                            (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)
        (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)))
+                  (kif ($kif kt kf)))
            ,(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 kif src ($primcall name args))))))
               (_ (convert-arg test
                    (lambda (test)
-                     (build-cps-term ($continue kif ($var test)))))))))))
+                     (build-cps-term
+                       ($continue kif src ($var test)))))))))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg exp
@@ -537,14 +530,14 @@
          (match (assq-ref subst gensym)
            ((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)
        (build-cps-term
-         ($letk* ((kseq (tree-il-src tail) ($kargs () ()
-                                             ,(convert tail k subst)))
-                  (ktrunc src ($ktrunc '() #f kseq)))
+         ($letk* ((kseq ($kargs () ()
+                          ,(convert tail k subst)))
+                  (ktrunc ($ktrunc '() #f kseq)))
            ,(convert head ktrunc subst)))))
 
     (($ <let> src names syms vals body)
@@ -554,9 +547,9 @@
          (((name . names) (sym . syms) (val . vals))
           (let-gensyms (klet)
             (build-cps-term
-              ($letk ((klet src ($kargs (name) (sym)
-                                  ,(box-bound-var name sym
-                                                  (lp names syms vals)))))
+              ($letk ((klet ($kargs (name) (sym)
+                              ,(box-bound-var name sym
+                                              (lp names syms vals)))))
                 ,(convert val klet subst))))))))
 
     (($ <fix> src names gensyms funs body)
@@ -568,15 +561,15 @@
                       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)))))
+             ($letk ((kscope ($kargs () ()
+                               ,(parameterize ((current-topbox-scope scope))
+                                  (convert exp k subst)))))
                ,(capture-toplevel-scope src scope kscope))))))
 
     (($ <let-values> src exp
@@ -584,11 +577,11 @@
      (let ((names (append req (if rest (list rest) '()))))
        (let-gensyms (ktrunc kargs)
          (build-cps-term
-           ($letk* ((kargs src ($kargs names syms
-                                 ,(fold box-bound-var
-                                        (convert body k subst)
-                                        names syms)))
-                    (ktrunc src ($ktrunc req rest kargs)))
+           ($letk* ((kargs ($kargs names syms
+                             ,(fold box-bound-var
+                                    (convert body k subst)
+                                    names syms)))
+                    (ktrunc ($ktrunc req rest kargs)))
              ,(convert exp ktrunc subst))))))))
 
 (define (build-subst exp)
@@ -628,16 +621,14 @@ indicates that the replacement variable is in a box."
   (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))))))))))))))
+        ($fun src '() '()
+          (kinit ($kentry init
+                   (ktail ($ktail))
+                   ((kclause
+                     ($kclause ('() '() #f '() #f)
+                       (kbody ($kargs () ()
+                                ,(convert exp ktail
+                                          (build-subst exp))))))))))))))
 
 (define *comp-module* (make-fluid))