X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/828ed94469b4c8cf69db08e6aeb12b399b67ed20..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/tree-il/compile-cps.scm

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