[PATCH 8/9] Add CPS -> RTL compiler

[Andy Wingo <wingo@pobox.com>]

* module/Makefile.am:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/slot-allocation.scm: New modules.

* module/language/cps/spec.scm: Register the compiler.

* test-suite/Makefile.am:
* test-suite/tests/rtl-compilation.test: Add tests.
---
 module/Makefile.am                      |   3 +
 module/language/cps/compile-rtl.scm     | 371 +++++++++++++++++++++++++++
 module/language/cps/dfg.scm             | 432 ++++++++++++++++++++++++++++++++
 module/language/cps/slot-allocation.scm | 419 +++++++++++++++++++++++++++++++
 module/language/cps/spec.scm            |   3 +-
 test-suite/Makefile.am                  |   1 +
 test-suite/tests/rtl-compilation.test   | 200 +++++++++++++++
 7 files changed, 1428 insertions(+), 1 deletion(-)
 create mode 100644 module/language/cps/compile-rtl.scm
 create mode 100644 module/language/cps/dfg.scm
 create mode 100644 module/language/cps/slot-allocation.scm
 create mode 100644 test-suite/tests/rtl-compilation.test

diff --git a/module/Makefile.am b/module/Makefile.am
index d7e524b..5a0ff69 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -122,8 +122,11 @@ CPS_LANG_SOURCES =						\
   language/cps.scm						\
   language/cps/arities.scm					\
   language/cps/closure-conversion.scm				\
+  language/cps/compile-rtl.scm					\
+  language/cps/dfg.scm						\
   language/cps/primitives.scm					\
   language/cps/reify-primitives.scm				\
+  language/cps/slot-allocation.scm				\
   language/cps/spec.scm						\
   language/cps/verify.scm
 
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
new file mode 100644
index 0000000..9277adf
--- /dev/null
+++ b/module/language/cps/compile-rtl.scm
@@ -0,0 +1,371 @@
+;;; 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:
+;;;
+;;; Compiling CPS to RTL.  The result is in the RTL language, which
+;;; happens to be an ELF image as a bytecode.
+;;;
+;;; Code:
+
+(define-module (language cps compile-rtl)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (language cps)
+  #:use-module (language cps arities)
+  #:use-module (language cps closure-conversion)
+  #:use-module (language cps dfg)
+  #:use-module (language cps primitives)
+  #:use-module (language cps reify-primitives)
+  #:use-module (language cps slot-allocation)
+  #:use-module (system vm assembler)
+  #:export (compile-rtl))
+
+;; TODO: Source info, local var names.  Needs work in the linker and the
+;; debugger.
+
+(define (kw-arg-ref args kw default)
+  (match (memq kw args)
+    ((_ val . _) val)
+    (_ default)))
+
+(define (optimize exp opts)
+  (define (run-pass exp pass kw default)
+    (if (kw-arg-ref opts kw default)
+        (pass exp)
+        exp))
+
+  ;; Calls to source-to-source optimization passes go here.
+  (let* ()
+    ;; Passes that are needed:
+    ;; 
+    ;;  * Contification: turning $letrec-bound $funs into $letk-bound $conts.
+    ;;
+    ;;  * Abort contification: turning abort primcalls into continuation
+    ;;    calls, and eliding prompts if possible.
+    ;;
+    ;;  * Common subexpression elimination.  Desperately needed.  Requires
+    ;;    effects analysis.
+    ;;
+    ;;  * Loop peeling.  Unrolls the first round through a loop if the
+    ;;    loop has effects that CSE can work on.  Requires effects
+    ;;    analysis.  When run before CSE, loop peeling is the equivalent
+    ;;    of loop-invariant code motion (LICM).
+    ;;
+    ;;  * Generic simplification pass, to be run as needed.  Used to
+    ;;    "clean up", both on the original raw input and after specific
+    ;;    optimization passes.
+
+    exp))
+
+(define (visit-funs proc exp)
+  (match exp
+    (($ $continue _ exp)
+     (visit-funs proc exp))
+
+    (($ $fun meta free body)
+     (proc exp)
+     (visit-funs proc body))
+
+    (($ $letk conts body)
+     (visit-funs proc body)
+     (for-each (lambda (cont) (visit-funs proc cont)) conts))
+
+    (($ $cont sym src ($ $kargs names syms body))
+     (visit-funs proc body))
+
+    (($ $cont sym src ($ $kclause arity body))
+     (visit-funs proc body))
+
+    (($ $cont sym src ($ $kentry self tail clauses))
+     (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+
+    (_ (values))))
+
+(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
+  (define (slot sym)
+    (lookup-slot sym allocation))
+
+  (define (constant sym)
+    (lookup-constant-value sym allocation))
+
+  (define (emit-rtl label k exp next-label)
+    (define (maybe-mov dst src)
+      (unless (= dst src)
+        (emit-mov asm dst src)))
+
+    (define (maybe-jump label)
+      (unless (eq? label next-label)
+        (emit-br asm label)))
+
+    (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 (emit-tail)
+      ;; 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 (emit-val sym)
+      (let ((dst (slot sym)))
+        (match exp
+          (($ $var sym)
+           (maybe-mov dst (slot sym)))
+          (($ $void)
+           (when dst
+             (emit-load-constant asm dst *unspecified*)))
+          (($ $const exp)
+           (when dst
+             (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 name args)
+           ;; FIXME: Inline all the cases.
+           (let ((inst (prim-rtl-instruction name)))
+             (emit-text asm `((,inst ,dst ,@(map slot args))))))
+          (($ $values (arg))
+           (or (maybe-load-constant dst arg)
+               (maybe-mov dst (slot arg))))
+          (($ $prompt escape? tag handler)
+           (emit-prompt asm escape? tag handler)))
+        (maybe-jump k)))
+
+    (define (emit-vals syms)
+      (match exp
+        (($ $primcall name args)
+         (error "unimplemented primcall in values context" name))
+        (($ $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)))
+      (maybe-jump k))
+
+    (define (emit-seq)
+      (match exp
+        (($ $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))
+         (emit-vector-set asm (slot vector) (slot index) (slot value)))
+        (($ $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 name args)
+         (error "unhandled primcall in seq context" name))
+        (($ $values ()) #f))
+      (maybe-jump k))
+
+    (define (emit-test kt kf)
+      (define (unary op sym)
+        (cond
+         ((eq? kt next-label)
+          (op asm (slot sym) #t kf))
+         (else
+          (op asm (slot sym) #f kt)
+          (maybe-jump 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)
+          (maybe-jump 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))
+        ;; Add TC7 tests here
+        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+        (($ $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 (emit-trunc nreq rest? k)
+      (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))
+                (emit-receive-values asm proc-slot 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)))))))
+      (maybe-jump k))
+
+    (match (lookup-cont k cont-table)
+      (($ $ktail) (emit-tail))
+      (($ $kargs (name) (sym)) (emit-val sym))
+      (($ $kargs () ()) (emit-seq))
+      (($ $kargs names syms) (emit-vals syms))
+      (($ $kargs (name) (sym)) (emit-val sym))
+      (($ $kif kt kf) (emit-test kt kf))
+      (($ $ktrunc ($ $arity req () rest () #f) k)
+       (emit-trunc (length req) (and rest #t) k))))
+
+  (define (collect-exps k src cont tail)
+    (define (find-exp k src term)
+      (match term
+        (($ $continue exp-k exp)
+         (cons (list k src exp-k exp) tail))
+        (($ $letk conts body)
+         (find-exp k src body))))
+    (match cont
+      (($ $kargs names syms body)
+       (find-exp k src body))
+      (_ tail)))
+
+  (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
+    (match exps
+      (() #t)
+      (((k src exp-k exp) . exps)
+       (let ((next-label (match exps
+                           (((k . _) . _) k)
+                           (() #f))))
+         (emit-label asm k)
+         (emit-rtl k exp-k exp next-label)
+         (lp exps))))))
+
+(define (compile-fun f asm)
+  (let ((allocation (allocate-slots f))
+        (cont-table (match f
+                      (($ $fun meta free body)
+                       (build-local-cont-table body)))))
+    (define (emit-fun-clause clause alternate)
+      (match clause
+        (($ $cont k src
+            ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+               body))
+         (let ((kw-indices (map (match-lambda
+                                 ((key name sym)
+                                  (cons key (lookup-slot sym allocation))))
+                                kw))
+               (nlocals (lookup-nlocals k allocation)))
+           (emit-label asm k)
+           (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+                                nlocals alternate)
+           (emit-rtl-sequence asm body allocation nlocals cont-table)
+           (emit-end-arity asm)))))
+
+    (define (emit-fun-clauses clauses)
+      (match clauses
+        ((clause . clauses)
+         (let ((kalternate (match clauses
+                             (() #f)
+                             ((($ $cont k) . _) k))))
+           (emit-fun-clause clause kalternate)
+           (when kalternate
+             (emit-fun-clauses clauses))))))
+
+    (match f
+      (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
+       (emit-begin-program asm k (or meta '()))
+       (emit-fun-clauses clauses)
+       (emit-end-program asm)))))
+
+(define (compile-rtl exp env opts)
+  (let* ((exp (fix-arities exp))
+         (exp (optimize exp opts))
+         (exp (convert-closures exp))
+         (exp (reify-primitives exp))
+         (asm (make-assembler)))
+    (visit-funs (lambda (fun)
+                  (compile-fun fun asm))
+                exp)
+    (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+            env
+            env)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
new file mode 100644
index 0000000..0826451
--- /dev/null
+++ b/module/language/cps/dfg.scm
@@ -0,0 +1,432 @@
+;;; 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:
+;;;
+;;; Many passes rely on a local or global static analysis of a function.
+;;; This module implements a simple data-flow graph (DFG) analysis,
+;;; tracking the definitions and uses of variables and continuations.
+;;; It also builds a table of continuations and parent links, to be able
+;;; to easily determine if one continuation is in the scope of another,
+;;; and to get to the expression inside a continuation.
+;;;
+;;; Note that the data-flow graph of continuation labels is a
+;;; control-flow graph.
+;;;
+;;; We currently don't expose details of the DFG type outside this
+;;; module, preferring to only expose accessors.  That may change in the
+;;; future but it seems to work for now.
+;;;
+;;; Code:
+
+(define-module (language cps dfg)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (language cps)
+  #:export (build-cont-table
+            build-local-cont-table
+            lookup-cont
+
+            compute-dfg
+            dfg-cont-table
+            lookup-def
+            lookup-uses
+            find-call
+            call-expression
+            find-expression
+            find-defining-expression
+            find-constant-value
+            lift-definition!
+            variable-used-in?
+            constant-needs-allocation?
+            dead-after-def?
+            dead-after-use?
+            branch?
+            find-other-branches
+            dead-after-branch?
+            lookup-bound-syms))
+
+(define (build-cont-table fun)
+  (fold-conts (lambda (k src 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)
+                      (hashq-set! table k cont)
+                      table)
+                    (make-hash-table)
+                    cont))
+
+(define (lookup-cont sym conts)
+  (let ((res (hashq-ref conts sym)))
+    (unless res
+      (error "Unknown continuation!" sym (hash-fold acons '() conts)))
+    res))
+
+;; Data-flow graph for CPS: both for values and continuations.
+(define-record-type $dfg
+  (make-dfg conts use-maps uplinks)
+  dfg?
+  ;; hash table of sym -> $kargs, $kif, etc
+  (conts dfg-cont-table)
+  ;; hash table of sym -> $use-map
+  (use-maps dfg-use-maps)
+  ;; hash table of sym -> $parent-link
+  (uplinks dfg-uplinks))
+
+(define-record-type $use-map
+  (make-use-map sym def uses)
+  use-map?
+  (sym use-map-sym)
+  (def use-map-def)
+  (uses use-map-uses set-use-map-uses!))
+
+(define-record-type $uplink
+  (make-uplink parent level)
+  uplink?
+  (parent uplink-parent)
+  (level uplink-level))
+
+(define (visit-fun fun conts use-maps uplinks global?)
+  (define (add-def! sym def-k)
+    (unless def-k
+      (error "Term outside labelled continuation?"))
+    (hashq-set! use-maps sym (make-use-map sym def-k '())))
+
+  (define (add-use! sym use-k)
+    (match (hashq-ref use-maps sym)
+      (#f (error "Symbol out of scope?" sym))
+      ((and use-map ($ $use-map sym def uses))
+       (set-use-map-uses! use-map (cons use-k uses)))))
+
+  (define (link-parent! k parent)
+    (match (hashq-ref uplinks parent)
+      (($ $uplink _ level)
+       (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+
+  (define (visit exp exp-k)
+    (define (def! sym)
+      (add-def! sym exp-k))
+    (define (use! sym)
+      (add-use! sym exp-k))
+    (define (recur exp)
+      (visit exp exp-k))
+    (match exp
+      (($ $letk (($ $cont k src cont) ...) body)
+       ;; Set up recursive environment before visiting cont bodies.
+       (for-each (lambda (cont k)
+                   (def! k)
+                   (hashq-set! conts k cont)
+                   (link-parent! k exp-k))
+                 cont k)
+       (for-each visit cont k)
+       (recur body))
+
+      (($ $kargs names syms body)
+       (for-each def! syms)
+       (recur body))
+
+      (($ $kif kt kf)
+       (use! kt)
+       (use! kf))
+
+      (($ $ktrunc arity k)
+       (use! k))
+
+      (($ $letrec names syms funs body)
+       (unless global?
+         (error "$letrec should not be present when building a local DFG"))
+       (for-each def! syms)
+       (for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
+       (visit body exp-k))
+
+      (($ $continue k exp)
+       (use! k)
+       (match exp
+         (($ $var sym)
+          (use! sym))
+
+         (($ $call proc args)
+          (use! proc)
+          (for-each use! args))
+
+         (($ $primcall name args)
+          (for-each use! args))
+
+         (($ $values args)
+          (for-each use! args))
+
+         (($ $prompt escape? tag handler)
+          (use! tag)
+          (use! handler))
+
+         (($ $fun)
+          (when global?
+            (visit-fun exp conts use-maps uplinks global?)))
+
+         (_ #f)))))
+
+  (match fun
+    (($ $fun meta free
+        ($ $cont kentry src
+           (and entry
+                ($ $kentry self ($ $cont ktail _ tail) clauses))))
+     ;; Treat the fun continuation as its own parent.
+     (add-def! kentry kentry)
+     (add-def! self kentry)
+     (hashq-set! uplinks kentry (make-uplink #f 0))
+     (hashq-set! conts kentry entry)
+
+     (add-def! ktail kentry)
+     (hashq-set! conts ktail tail)
+     (link-parent! ktail kentry)
+
+     (for-each
+      (match-lambda
+       (($ $cont kclause _
+           (and clause ($ $kclause arity ($ $cont kbody _ body))))
+        (add-def! kclause kentry)
+        (hashq-set! conts kclause clause)
+        (link-parent! kclause kentry)
+
+        (add-def! kbody kclause)
+        (hashq-set! conts kbody body)
+        (link-parent! kbody kclause)
+
+        (visit body kbody)))
+      clauses))))
+
+(define* (compute-dfg fun #:key (global? #t))
+  (let* ((conts (make-hash-table))
+         (use-maps (make-hash-table))
+         (uplinks (make-hash-table)))
+    (visit-fun fun conts use-maps uplinks global?)
+    (make-dfg conts use-maps uplinks)))
+
+(define (lookup-uplink k uplinks)
+  (let ((res (hashq-ref uplinks k)))
+    (unless res
+      (error "Unknown continuation!" k (hash-fold acons '() uplinks)))
+    res))
+
+(define (lookup-use-map sym use-maps)
+  (let ((res (hashq-ref use-maps sym)))
+    (unless res
+      (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
+    res))
+
+(define (lookup-def sym dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map sym def uses)
+        def)))))
+
+(define (lookup-uses sym dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map sym def uses)
+        uses)))))
+
+(define (find-defining-term sym dfg)
+  (match (lookup-uses (lookup-def sym dfg) dfg)
+    ((def-exp-k)
+     (lookup-cont def-exp-k (dfg-cont-table dfg)))
+    (else #f)))
+
+(define (find-call term)
+  (match term
+    (($ $kargs names syms body) (find-call body))
+    (($ $letk conts body) (find-call body))
+    (($ $letrec names syms funs body) (find-call body))
+    (($ $continue) term)))
+
+(define (call-expression call)
+  (match call
+    (($ $continue k exp) exp)))
+
+(define (find-expression term)
+  (call-expression (find-call term)))
+
+(define (find-defining-expression sym dfg)
+  (match (find-defining-term sym dfg)
+    (#f #f)
+    (($ $ktrunc) #f)
+    (term (find-expression term))))
+
+(define (find-constant-value sym dfg)
+  (match (find-defining-expression sym dfg)
+    (($ $const val)
+     (values #t val))
+    (($ $continue k ($ $void))
+     (values #t *unspecified*))
+    (else
+     (values #f #f))))
+
+(define (constant-needs-allocation? sym val dfg)
+  (define (find-exp term)
+    (match term
+      (($ $kargs names syms body) (find-exp body))
+      (($ $letk conts body) (find-exp body))
+      (else term)))
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map _ def uses)
+        (or-map
+         (lambda (use)
+           (match (find-expression (lookup-cont use conts))
+             (($ $call) #f)
+             (($ $values) #f)
+             (($ $primcall 'free-ref (closure slot))
+              (not (eq? sym slot)))
+             (($ $primcall 'free-set! (closure slot value))
+              (not (eq? sym slot)))
+             (($ $primcall 'cache-current-module! (mod . _))
+              (eq? sym mod))
+             (($ $primcall 'cached-toplevel-box _)
+              #f)
+             (($ $primcall 'cached-module-box _)
+              #f)
+             (($ $primcall 'resolve (name bound?))
+              (eq? sym name))
+             (_ #t)))
+         uses))))))
+
+(define (continuation-scope-contains? parent-k k uplinks)
+  (match (lookup-uplink parent-k uplinks)
+    (($ $uplink _ parent-level)
+     (let lp ((k k))
+       (or (eq? parent-k k)
+           (match (lookup-uplink k uplinks)
+             (($ $uplink parent level)
+              (and (< parent-level level)
+                   (lp parent)))))))))
+
+(define (lift-definition! k parent-k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-uplink parent-k uplinks)
+       (($ $uplink parent level)
+        (hashq-set! uplinks k
+                    (make-uplink parent-k (1+ level)))
+        ;; Lift definitions of all conts in K.
+        (let lp ((cont (lookup-cont k conts)))
+          (match cont
+            (($ $letk (($ $cont kid) ...) body)
+             (for-each (cut lift-definition! <> k dfg) kid)
+             (lp body))
+            (($ $letrec names syms funs body)
+             (lp body))
+            (_ #t))))))))
+
+(define (variable-used-in? var parent-k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (or-map (lambda (use)
+               (continuation-scope-contains? parent-k use uplinks))
+             (match (lookup-use-map var use-maps)
+               (($ $use-map sym def uses)
+                uses))))))
+
+;; Does k1 dominate k2?
+;;
+;; Note that this is a conservative predicate: a false return value does
+;; not indicate that k1 _doesn't_ dominate k2.  The reason for this is
+;; that we are using the scope tree as an approximation of the dominator
+;; relationship.  See
+;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
+;; deeper discussion.
+(define (conservatively-dominates? k1 k2 uplinks)
+  (continuation-scope-contains? k1 k2 uplinks))
+
+(define (dead-after-def? sym dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map sym def uses)
+        (null? uses))))))
+
+(define (dead-after-use? sym use-k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map sym def uses)
+        ;; If all other uses dominate this use, it is now dead.  There
+        ;; are other ways for it to be dead, but this is an
+        ;; approximation.  A better check would be if the successor
+        ;; post-dominates all uses.
+        (and-map (cut conservatively-dominates? <> use-k uplinks)
+                 uses))))))
+
+;; A continuation is a "branch" if all of its predecessors are $kif
+;; continuations.
+(define (branch? k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map k use-maps)
+       (($ $use-map sym def uses)
+        (and (not (null? uses))
+             (and-map (lambda (k)
+                        (match (lookup-cont k conts)
+                          (($ $kif) #t)
+                          (_ #f)))
+                      uses)))))))
+
+(define (find-other-branches k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map k use-maps)
+       (($ $use-map sym def (uses ..1))
+        (map (lambda (kif)
+               (match (lookup-cont kif conts)
+                 (($ $kif (? (cut eq? <> k)) kf)
+                  kf)
+                 (($ $kif kt (? (cut eq? <> k)))
+                  kt)
+                 (_ (error "Not all predecessors are branches"))))
+             uses))))))
+
+(define (dead-after-branch? sym branch other-branches dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map sym use-maps)
+       (($ $use-map sym def uses)
+        (and-map
+         (lambda (use-k)
+           ;; A symbol is dead after a branch if at least one of the
+           ;; other branches dominates a use of the symbol, and all
+           ;; other uses of the symbol dominate the test.
+           (if (or-map (cut conservatively-dominates? <> use-k uplinks)
+                       other-branches)
+               (not (conservatively-dominates? branch use-k uplinks))
+               (conservatively-dominates? use-k branch uplinks)))
+         uses))))))
+
+(define (lookup-bound-syms k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-cont k conts)
+       (($ $kargs names syms body)
+        syms)))))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
new file mode 100644
index 0000000..a7b9f74
--- /dev/null
+++ b/module/language/cps/slot-allocation.scm
@@ -0,0 +1,419 @@
+;;; 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:
+;;;
+;;; A module to assign stack slots to variables in a CPS term.
+;;;
+;;; Code:
+
+(define-module (language cps slot-allocation)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (language cps)
+  #:use-module (language cps dfg)
+  #:export (allocate-slots
+            lookup-slot
+            lookup-constant-value
+            lookup-maybe-constant-value
+            lookup-nlocals
+            lookup-call-proc-slot
+            lookup-parallel-moves))
+
+;; Continuations can bind variables.  The $allocation structure
+;; represents the slot in which a variable is stored.
+;;
+;; Not all variables have slots allocated.  Variables that are constant
+;; and that are only used by primcalls that can accept constants
+;; directly are not allocated to slots, and their SLOT value is false.
+;; Likewise constants that are only used by calls are not allocated into
+;; slots, to avoid needless copying.  If a variable is constant, its
+;; constant value is set to the CONST slot and HAS-CONST? is set to a
+;; true value.
+;;
+;; DEF holds the label of the continuation that defines the variable,
+;; and DEAD is a list of continuations at which the variable becomes
+;; dead.
+(define-record-type $allocation
+  (make-allocation def slot dead has-const? const)
+  allocation?
+  (def allocation-def)
+  (slot allocation-slot)
+  (dead allocation-dead set-allocation-dead!)
+  (has-const? allocation-has-const?)
+  (const allocation-const))
+
+;; Continuations can also have associated allocation data.  For example,
+;; when a call happens in a labelled continuation, we need to know what
+;; slot the procedure goes in.  Likewise before branching to the target
+;; continuation, we might need to shuffle values into the right place: a
+;; parallel move.  $cont-allocation stores allocation data keyed on the
+;; continuation label.
+(define-record-type $cont-allocation
+  (make-cont-allocation call-proc-slot parallel-moves)
+  cont-allocation?
+
+  ;; Currently calls are allocated in the caller frame, above all locals
+  ;; that are live at the time of the call.  Therefore there is no
+  ;; parallel move problem.  We could be more clever here.
+  (call-proc-slot cont-call-proc-slot)
+
+  ;; Tail calls, multiple-value returns, and jumps to continuations with
+  ;; multiple arguments are forms of parallel assignment.  A
+  ;; $parallel-move represents a specific solution to the parallel
+  ;; assignment problem, with an ordered list of (SRC . DST) moves.  This
+  ;; may involve a temporary variable.
+  ;;
+  ;; ((src . dst) ...)
+  (parallel-moves cont-parallel-moves))
+
+(define (find-first-zero n)
+  ;; Naive implementation.
+  (let lp ((slot 0))
+    (if (logbit? slot n)
+        (lp (1+ slot))
+        slot)))
+
+(define (find-first-trailing-zero n count)
+  (let lp ((slot count))
+    (if (or (zero? slot) (logbit? (1- slot) n))
+        slot
+        (lp (1- slot)))))
+
+(define (lookup-allocation sym allocation)
+  (let ((res (hashq-ref allocation sym)))
+    (unless res
+      (error "Variable or continuation not defined" sym))
+    res))
+
+(define (lookup-slot sym allocation)
+  (match (lookup-allocation sym allocation)
+    (($ $allocation def slot dead has-const? const) slot)))
+
+(define (lookup-constant-value sym allocation)
+  (match (lookup-allocation sym allocation)
+    (($ $allocation def slot dead #t const) const)
+    (_
+     (error "Variable does not have constant value" sym))))
+
+(define (lookup-maybe-constant-value sym allocation)
+  (match (lookup-allocation sym allocation)
+    (($ $allocation def slot dead has-const? const)
+     (values has-const? const))))
+
+(define (lookup-call-proc-slot k allocation)
+  (match (lookup-allocation k allocation)
+    (($ $cont-allocation proc-slot parallel-moves)
+     (unless proc-slot
+       (error "Continuation not a call" k))
+     proc-slot)
+    (_
+     (error "Continuation not a call" k))))
+
+(define (lookup-nlocals k allocation)
+  (match (lookup-allocation k allocation)
+    ((? number? nlocals) nlocals)
+    (_
+     (error "Not a clause continuation" k))))
+
+(define (lookup-parallel-moves k allocation)
+  (match (lookup-allocation k allocation)
+    (($ $cont-allocation proc-slot parallel-moves)
+     (unless parallel-moves
+       (error "Continuation does not have parallel moves" k))
+     parallel-moves)
+    (_
+     (error "Continuation not a call" k))))
+
+(define (solve-parallel-move src dst tmp)
+  "Solve the parallel move problem between src and dst slot lists, which
+are comparable with eqv?.  A tmp slot may be used."
+
+  ;; This algorithm is taken from: "Tilting at windmills with Coq:
+  ;; formal verification of a compilation algorithm for parallel moves"
+  ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
+  ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
+
+  (define (split-move moves reg)
+    (let loop ((revhead '()) (tail moves))
+      (match tail
+        (((and s+d (s . d)) . rest)
+         (if (eqv? s reg)
+             (cons d (append-reverse revhead rest))
+             (loop (cons s+d revhead) rest)))
+        (_ #f))))
+
+  (define (replace-last-source reg moves)
+    (match moves
+      ((moves ... (s . d))
+       (append moves (list (cons reg d))))))
+
+  (let loop ((to-move (map cons src dst))
+             (being-moved '())
+             (moved '())
+             (last-source #f))
+    ;; 'last-source' should always be equivalent to:
+    ;; (and (pair? being-moved) (car (last being-moved)))
+    (match being-moved
+      (() (match to-move
+            (() (reverse moved))
+            (((and s+d (s . d)) . t1)
+             (if (or (eqv? s d) ; idempotent
+                     (not s))   ; src is a constant and can be loaded directly
+                 (loop t1 '() moved #f)
+                 (loop t1 (list s+d) moved s)))))
+      (((and s+d (s . d)) . b)
+       (match (split-move to-move d)
+         ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
+         (#f (match b
+               (() (loop to-move '() (cons s+d moved) #f))
+               (_ (if (eqv? d last-source)
+                      (loop to-move
+                            (replace-last-source tmp b)
+                            (cons s+d (acons d tmp moved))
+                            tmp)
+                      (loop to-move b (cons s+d moved) last-source))))))))))
+
+(define (allocate-slots fun)
+  (define (empty-live-set)
+    (cons #b0 '()))
+
+  (define (add-live-variable sym slot live-set)
+    (cons (logior (car live-set) (ash 1 slot))
+          (acons sym slot (cdr live-set))))
+
+  (define (remove-live-variable sym slot live-set)
+    (cons (logand (car live-set) (lognot (ash 1 slot)))
+          (acons sym #f (cdr live-set))))
+
+  (define (fold-live-set proc seed live-set)
+    (let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed))
+      (if (zero? bits)
+          seed
+          (match clauses
+            (((sym . slot) . clauses)
+             (if (and slot (logbit? slot bits))
+                 (lp (logand bits (lognot (ash 1 slot)))
+                     clauses
+                     (proc sym slot seed))
+                 (lp bits clauses seed)))))))
+
+  (define (compute-slot live-set hint)
+    (if (and hint (not (logbit? hint (car live-set))))
+        hint
+        (find-first-zero (car live-set))))
+
+  (define (compute-call-proc-slot live-set nlocals)
+    (+ 3 (find-first-trailing-zero (car live-set) nlocals)))
+
+  (define dfg (compute-dfg fun #:global? #f))
+  (define allocation (make-hash-table))
+             
+  (define (visit-clause clause live-set)
+    (define nlocals (compute-slot live-set #f))
+    (define nargs
+      (match clause
+        (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+         (length syms))))
+
+    (define (allocate! sym k hint live-set)
+      (match (hashq-ref allocation sym)
+        (($ $allocation def slot dead has-const)
+         ;; Parallel move already allocated this one.
+         (if slot
+             (add-live-variable sym slot live-set)
+             live-set))
+        (_
+         (call-with-values (lambda () (find-constant-value sym dfg))
+           (lambda (has-const? const)
+             (cond
+              ((and has-const? (not (constant-needs-allocation? sym const dfg)))
+               (hashq-set! allocation sym
+                           (make-allocation k #f '() has-const? const))
+               live-set)
+              (else
+               (let ((slot (compute-slot live-set hint)))
+                 (when (>= slot nlocals)
+                   (set! nlocals (+ slot 1)))
+                 (hashq-set! allocation sym
+                             (make-allocation k slot '() has-const? const))
+                 (add-live-variable sym slot live-set)))))))))
+
+    (define (dead sym k live-set)
+      (match (lookup-allocation sym allocation)
+        ((and allocation ($ $allocation def slot dead has-const? const))
+         (set-allocation-dead! allocation (cons k dead))
+         (remove-live-variable sym slot live-set))))
+
+    (define (allocate-frame! k nargs live-set)
+      (let ((proc-slot (compute-call-proc-slot live-set nlocals)))
+        (set! nlocals (max nlocals (+ proc-slot 1 nargs)))
+        (hashq-set! allocation k
+                    (make-cont-allocation
+                     proc-slot
+                     (match (hashq-ref allocation k)
+                       (($ $cont-allocation #f moves) moves)
+                       (#f #f))))
+        live-set))
+
+    (define (parallel-move! src-k src-slots pre-live-set post-live-set dst-slots)
+      (let* ((tmp-slot (find-first-zero (logior (car pre-live-set)
+                                                (car post-live-set))))
+             (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
+        (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
+          (set! nlocals (+ tmp-slot 1)))
+        (hashq-set! allocation src-k
+                    (make-cont-allocation
+                     (match (hashq-ref allocation src-k)
+                       (($ $cont-allocation proc-slot #f) proc-slot)
+                       (#f #f))
+                     moves))
+        post-live-set))
+
+    (define (visit-cont cont label live-set)
+      (define (maybe-kill-definition sym live-set)
+        (if (and (lookup-slot sym allocation) (dead-after-def? sym dfg))
+            (dead sym label live-set)
+            live-set))
+
+      (define (kill-conditionally-dead live-set)
+        (if (branch? label dfg)
+            (let ((branches (find-other-branches label dfg)))
+              (fold-live-set
+               (lambda (sym slot live-set)
+                 (if (and (> slot nargs)
+                          (dead-after-branch? sym label branches dfg))
+                     (dead sym label live-set)
+                     live-set))
+               live-set
+               live-set))
+            live-set))
+
+      (match cont
+        (($ $kentry self tail clauses)
+         (let ((live-set (allocate! self label 0 live-set)))
+           (for-each (cut visit-cont <> label live-set) clauses))
+         live-set)
+
+        (($ $kclause arity ($ $cont k src body))
+         (visit-cont body k live-set))
+
+        (($ $kargs names syms body)
+         (visit-term body label
+                     (kill-conditionally-dead
+                      (fold maybe-kill-definition
+                            (fold (cut allocate! <> label #f <>) live-set syms)
+                            syms))))
+
+        (($ $ktrunc) live-set)
+        (($ $kif) live-set)))
+
+    (define (visit-term term label live-set)
+      (match term
+        (($ $letk conts body)
+         (let ((live-set (visit-term body label live-set)))
+           (for-each (match-lambda
+                      (($ $cont k src cont)
+                       (visit-cont cont k live-set)))
+                     conts))
+         live-set)
+
+        (($ $continue k exp)
+         (visit-exp exp label k live-set))))
+
+    (define (visit-exp exp label k live-set)
+      (define (use sym live-set)
+        (if (and (lookup-slot sym allocation) (dead-after-use? sym k dfg))
+            (dead sym k live-set)
+            live-set))
+
+      (match exp
+        (($ $var sym)
+         (use sym live-set))
+
+        (($ $call proc args)
+         (match (lookup-cont k (dfg-cont-table dfg))
+           (($ $ktail)
+            (let ((tail-nlocals (1+ (length args))))
+              (set! nlocals (max nlocals tail-nlocals))
+              (parallel-move! label
+                              (map (cut lookup-slot <> allocation)
+                                   (cons proc args))
+                              live-set (fold use live-set (cons proc args))
+                              (iota tail-nlocals))))
+           (($ $ktrunc arity kargs)
+            (let* ((live-set
+                    (fold use
+                          (use proc
+                               (allocate-frame! label (length args) live-set))
+                          args))
+                   (proc-slot (lookup-call-proc-slot label allocation))
+                   (dst-syms (lookup-bound-syms kargs dfg))
+                   (nvals (length dst-syms))
+                   (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
+                   (live-set* (fold (cut allocate! <> kargs <> <>)
+                                    live-set dst-syms src-slots))
+                   (dst-slots (map (cut lookup-slot <> allocation)
+                                   dst-syms)))
+              (parallel-move! label src-slots live-set live-set* dst-slots)))
+           (else
+            (fold use
+                  (use proc (allocate-frame! label (length args) live-set))
+                  args))))
+
+        (($ $primcall name args)
+         (fold use live-set args))
+
+        (($ $values args)
+         (let ((live-set* (fold use live-set args)))
+           (define (compute-dst-slots)
+             (match (lookup-cont k (dfg-cont-table dfg))
+               (($ $ktail)
+                (let ((tail-nlocals (1+ (length args))))
+                  (set! nlocals (max nlocals tail-nlocals))
+                  (cdr (iota tail-nlocals))))
+               (_
+                (let* ((src-slots (map (cut lookup-slot <> allocation) args))
+                       (dst-syms (lookup-bound-syms k dfg))
+                       (dst-live-set (fold (cut allocate! <> k <> <>)
+                                           live-set* dst-syms src-slots)))
+                  (map (cut lookup-slot <> allocation) dst-syms)))))
+
+           (parallel-move! label
+                           (map (cut lookup-slot <> allocation) args)
+                           live-set live-set*
+                           (compute-dst-slots))))
+
+        (($ $prompt escape? tag handler)
+         (use tag live-set))
+
+        (_ live-set)))
+
+    (match clause
+      (($ $cont k _ body)
+       (visit-cont body k live-set)
+       (hashq-set! allocation k nlocals))))
+
+  (match fun
+    (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
+     (let ((live-set (add-live-variable self 0 (empty-live-set))))
+       (hashq-set! allocation self (make-allocation k 0 '() #f #f))
+       (for-each (cut visit-clause <> live-set) clauses)
+       allocation))))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
index 38dc54d..493b547 100644
--- a/module/language/cps/spec.scm
+++ b/module/language/cps/spec.scm
@@ -21,6 +21,7 @@
 (define-module (language cps spec)
   #:use-module (system base language)
   #:use-module (language cps)
+  #:use-module (language cps compile-rtl)
   #:export (cps))
 
 (define* (write-cps exp #:optional (port (current-output-port)))
@@ -31,6 +32,6 @@
   #:reader	(lambda (port env) (read port))
   #:printer	write-cps
   #:parser      parse-cps
-  #:compilers   '()
+  #:compilers   `((rtl . ,compile-rtl))
   #:for-humans? #f
   )
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index fad64b7..c4e4d1f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,6 +115,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/receive.test			\
 	    tests/regexp.test			\
 	    tests/rtl.test			\
+	    tests/rtl-compilation.test		\
 	    tests/session.test			\
 	    tests/signals.test			\
 	    tests/srcprop.test			\
diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test
new file mode 100644
index 0000000..cf00a4f
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,200 @@
+;;;; rtl-compilation.test --- test suite for compiling via rtl   -*- scheme -*-
+;;;;
+;;;; 	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
+
+(define-module (test-suite rtl-compilation)
+  #:use-module (test-suite lib)
+  #:use-module (system base compile)
+  #:use-module (system vm objcode))
+
+(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
+  (load-thunk-from-memory
+   (compile exp #:env env #:to 'rtl
+            #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-rtl exp #:key (env (make-fresh-user-module)))
+  (let ((thunk (compile-via-rtl exp #:env env)))
+    (save-module-excursion
+     (lambda ()
+       (set-current-module env)
+       (thunk)))))
+
+(with-test-prefix "tail context"
+  (pass-if-equal 1
+      (run-rtl '(let ((x 1)) x)))
+
+  (pass-if-equal 1
+      (run-rtl 1))
+
+  (pass-if-equal (if #f #f)
+      (run-rtl '(if #f #f)))
+
+  (pass-if-equal "top-level define"
+      (list (if #f #f) 1)
+    (let ((mod (make-fresh-user-module)))
+      (let ((result (run-rtl '(define v 1) #:env mod)))
+        (list result (module-ref mod 'v)))))
+
+  (pass-if-equal "top-level set!"
+      (list (if #f #f) 1)
+    (let ((mod (make-fresh-user-module)))
+      (module-define! mod 'v #f)
+      (let ((result (run-rtl '(set! v 1) #:env mod)))
+        (list result (module-ref mod 'v)))))
+
+  (pass-if-equal "top-level apply [single value]"
+      8
+    (let ((mod (make-fresh-user-module)))
+      (module-define! mod 'args '(2 3))
+      (run-rtl '(apply expt args) #:env mod)))
+
+  (pass-if-equal "top-level apply [zero values]"
+      '()
+    (let ((mod (make-fresh-user-module)))
+      (module-define! mod 'proc (lambda () (values)))
+      (module-define! mod 'args '())
+      (call-with-values
+          (lambda () (run-rtl '(apply proc args) #:env mod))
+        list)))
+
+  (pass-if-equal "top-level apply [two values]"
+      '(1 2)
+    (let ((mod (make-fresh-user-module)))
+      (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+      (module-define! mod 'args '(5 3))
+      (call-with-values
+          (lambda () (run-rtl '(apply proc args) #:env mod))
+        list)))
+
+  (pass-if-equal "call-with-values"
+      '(1 2 3)
+    ((run-rtl '(lambda (n d)
+                 (call-with-values (lambda () (floor/ n d))
+                   (lambda (q r) (list q r (+ q r))))))
+     5 3))
+
+  (pass-if-equal cons
+      (run-rtl 'cons))
+
+  (pass-if-equal 1
+      ((run-rtl '(lambda () 1))))
+
+  (pass-if-equal 1
+      ((run-rtl '(lambda (x) 1)) 2))
+
+  (pass-if-equal 1
+      ((run-rtl '(lambda (x) x)) 1))
+
+  (pass-if-equal 6
+      ((((run-rtl '(lambda (x)
+                     (lambda (y)
+                       (lambda (z)
+                         (+ x y z))))) 1) 2) 3))
+
+  (pass-if-equal 1
+      (run-rtl '(identity 1)))
+
+  (pass-if-equal '(1 . 2)
+      (run-rtl '(cons 1 2)))
+
+  (pass-if-equal '(1 2)
+      (call-with-values (lambda () (run-rtl '(values 1 2))) list))
+
+  (pass-if-equal 28
+      ((run-rtl '(lambda (x y z rest) (apply + x y z rest)))
+       2 3 5 '(7 11)))
+
+  ;; prompts
+  )
+
+(with-test-prefix "value context"
+  1
+  )
+
+(with-test-prefix "drop context"
+  1
+  )
+
+(with-test-prefix "test context"
+  1
+  )
+
+(with-test-prefix "values context"
+  (pass-if-equal '(3 . 1)
+      (run-rtl
+       '(let ((rat (lambda (n d)
+                     (call-with-values
+                         (lambda () (floor/ n d))
+                       (lambda (q r)
+                         (cons q r))))))
+          (rat 10 3)))))
+
+(with-test-prefix "contification"
+  (pass-if ((run-rtl '(lambda (x)
+                        (define (even? x)
+                          (if (null? x) #t (odd? (cdr x))))
+                        (define (odd? x)
+                          (if (null? x) #f (even? (cdr x))))
+                        (even? x)))
+            '(1 2 3 4)))
+
+  (pass-if (not ((run-rtl '(lambda (x)
+                             (define (even? x)
+                               (if (null? x) #t (odd? (cdr x))))
+                             (define (odd? x)
+                               (if (null? x) #f (even? (cdr x))))
+                             (even? x)))
+                 '(1 2 3)))))
+
+(with-test-prefix "case-lambda"
+  (pass-if-equal "simple"
+      '(0 3 9 28)
+    (let ((proc (run-rtl '(case-lambda
+                            (() 0)
+                            ((x) x)
+                            ((x y) (+ x y))
+                            ((x y z . rest) (apply + x y z rest))))))
+      (map (lambda (args) (apply proc args))
+           '(() (3) (2 7) (2 3 5 7 11)))))
+
+  (pass-if-exception "no match"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y))))
+     1 2 3))
+
+  (pass-if-exception "zero clauses called with no args"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda))))
+
+  (pass-if-exception "zero clauses called with args"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+  (pass-if-equal "sequences" '(3 4 5)
+    (let* ((pair (cons 1 2))
+           (result ((run-rtl '(lambda (pair)
+                                (set-car! pair 3)
+                                (set-cdr! pair 4)
+                                5))
+                    pair)))
+      (list (car pair)
+            (cdr pair)
+            result)))
+
+  (pass-if-equal "mutable lexicals" 2
+    (run-rtl '(let ((n 1)) (set! n 2) n))))
-- 
1.8.3.2