(compile foo #:to 'cps)

* module/language/tree-il/compile-cps.scm: New module implementing CPS
  conversion of Tree-IL.

* module/Makefile.am:
* module/language/tree-il/spec.scm:
* module/language/cps/spec.scm: Integrate CPS in the build and language
  system.

4 files changed, 635 insertions, 1 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 1f66ac4f8..fea910f5e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -112,12 +112,14 @@ TREE_IL_LANG_SOURCES =						\
   language/tree-il/canonicalize.scm                             \
   language/tree-il/analyze.scm					\
   language/tree-il/inline.scm 					\
+  language/tree-il/compile-cps.scm 				\
   language/tree-il/compile-glil.scm 				\
   language/tree-il/debug.scm 					\
   language/tree-il/spec.scm
 
 CPS_LANG_SOURCES =						\
   language/cps.scm						\
+  language/cps/spec.scm						\
   language/cps/verify.scm
 
 GLIL_LANG_SOURCES =						\
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
new file mode 100644
index 000000000..38dc54d1c
--- /dev/null
+++ b/module/language/cps/spec.scm
@@ -0,0 +1,36 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language cps spec)
+  #:use-module (system base language)
+  #:use-module (language cps)
+  #:export (cps))
+
+(define* (write-cps exp #:optional (port (current-output-port)))
+  (write (unparse-cps exp) port))
+
+(define-language cps
+  #:title	"CPS Intermediate Language"
+  #:reader	(lambda (port env) (read port))
+  #:printer	write-cps
+  #:parser      parse-cps
+  #:compilers   '()
+  #:for-humans? #f
+  )
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
new file mode 100644
index 000000000..e7befbe41
--- /dev/null
+++ b/module/language/tree-il/compile-cps.scm
@@ -0,0 +1,594 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; This pass converts Tree-IL to the continuation-passing style (CPS)
+;;; language.
+;;;
+;;; CPS is a lower-level representation than Tree-IL.  Converting to
+;;; CPS, beyond adding names for all control points and all values,
+;;; simplifies expressions in the following ways, among others:
+;;;
+;;;   * Fixing the order of evaluation.
+;;;
+;;;   * Converting assigned variables to boxed variables.
+;;;
+;;;   * Requiring that Scheme's <letrec> has already been lowered to
+;;;     <fix>.
+;;;
+;;;   * Inlining default-value initializers into lambda-case
+;;;     expressions.
+;;;
+;;;   * Inlining prompt bodies.
+;;;
+;;;   * Turning toplevel and module references into primcalls.  This
+;;;     involves explicitly modelling the "scope" of toplevel lookups
+;;;     (indicating the module with respect to which toplevel bindings
+;;;     are resolved).
+;;;
+;;; The utility of CPS is that it gives a name to everything: every
+;;; intermediate value, and every control point (continuation).  As such
+;;; it is more verbose than Tree-IL, but at the same time more simple as
+;;; the number of concepts is reduced.
+;;;
+;;; Code:
+
+(define-module (language tree-il compile-cps)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
+  #:use-module (srfi srfi-26)
+  #:use-module ((system foreign) #:select (make-pointer pointer->scm))
+  #:use-module (language cps)
+  #:use-module (language cps primitives)
+  #:use-module (language tree-il analyze)
+  #:use-module (language tree-il optimize)
+  #:use-module ((language tree-il)
+                #:select
+                (<void>
+                 <const> <primitive-ref> <lexical-ref> <lexical-set>
+                 <module-ref> <module-set>
+                 <toplevel-ref> <toplevel-set> <toplevel-define>
+                 <conditional>
+                 <call> <primcall>
+                 <seq>
+                 <lambda> <lambda-case>
+                 <let> <letrec> <fix> <let-values>
+                 <prompt> <abort>
+                 make-conditional make-const make-primcall
+                 tree-il-src
+                 tree-il-fold))
+  #:export (compile-cps))
+
+;;; Guile's semantics are that a toplevel lambda captures a reference on
+;;; the current module, and that all contained lambdas use that module
+;;; to resolve toplevel variables.  This parameter tracks whether or not
+;;; we are in a toplevel lambda.  If we are in a lambda, the parameter
+;;; is bound to a fresh name identifying the module that was current
+;;; when the toplevel lambda is defined.
+;;;
+;;; This is more complicated than it need be.  Ideally we should resolve
+;;; all toplevel bindings to bindings from specific modules, unless the
+;;; binding is unbound.  This is always valid if the compilation unit
+;;; sets the module explicitly, as when compiling a module, but it
+;;; doesn't work for files auto-compiled for use with `load'.
+;;;
+(define current-topbox-scope (make-parameter #f))
+
+(define (toplevel-box src name bound? val-proc)
+  (let-gensyms (name-sym bound?-sym kbox box)
+    (build-cps-term
+      ($letconst (('name name-sym name)
+                  ('bound? bound?-sym bound?))
+        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+          ,(match (current-topbox-scope)
+             (#f
+              (build-cps-term
+                ($continue kbox
+                  ($primcall 'resolve
+                             (name-sym bound?-sym)))))
+             (scope
+              (let-gensyms (scope-sym)
+                (build-cps-term
+                  ($letconst (('scope scope-sym scope))
+                    ($continue kbox
+                      ($primcall 'cached-toplevel-box
+                                 (scope-sym name-sym bound?-sym)))))))))))))
+
+(define (module-box src module name public? bound? val-proc)
+  (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+    (build-cps-term
+      ($letconst (('module module-sym module)
+                  ('name name-sym name)
+                  ('public? public?-sym public?)
+                  ('bound? bound?-sym bound?))
+        ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+          ($continue kbox
+            ($primcall 'cached-module-box
+                       (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (capture-toplevel-scope src scope k)
+  (let-gensyms (module scope-sym kmodule)
+    (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
+            ($primcall 'current-module ())))))))
+
+(define (fold-formals proc seed arity gensyms inits)
+  (match arity
+    (($ $arity req opt rest kw allow-other-keys?)
+     (let ()
+       (define (fold-req names gensyms seed)
+         (match names
+           (() (fold-opt opt gensyms inits seed))
+           ((name . names)
+            (proc name (car gensyms) #f
+                  (fold-req names (cdr gensyms) seed)))))
+       (define (fold-opt names gensyms inits seed)
+         (match names
+           (() (fold-rest rest gensyms inits seed))
+           ((name . names)
+            (proc name (car gensyms) (car inits)
+                  (fold-opt names (cdr gensyms) (cdr inits) seed)))))
+       (define (fold-rest rest gensyms inits seed)
+         (match rest
+           (#f (fold-kw kw gensyms inits seed))
+           (name (proc name (car gensyms) #f
+                       (fold-kw kw (cdr gensyms) inits seed)))))
+       (define (fold-kw kw gensyms inits seed)
+         (match kw
+           (()
+            (unless (null? gensyms)
+              (error "too many gensyms"))
+            (unless (null? inits)
+              (error "too many inits"))
+            seed)
+           (((key name var) . kw)
+            (unless (eq? var (car gensyms))
+              (error "unexpected keyword arg order"))
+            (proc name var (car inits)
+                  (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
+       (fold-req req gensyms seed)))))
+
+(define (unbound? src sym kt kf)
+  (define tc8-iflag 4)
+  (define unbound-val 9)
+  (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+  (let-gensyms (unbound ktest)
+    (build-cps-term
+      ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+        ($letk ((ktest src ($kif kt kf)))
+          ($continue ktest
+            ($primcall 'eq? (sym unbound))))))))
+
+(define (init-default-value name sym subst init body)
+  (match (assq-ref subst sym)
+    ((subst-sym box?)
+     (let ((src (tree-il-src init)))
+       (define (maybe-box k make-body)
+         (if box?
+             (let-gensyms (kbox phi)
+               (build-cps-term
+                 ($letk ((kbox src ($kargs (name) (phi)
+                                     ($continue k ($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)))
+             ,(maybe-box
+               knext
+               (lambda (k)
+                 (build-cps-term
+                   ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
+                           (kunbound src ($kargs () () ,(convert init k subst))))
+                     ,(unbound? src sym kunbound kbound))))))))))))
+
+;; exp k-name alist -> term
+(define (convert exp k subst)
+  ;; exp (v-name -> term) -> term
+  (define (convert-arg exp k)
+    (match exp
+      (($ <lexical-ref> src name sym)
+       (match (assq-ref subst sym)
+         ((box #t)
+          (let-gensyms (kunboxed unboxed)
+            (build-cps-term
+              ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+                ($continue kunboxed ($primcall 'box-ref (box)))))))
+         ((subst #f) (k subst))
+         (#f (k sym))))
+      (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))))))))
+  ;; (exp ...) ((v-name ...) -> term) -> term
+  (define (convert-args exps k)
+    (match exps
+      (() (k '()))
+      ((exp . exps)
+       (convert-arg exp
+         (lambda (name)
+           (convert-args exps
+             (lambda (names)
+               (k (cons name names)))))))))
+  (define (box-bound-var name sym body)
+    (match (assq-ref subst sym)
+      ((box #t)
+       (let-gensyms (k)
+         (build-cps-term
+           ($letk ((k #f ($kargs (name) (box) ,body)))
+             ($continue k ($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))))))
+
+    (($ <void> src)
+     (build-cps-term ($continue k ($void))))
+
+    (($ <const> src exp)
+     (build-cps-term ($continue k ($const exp))))
+
+    (($ <primitive-ref> src name)
+     (build-cps-term ($continue k ($prim name))))
+
+    (($ <lambda> fun-src meta body)
+     (let ()
+       (define (convert-clauses body ktail)
+         (match body
+           (#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))))
+                   (names (fold-formals (lambda (name sym init names)
+                                          (cons name names))
+                                        '()
+                                        arity gensyms inits)))
+              (cons
+               (let-gensyms (kclause kargs)
+                 (build-cps-cont
+                   (kclause
+                    src
+                    ($kclause ,arity
+                      (kargs
+                       src
+                       ($kargs names gensyms
+                         ,(fold-formals
+                           (lambda (name sym init body)
+                             (if init
+                                 (init-default-value name sym subst init body)
+                                 (box-bound-var name sym body)))
+                           (convert body ktail subst)
+                           arity gensyms inits)))))))
+               (convert-clauses alternate ktail))))))
+       (if (current-topbox-scope)
+           (let-gensyms (kentry self ktail)
+             (build-cps-term
+               ($continue k
+                 ($fun meta '()
+                   (kentry fun-src
+                           ($kentry self (ktail #f ($ktail))
+                                    ,(convert-clauses body ktail)))))))
+           (let-gensyms (scope kscope)
+             (build-cps-term
+               ($letk ((kscope fun-src
+                               ($kargs () ()
+                                 ,(parameterize ((current-topbox-scope scope))
+                                    (convert exp k subst)))))
+                 ,(capture-toplevel-scope fun-src scope kscope)))))))
+
+    (($ <module-ref> src mod name public?)
+     (module-box
+      src mod name public? #t
+      (lambda (box)
+        (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+
+    (($ <module-set> src mod name public? exp)
+     (convert-arg exp
+       (lambda (val)
+         (module-box
+          src mod name public? #f
+          (lambda (box)
+            (build-cps-term ($continue k ($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)))))))
+
+    (($ <toplevel-set> src name exp)
+     (convert-arg exp
+       (lambda (val)
+         (toplevel-box
+          src name #f
+          (lambda (box)
+            (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+
+    (($ <toplevel-define> src name exp)
+     (convert-arg exp
+       (lambda (val)
+         (let-gensyms (kname name-sym)
+           (build-cps-term
+             ($letconst (('name name-sym name))
+               ($continue k ($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)))))))
+
+    (($ <primcall> src name args)
+     (case name
+       ((list)
+        (convert (fold-right (lambda (elem tail)
+                               (make-primcall src 'cons
+                                              (list elem tail)))
+                             (make-const src '())
+                             args)
+                 k subst))
+       (else
+        (if (branching-primitive? name)
+            (convert (make-conditional src exp (make-const #f #t)
+                                       (make-const #f #f))
+                     k subst)
+            (convert-args args
+              (lambda (args)
+                (if (eq? name 'values)
+                    (build-cps-term ($continue k ($values args)))
+                    (build-cps-term ($continue k ($primcall name args))))))))))
+
+    ;; Prompts with inline handlers.
+    (($ <prompt> src escape-only? tag body
+        ($ <lambda> hsrc hmeta
+           ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+     ;; Handler:
+     ;;   khargs: check args returned to handler, -> khbody
+     ;;   khbody: the handler, -> k
+     ;;
+     ;; Post-body:
+     ;;   krest: collect return vals from body to list, -> kpop
+     ;;   kpop: pop the prompt, -> kprim
+     ;;   kprim: load the values primitive, -> kret
+     ;;   kret: (apply values rvals), -> k
+     ;;
+     ;; Escape prompts evaluate the body with the continuation of krest.
+     ;; Otherwise we do a no-inline call to body, continuing to krest.
+     (convert-arg tag
+       (lambda (tag)
+         (let ((hnames (append hreq (if hrest (list hrest) '()))))
+           (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+             (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)
+                                ($letk ((kret
+                                         src
+                                         ($kargs () ()
+                                           ($letk ((kprim
+                                                    src
+                                                    ($kargs ('prim) (prim)
+                                                      ($continue k
+                                                        ($primcall 'apply
+                                                                   (prim vals))))))
+                                             ($continue kprim
+                                               ($prim 'values))))))
+                                  ($continue kret
+                                    ($primcall 'pop-prompt ())))))
+                        (krest src ($ktrunc '() 'rest kpop)))
+                 ,(if escape-only?
+                      (build-cps-term
+                        ($letk ((kbody (tree-il-src body) 
+                                       ($kargs () ()
+                                         ,(convert body krest subst))))
+                          ($continue kbody ($prompt #t tag khargs))))
+                      (convert-arg body
+                        (lambda (thunk)
+                          (build-cps-term
+                            ($letk ((kbody (tree-il-src body) 
+                                           ($kargs () ()
+                                             ($continue krest
+                                               ($primcall 'call-thunk/no-inline
+                                                          (thunk))))))
+                              ($continue kbody
+                                ($prompt #f tag khargs))))))))))))))
+
+    ;; Eta-convert prompts without inline handlers.
+    (($ <prompt> src escape-only? tag body handler)
+     (convert-args (list tag body handler)
+       (lambda (args)
+         (build-cps-term
+           ($continue k ($primcall 'call-with-prompt args))))))
+
+    (($ <abort> src tag args tail)
+     (convert-args (append (list tag) args (list tail))
+       (lambda (args*)
+         (build-cps-term ($continue k ($primcall 'abort 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)))
+           ,(match test
+              (($ <primcall> src (? branching-primitive? name) args)
+               (convert-args args
+                 (lambda (args)
+                   (build-cps-term ($continue kif ($primcall name args))))))
+              (_ (convert-arg test
+                   (lambda (test)
+                     (build-cps-term ($continue kif ($var test)))))))))))
+
+    (($ <lexical-set> src name gensym exp)
+     (convert-arg exp
+       (lambda (exp)
+         (match (assq-ref subst gensym)
+           ((box #t)
+            (build-cps-term
+              ($continue k ($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)))
+           ,(convert head ktrunc subst)))))
+
+    (($ <let> src names syms vals body)
+     (let lp ((names names) (syms syms) (vals vals))
+       (match (list names syms vals)
+         ((() () ()) (convert body k subst))
+         (((name . names) (sym . syms) (val . vals))
+          (let-gensyms (klet)
+            (build-cps-term
+              ($letk ((klet src ($kargs (name) (sym)
+                                  ,(box-bound-var name sym
+                                                  (lp names syms vals)))))
+                ,(convert val klet subst))))))))
+
+    (($ <fix> src names gensyms funs body)
+     ;; Some letrecs can be contified; that happens later.
+     (if (current-topbox-scope)
+         (let-gensyms (self)
+           (build-cps-term
+             ($letrec names
+                      gensyms
+                      (map (lambda (fun)
+                             (match (convert fun k subst)
+                               (($ $continue _ (and fun ($ $fun)))
+                                fun)))
+                           funs)
+                      ,(convert body k subst))))
+         (let-gensyms (scope kscope)
+           (build-cps-term
+             ($letk ((kscope src ($kargs () ()
+                                   ,(parameterize ((current-topbox-scope scope))
+                                      (convert exp k subst)))))
+               ,(capture-toplevel-scope src scope kscope))))))
+
+    (($ <let-values> src exp
+        ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+     (let ((names (append req (if rest (list rest) '()))))
+       (let-gensyms (ktrunc kargs)
+         (build-cps-term
+           ($letk* ((kargs src ($kargs names syms
+                                 ,(fold box-bound-var
+                                        (convert body k subst)
+                                        names syms)))
+                    (ktrunc src ($ktrunc req rest kargs)))
+             ,(convert exp ktrunc subst))))))))
+
+(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))
+
+(define (cps-convert/thunk exp)
+  (let ((src (tree-il-src exp)))
+    (let-gensyms (kinit init ktail kclause kbody)
+      (build-cps-exp
+        ($fun '() '()
+          (kinit src
+                 ($kentry init
+                   (ktail #f ($ktail))
+                   ((kclause src
+                            ($kclause ('() '() #f '() #f)
+                              (kbody src
+                                     ($kargs () ()
+                                       ,(convert exp ktail
+                                                 (build-subst exp))))))))))))))
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+  `((unused-variable     . ,unused-variable-analysis)
+    (unused-toplevel     . ,unused-toplevel-analysis)
+    (unbound-variable    . ,unbound-variable-analysis)
+    (arity-mismatch      . ,arity-analysis)
+    (format              . ,format-analysis)))
+
+(define (optimize-tree-il x e opts)
+  (define warnings
+    (or (and=> (memq #:warnings opts) cadr)
+        '()))
+
+  ;; Go through the warning passes.
+  (let ((analyses (filter-map (lambda (kind)
+                                (assoc-ref %warning-passes kind))
+                              warnings)))
+    (analyze-tree analyses x e))
+
+  (optimize x e opts))
+
+(define (compile-cps exp env opts)
+  (values (cps-convert/thunk (optimize-tree-il exp env opts))
+          env
+          env))
+
+;;; Local Variables:
+;;; eval: (put 'convert-arg 'scheme-indent-function 1)
+;;; eval: (put 'convert-args 'scheme-indent-function 1)
+;;; End:
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 80c32fe29..a574eb237 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -23,6 +23,7 @@
   #:use-module (system base pmatch)
   #:use-module (language glil)
   #:use-module (language tree-il)
+  #:use-module (language tree-il compile-cps)
   #:use-module (language tree-il compile-glil)
   #:export (tree-il))
 
@@ -43,6 +44,7 @@
   #:printer	write-tree-il
   #:parser      parse-tree-il
   #:joiner      join
-  #:compilers   `((glil . ,compile-glil))
+  #:compilers   `((glil . ,compile-glil)
+                  (cps . ,compile-cps))
   #:for-humans? #f
   )