From d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 1 Nov 2013 14:37:57 +0100
Subject: [PATCH] RTL compilation sorts continuations topologically before
 visiting them

* module/language/cps/compile-rtl.scm (compile-fun): Rewrite to visit
  conts in reverse-post-order, which is a topological sort on the basic
  blocks.

* module/language/cps/slot-allocation.scm (allocate-slots): Expect a DFG
  as an argument.
---
 module/language/cps/compile-rtl.scm     | 774 ++++++++++++------------
 module/language/cps/slot-allocation.scm |   9 +-
 2 files changed, 407 insertions(+), 376 deletions(-)

diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 51478c125..7ed0c1113 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -39,8 +39,7 @@
   #:use-module (system vm assembler)
   #:export (compile-rtl))
 
-;; TODO: Source info, local var names.  Needs work in the linker and the
-;; debugger.
+;; TODO: Local var names.
 
 (define (kw-arg-ref args kw default)
   (match (memq kw args)
@@ -78,6 +77,408 @@
 
     exp))
 
+(define (collect-conts f cfa)
+  (let ((srcv (make-vector (cfa-k-count cfa) #f))
+        (contv (make-vector (cfa-k-count cfa) #f)))
+    (fold-local-conts
+     (lambda (k src cont tail)
+       (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
+         (when idx
+           (when src
+             (vector-set! srcv idx src))
+           (vector-set! contv idx cont))))
+     '()
+     (match f
+       (($ $fun meta free entry)
+        entry)))
+    (values srcv contv)))
+
+(define (compile-fun f asm)
+  (let* ((dfg (compute-dfg f #:global? #f))
+         (cfa (analyze-control-flow f dfg))
+         (allocation (allocate-slots f dfg)))
+    (call-with-values (lambda () (collect-conts f cfa))
+      (lambda (srcv contv)
+        (define (lookup-cont k)
+          (vector-ref contv (cfa-k-idx cfa k)))
+
+        (define (maybe-emit-source n)
+          (let ((src (vector-ref srcv n)))
+            (when src
+              (emit-source asm src))))
+
+        (define (emit-label-and-maybe-source n)
+          (emit-label asm (cfa-k-sym cfa n))
+          (maybe-emit-source n))
+
+        (define (immediate-u8? val)
+          (and (integer? val) (exact? val) (<= 0 val 255)))
+
+        (define (maybe-immediate-u8 sym)
+          (call-with-values (lambda ()
+                              (lookup-maybe-constant-value sym allocation))
+            (lambda (has-const? val)
+              (and has-const? (immediate-u8? val) val))))
+
+        (define (slot sym)
+          (lookup-slot sym allocation))
+
+        (define (constant sym)
+          (lookup-constant-value sym allocation))
+
+        (define (maybe-mov dst src)
+          (unless (= dst src)
+            (emit-mov asm dst src)))
+
+        (define (maybe-load-constant slot src)
+          (call-with-values (lambda ()
+                              (lookup-maybe-constant-value src allocation))
+            (lambda (has-const? val)
+              (and has-const?
+                   (begin
+                     (emit-load-constant asm slot val)
+                     #t)))))
+
+        (define (compile-entry meta)
+          (match (vector-ref contv 0)
+            (($ $kentry self tail clauses)
+             (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+             (maybe-emit-source 0)
+             (let lp ((n 1)
+                      (ks (map (match-lambda (($ $cont k) k)) clauses)))
+               (match ks
+                 (()
+                  (unless (= n (vector-length contv))
+                    (error "unexpected end of clauses"))
+                  (emit-end-program asm))
+                 ((k . ks)
+                  (unless (eq? (cfa-k-sym cfa n) k)
+                    (error "unexpected k" k))
+                  (lp (compile-clause n (and (pair? ks) (car ks)))
+                      ks)))))))
+
+        (define (compile-clause n alternate)
+          (match (vector-ref contv n)
+            (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+             (let ((kw-indices (map (match-lambda
+                                     ((key name sym)
+                                      (cons key (lookup-slot sym allocation))))
+                                    kw))
+                   (nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation)))
+               (emit-label-and-maybe-source n)
+               (emit-begin-kw-arity asm req opt rest kw-indices
+                                    allow-other-keys? nlocals alternate)
+               (let ((next (compile-body (1+ n) nlocals)))
+                 (emit-end-arity asm)
+                 next)))))
+
+        (define (compile-body n nlocals)
+          (let compile-cont ((n n))
+            (if (= n (vector-length contv))
+                n
+                (match (vector-ref contv n)
+                  (($ $kclause) n)
+                  (($ $kargs _ _ term)
+                   (emit-label-and-maybe-source n)
+                   (let find-exp ((term term))
+                     (match term
+                       (($ $letk conts term)
+                        (find-exp term))
+                       (($ $continue k exp)
+                        (compile-expression n k exp nlocals)
+                        (compile-cont (1+ n))))))
+                  (_
+                   (emit-label-and-maybe-source n)
+                   (compile-cont (1+ n)))))))
+
+        (define (compile-expression n k exp nlocals)
+          (let* ((label (cfa-k-sym cfa n))
+                 (k-idx (cfa-k-idx cfa k))
+                 (fallthrough? (= k-idx (1+ n))))
+            (define (maybe-emit-jump)
+              (unless (= k-idx (1+ n))
+                (emit-br asm k)))
+            (match (vector-ref contv k-idx)
+              (($ $ktail)
+               (compile-tail label exp))
+              (($ $kargs (name) (sym))
+               (let ((dst (slot sym)))
+                 (when dst
+                   (compile-value label exp dst nlocals)))
+               (maybe-emit-jump))
+              (($ $kargs () ())
+               (compile-effect label exp k nlocals)
+               (maybe-emit-jump))
+              (($ $kargs names syms)
+               (compile-values label exp syms)
+               (maybe-emit-jump))
+              (($ $kif kt kf)
+               (compile-test label exp kt kf
+                             (and (= k-idx (1+ n))
+                                  (< (+ n 2) (cfa-k-count cfa))
+                                  (cfa-k-sym cfa (+ n 2)))))
+              (($ $ktrunc ($ $arity req () rest () #f) k)
+               (compile-trunc label exp (length req) (and rest #t) nlocals)
+               (unless (and (= k-idx (1+ n))
+                            (< (+ n 2) (cfa-k-count cfa))
+                            (eq? (cfa-k-sym cfa (+ n 2)) k))
+                 (emit-br asm k))))))
+
+        (define (compile-tail label exp)
+          ;; There are only three kinds of expressions in tail position:
+          ;; tail calls, multiple-value returns, and single-value returns.
+          (match exp
+            (($ $call proc args)
+             (for-each (match-lambda
+                        ((src . dst) (emit-mov asm dst src)))
+                       (lookup-parallel-moves label allocation))
+             (let ((tail-slots (cdr (iota (1+ (length args))))))
+               (for-each maybe-load-constant tail-slots args))
+             (emit-tail-call asm (1+ (length args))))
+            (($ $values args)
+             (let ((tail-slots (cdr (iota (1+ (length args))))))
+               (for-each (match-lambda
+                          ((src . dst) (emit-mov asm dst src)))
+                         (lookup-parallel-moves label allocation))
+               (for-each maybe-load-constant tail-slots args))
+             (emit-reset-frame asm (1+ (length args)))
+             (emit-return-values asm))
+            (($ $primcall 'return (arg))
+             (emit-return asm (slot arg)))))
+
+        (define (compile-value label exp dst nlocals)
+          (match exp
+            (($ $var sym)
+             (maybe-mov dst (slot sym)))
+            ;; FIXME: Remove ($var sym), replace with ($values (sym))
+            (($ $values (arg))
+             (or (maybe-load-constant dst arg)
+                 (maybe-mov dst (slot arg))))
+            (($ $void)
+             (emit-load-constant asm dst *unspecified*))
+            (($ $const exp)
+             (emit-load-constant asm dst exp))
+            (($ $fun meta () ($ $cont k))
+             (emit-load-static-procedure asm dst k))
+            (($ $fun meta free ($ $cont k))
+             (emit-make-closure asm dst k (length free)))
+            (($ $call proc args)
+             (let ((proc-slot (lookup-call-proc-slot label allocation))
+                   (nargs (length args)))
+               (or (maybe-load-constant proc-slot proc)
+                   (maybe-mov proc-slot (slot proc)))
+               (let lp ((n (1+ proc-slot)) (args args))
+                 (match args
+                   (()
+                    (emit-call asm proc-slot (+ nargs 1))
+                    (emit-receive asm dst proc-slot nlocals))
+                   ((arg . args)
+                    (or (maybe-load-constant n arg)
+                        (maybe-mov n (slot arg)))
+                    (lp (1+ n) args))))))
+            (($ $primcall 'current-module)
+             (emit-current-module asm dst))
+            (($ $primcall 'cached-toplevel-box (scope name bound?))
+             (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+                                       (constant bound?)))
+            (($ $primcall 'cached-module-box (mod name public? bound?))
+             (emit-cached-module-box asm dst (constant mod) (constant name)
+                                     (constant public?) (constant bound?)))
+            (($ $primcall 'resolve (name bound?))
+             (emit-resolve asm dst (constant bound?) (slot name)))
+            (($ $primcall 'free-ref (closure idx))
+             (emit-free-ref asm dst (slot closure) (constant idx)))
+            (($ $primcall 'make-vector (length init))
+             (cond
+              ((maybe-immediate-u8 length)
+               => (lambda (length)
+                    (emit-constant-make-vector asm dst length (slot init))))
+              (else
+               (emit-make-vector asm dst (slot length) (slot init)))))
+            (($ $primcall 'vector-ref (vector index))
+             (cond
+              ((maybe-immediate-u8 index)
+               => (lambda (index)
+                    (emit-constant-vector-ref asm dst (slot vector) index)))
+              (else
+               (emit-vector-ref asm dst (slot vector) (slot index)))))
+            (($ $primcall 'builtin-ref (name))
+             (emit-builtin-ref asm dst (constant name)))
+            (($ $primcall 'bv-u8-ref (bv idx))
+             (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-u16-ref (bv idx))
+             (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-s16-ref (bv idx))
+             (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-u32-ref (bv idx val))
+             (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-s32-ref (bv idx val))
+             (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-u64-ref (bv idx val))
+             (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-s64-ref (bv idx val))
+             (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-f32-ref (bv idx val))
+             (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall 'bv-f64-ref (bv idx val))
+             (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
+            (($ $primcall name args)
+             ;; FIXME: Inline all the cases.
+             (let ((inst (prim-rtl-instruction name)))
+               (emit-text asm `((,inst ,dst ,@(map slot args))))))))
+
+        (define (compile-effect label exp k nlocals)
+          (match exp
+            (($ $values ()) #f)
+            (($ $prompt escape? tag handler pop)
+             (match (lookup-cont handler)
+               (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+                (let ((receive-args (gensym "handler"))
+                      (nreq (length req))
+                      (proc-slot (lookup-call-proc-slot label allocation)))
+                  (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+                  (emit-br asm k)
+                  (emit-label asm receive-args)
+                  (emit-receive-values asm proc-slot (->bool rest) nreq)
+                  (when rest
+                    (emit-bind-rest asm (+ proc-slot 1 nreq)))
+                  (for-each (match-lambda
+                             ((src . dst) (emit-mov asm dst src)))
+                            (lookup-parallel-moves handler allocation))
+                  (emit-reset-frame asm nlocals)
+                  (emit-br asm khandler-body)))))
+            (($ $primcall 'cache-current-module! (sym scope))
+             (emit-cache-current-module! asm (slot sym) (constant scope)))
+            (($ $primcall 'free-set! (closure idx value))
+             (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+            (($ $primcall 'box-set! (box value))
+             (emit-box-set! asm (slot box) (slot value)))
+            (($ $primcall 'struct-set! (struct index value))
+             (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+            (($ $primcall 'vector-set! (vector index value))
+             (call-with-values (lambda ()
+                                 (lookup-maybe-constant-value index allocation))
+               (lambda (has-const? index-val)
+                 (if (and has-const? (integer? index-val) (exact? index-val)
+                          (<= 0 index-val 255))
+                     (emit-constant-vector-set! asm (slot vector) index-val
+                                                (slot value))
+                     (emit-vector-set! asm (slot vector) (slot index)
+                                       (slot value))))))
+            (($ $primcall 'variable-set! (var val))
+             (emit-box-set! asm (slot var) (slot val)))
+            (($ $primcall 'set-car! (pair value))
+             (emit-set-car! asm (slot pair) (slot value)))
+            (($ $primcall 'set-cdr! (pair value))
+             (emit-set-cdr! asm (slot pair) (slot value)))
+            (($ $primcall 'define! (sym value))
+             (emit-define! asm (slot sym) (slot value)))
+            (($ $primcall 'push-fluid (fluid val))
+             (emit-push-fluid asm (slot fluid) (slot val)))
+            (($ $primcall 'pop-fluid ())
+             (emit-pop-fluid asm))
+            (($ $primcall 'wind (winder unwinder))
+             (emit-wind asm (slot winder) (slot unwinder)))
+            (($ $primcall 'bv-u8-set! (bv idx val))
+             (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-u16-set! (bv idx val))
+             (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-s16-set! (bv idx val))
+             (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-u32-set! (bv idx val))
+             (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-s32-set! (bv idx val))
+             (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-u64-set! (bv idx val))
+             (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-s64-set! (bv idx val))
+             (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-f32-set! (bv idx val))
+             (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'bv-f64-set! (bv idx val))
+             (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
+            (($ $primcall 'unwind ())
+             (emit-unwind asm))))
+
+        (define (compile-values label exp syms)
+          (match exp
+            (($ $values args)
+             (for-each (match-lambda
+                        ((src . dst) (emit-mov asm dst src)))
+                       (lookup-parallel-moves label allocation))
+             (for-each maybe-load-constant (map slot syms) args))))
+
+        (define (compile-test label exp kt kf next-label)
+          (define (unary op sym)
+            (cond
+             ((eq? kt next-label)
+              (op asm (slot sym) #t kf))
+             (else
+              (op asm (slot sym) #f kt)
+              (unless (eq? kf next-label)
+                (emit-br asm kf)))))
+          (define (binary op a b)
+            (cond
+             ((eq? kt next-label)
+              (op asm (slot a) (slot b) #t kf))
+             (else
+              (op asm (slot a) (slot b) #f kt)
+              (unless (eq? kf next-label)
+                (emit-br asm kf)))))
+          (match exp
+            (($ $var sym) (unary emit-br-if-true sym))
+            (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+            (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+            (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+            (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+            (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+            (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+            (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
+            (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
+            (($ $primcall 'string? (a)) (unary emit-br-if-string a))
+            (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
+            ;; Add more TC7 tests here.  Keep in sync with
+            ;; *branching-primcall-arities* in (language cps primitives) and
+            ;; the set of macro-instructions in assembly.scm.
+            (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+            (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+            (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+            (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+            (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+            (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+            (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+            (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+
+        (define (compile-trunc label exp nreq rest? nlocals)
+          (match exp
+            (($ $call proc args)
+             (let ((proc-slot (lookup-call-proc-slot label allocation))
+                   (nargs (length args)))
+               (or (maybe-load-constant proc-slot proc)
+                   (maybe-mov proc-slot (slot proc)))
+               (let lp ((n (1+ proc-slot)) (args args))
+                 (match args
+                   (()
+                    (emit-call asm proc-slot (+ nargs 1))
+                    ;; FIXME: Only allow more values if there is a rest arg.
+                    ;; Express values truncation by the presence of an
+                    ;; unused rest arg instead of implicitly.
+                    (emit-receive-values asm proc-slot #t nreq)
+                    (when rest?
+                      (emit-bind-rest asm (+ proc-slot 1 nreq)))
+                    (for-each (match-lambda
+                               ((src . dst) (emit-mov asm dst src)))
+                              (lookup-parallel-moves label allocation))
+                    (emit-reset-frame asm nlocals))
+                   ((arg . args)
+                    (or (maybe-load-constant n arg)
+                        (maybe-mov n (slot arg)))
+                    (lp (1+ n) args))))))))
+
+        (match f
+          (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
+           (compile-entry (or meta '()))))))))
+
 (define (visit-funs proc exp)
   (match exp
     (($ $continue _ exp)
@@ -102,375 +503,6 @@
 
     (_ (values))))
 
-(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
-  (define (immediate-u8? val)
-    (and (integer? val) (exact? val) (<= 0 val 255)))
-
-  (define (maybe-immediate-u8 sym)
-    (call-with-values (lambda ()
-                        (lookup-maybe-constant-value sym allocation))
-      (lambda (has-const? val)
-        (and has-const? (immediate-u8? val) val))))
-
-  (define (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 'make-vector (length init))
-           (cond
-            ((maybe-immediate-u8 length)
-             => (lambda (length)
-                  (emit-constant-make-vector asm dst length (slot init))))
-            (else
-             (emit-make-vector asm dst (slot length) (slot init)))))
-          (($ $primcall 'vector-ref (vector index))
-           (cond
-            ((maybe-immediate-u8 index)
-             => (lambda (index)
-                  (emit-constant-vector-ref asm dst (slot vector) index)))
-            (else
-             (emit-vector-ref asm dst (slot vector) (slot index)))))
-          (($ $primcall 'builtin-ref (name))
-           (emit-builtin-ref asm dst (constant name)))
-          (($ $primcall 'bv-u8-ref (bv idx))
-           (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-u16-ref (bv idx))
-           (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-s16-ref (bv idx))
-           (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-u32-ref (bv idx val))
-           (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-s32-ref (bv idx val))
-           (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-u64-ref (bv idx val))
-           (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-s64-ref (bv idx val))
-           (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-f32-ref (bv idx val))
-           (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall 'bv-f64-ref (bv idx val))
-           (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
-          (($ $primcall name args)
-           ;; FIXME: Inline all the cases.
-           (let ((inst (prim-rtl-instruction name)))
-             (emit-text asm `((,inst ,dst ,@(map slot args))))))
-          (($ $values (arg))
-           (or (maybe-load-constant dst arg)
-               (maybe-mov dst (slot arg)))))
-        (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))
-         (call-with-values (lambda ()
-                             (lookup-maybe-constant-value index allocation))
-           (lambda (has-const? index-val)
-             (if (and has-const? (integer? index-val) (exact? index-val)
-                      (<= 0 index-val 255))
-                 (emit-constant-vector-set! asm (slot vector) index-val
-                                            (slot value))
-                 (emit-vector-set! asm (slot vector) (slot index)
-                                   (slot value))))))
-        (($ $primcall 'variable-set! (var val))
-         (emit-box-set! asm (slot var) (slot val)))
-        (($ $primcall 'set-car! (pair value))
-         (emit-set-car! asm (slot pair) (slot value)))
-        (($ $primcall 'set-cdr! (pair value))
-         (emit-set-cdr! asm (slot pair) (slot value)))
-        (($ $primcall 'define! (sym value))
-         (emit-define! asm (slot sym) (slot value)))
-        (($ $primcall 'push-fluid (fluid val))
-         (emit-push-fluid asm (slot fluid) (slot val)))
-        (($ $primcall 'pop-fluid ())
-         (emit-pop-fluid asm))
-        (($ $primcall 'wind (winder unwinder))
-         (emit-wind asm (slot winder) (slot unwinder)))
-        (($ $primcall 'bv-u8-set! (bv idx val))
-         (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-u16-set! (bv idx val))
-         (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-s16-set! (bv idx val))
-         (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-u32-set! (bv idx val))
-         (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-s32-set! (bv idx val))
-         (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-u64-set! (bv idx val))
-         (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-s64-set! (bv idx val))
-         (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-f32-set! (bv idx val))
-         (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'bv-f64-set! (bv idx val))
-         (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
-        (($ $primcall 'unwind ())
-         (emit-unwind asm))
-        (($ $primcall name args)
-         (error "unhandled primcall in seq context" name))
-        (($ $values ()) #f)
-        (($ $prompt escape? tag handler pop)
-         (match (lookup-cont handler cont-table)
-           (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
-            (let ((receive-args (gensym "handler"))
-                  (nreq (length req))
-                  (proc-slot (lookup-call-proc-slot label allocation)))
-              (emit-prompt asm (slot tag) escape? proc-slot receive-args)
-              (emit-br asm k)
-              (emit-label asm receive-args)
-              (emit-receive-values asm proc-slot (->bool rest) nreq)
-              (when rest
-                (emit-bind-rest asm (+ proc-slot 1 nreq)))
-              (for-each (match-lambda
-                         ((src . dst) (emit-mov asm dst src)))
-                        (lookup-parallel-moves handler allocation))
-              (emit-reset-frame asm nlocals)
-              (emit-br asm khandler-body))))))
-      (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))
-        (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
-        (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
-        (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
-        (($ $primcall 'string? (a)) (unary emit-br-if-string a))
-        (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
-        ;; Add more TC7 tests here.  Keep in sync with
-        ;; *branching-primcall-arities* in (language cps primitives) and
-        ;; the set of macro-instructions in assembly.scm.
-        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
-        (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
-        (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
-        (($ $primcall '< (a b)) (binary emit-br-if-< a b))
-        (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
-        (($ $primcall '= (a b)) (binary emit-br-if-= a b))
-        (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
-        (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
-
-    (define (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))
-                ;; FIXME: Only allow more values if there is a rest arg.
-                ;; Express values truncation by the presence of an
-                ;; unused rest arg instead of implicitly.
-                (emit-receive-values asm proc-slot #t nreq)
-                (when rest?
-                  (emit-bind-rest asm (+ proc-slot 1 nreq)))
-                (for-each (match-lambda
-                           ((src . dst) (emit-mov asm dst src)))
-                          (lookup-parallel-moves label allocation))
-                (emit-reset-frame asm nlocals))
-               ((arg . args)
-                (or (maybe-load-constant n arg)
-                    (maybe-mov n (slot arg)))
-                (lp (1+ n) args)))))))
-      (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)
-         (when src
-           (emit-source asm src))
-         (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)
-           (when src
-             (emit-source asm src))
-           (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 '()))
-       (when src
-         (emit-source asm src))
-       (emit-fun-clauses clauses)
-       (emit-end-program asm)))))
-
 (define (compile-rtl exp env opts)
   (pk 'COMPILING)
   (let* ((exp (fix-arities exp))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index ddc3751cf..c0d21d9ec 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -198,7 +198,7 @@ are comparable with eqv?.  A tmp slot may be used."
   (let ((l (dfa-k-idx dfa use-k)))
     (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
 
-(define (allocate-slots fun)
+(define (allocate-slots fun dfg)
   (define (empty-live-slots)
     #b0)
 
@@ -231,7 +231,7 @@ are comparable with eqv?.  A tmp slot may be used."
                         live-slots)))
               live-slots)))))
 
-  (define (visit-clause clause dfg dfa allocation slots live-slots)
+  (define (visit-clause clause dfa allocation slots live-slots)
     (define nlocals (compute-slot live-slots #f))
     (define nargs
       (match clause
@@ -426,13 +426,12 @@ are comparable with eqv?.  A tmp slot may be used."
 
   (match fun
     (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
-     (let* ((dfg (compute-dfg fun #:global? #f))
-            (dfa (compute-live-variables fun dfg))
+     (let* ((dfa (compute-live-variables fun dfg))
             (allocation (make-hash-table))
             (slots (make-vector (dfa-var-count dfa) #f))
             (live-slots (add-live-slot 0 (empty-live-slots))))
        (vector-set! slots (dfa-var-idx dfa self) 0)
        (hashq-set! allocation self (make-allocation 0 #f #f))
-       (for-each (cut visit-clause <> dfg dfa allocation slots live-slots)
+       (for-each (cut visit-clause <> dfa allocation slots live-slots)
                  clauses)
        allocation))))