Remove CPS optimization passes and closure conversion

* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm: Remove these files, obsoleted by CPS2.

* module/Makefile.am: Update.

15 files changed, 0 insertions, 5209 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 270699b96..188cc7626 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,27 +123,13 @@ TREE_IL_LANG_SOURCES =						\
 
 CPS_LANG_SOURCES =						\
   language/cps.scm						\
-  language/cps/closure-conversion.scm				\
   language/cps/compile-bytecode.scm				\
-  language/cps/constructors.scm					\
-  language/cps/contification.scm				\
-  language/cps/cse.scm						\
-  language/cps/dce.scm						\
   language/cps/dfg.scm						\
-  language/cps/effects-analysis.scm				\
-  language/cps/elide-values.scm					\
   language/cps/primitives.scm					\
-  language/cps/prune-bailouts.scm				\
-  language/cps/prune-top-level-scopes.scm			\
   language/cps/reify-primitives.scm				\
   language/cps/renumber.scm					\
-  language/cps/self-references.scm				\
   language/cps/slot-allocation.scm				\
-  language/cps/simplify.scm					\
   language/cps/spec.scm						\
-  language/cps/specialize-primcalls.scm				\
-  language/cps/type-fold.scm					\
-  language/cps/types.scm					\
   language/cps/verify.scm
 
 CPS2_LANG_SOURCES =						\
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
deleted file mode 100644
index 49ff30f93..000000000
--- a/module/language/cps/closure-conversion.scm
+++ /dev/null
@@ -1,565 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Commentary:
-;;;
-;;; This pass converts a CPS term in such a way that no function has any
-;;; free variables.  Instead, closures are built explicitly with
-;;; make-closure primcalls, and free variables are referenced through
-;;; the closure.
-;;;
-;;; Closure conversion also removes any $rec expressions that
-;;; contification did not handle.  See (language cps) for a further
-;;; discussion of $rec.
-;;;
-;;; Code:
-
-(define-module (language cps closure-conversion)
-  #:use-module (ice-9 match)
-  #:use-module ((srfi srfi-1) #:select (fold
-                                        filter-map
-                                        lset-union lset-difference
-                                        list-index))
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-26)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:export (convert-closures))
-
-;; free := var ...
-
-(define (analyze-closures exp dfg)
-  "Compute the set of free variables for all $fun instances in
-@var{exp}."
-  (let ((bound-vars (make-hash-table))
-        (free-vars (make-hash-table))
-        (named-funs (make-hash-table))
-        (well-known-vars (make-bitvector (var-counter) #t))
-        (letrec-conts (make-hash-table)))
-    (define (add-named-fun! var cont)
-      (hashq-set! named-funs var cont)
-      (match cont
-        (($ $cont label ($ $kfun src meta self))
-         (unless (eq? var self)
-           (hashq-set! bound-vars label var)))))
-    (define (clear-well-known! var)
-      (bitvector-set! well-known-vars var #f))
-    (define (compute-well-known-labels)
-      (let ((bv (make-bitvector (label-counter) #f)))
-        (hash-for-each
-         (lambda (var cont)
-           (match cont
-             (($ $cont label ($ $kfun src meta self))
-              (unless (equal? var self)
-                (bitvector-set! bv label
-                                (and (bitvector-ref well-known-vars var)
-                                     (bitvector-ref well-known-vars self)))))))
-         named-funs)
-        bv))
-    (define (union a b)
-      (lset-union eq? a b))
-    (define (difference a b)
-      (lset-difference eq? a b))
-    (define (visit-cont cont bound)
-      (match cont
-        (($ $cont label ($ $kargs names vars body))
-         (visit-term body (append vars bound)))
-        (($ $cont label ($ $kfun src meta self tail clause))
-         (add-named-fun! self cont)
-         (let ((free (if clause
-                         (visit-cont clause (list self))
-                         '())))
-           (hashq-set! free-vars label free)
-           (difference free bound)))
-        (($ $cont label ($ $kclause arity body alternate))
-         (let ((free (visit-cont body bound)))
-           (if alternate
-               (union (visit-cont alternate bound) free)
-               free)))
-        (($ $cont) '())))
-    (define (visit-term term bound)
-      (match term
-        (($ $letk conts body)
-         (fold (lambda (cont free)
-                 (union (visit-cont cont bound) free))
-               (visit-term body bound)
-               conts))
-        (($ $continue k src ($ $fun body))
-         (match (lookup-predecessors k dfg)
-           ((_) (match (lookup-cont k dfg)
-                  (($ $kargs (name) (var))
-                   (add-named-fun! var body))))
-           (_ #f))
-         (visit-cont body bound))
-        (($ $continue k src ($ $rec names vars (($ $fun cont) ...)))
-         (hashq-set! letrec-conts k (lookup-cont k dfg))
-         (let ((bound (append vars bound)))
-           (for-each add-named-fun! vars cont)
-           (fold (lambda (cont free)
-                   (union (visit-cont cont bound) free))
-                 '()
-                 cont)))
-        (($ $continue k src exp)
-         (visit-exp exp bound))))
-    (define (visit-exp exp bound)
-      (define (adjoin var free)
-        (if (or (memq var bound) (memq var free))
-            free
-            (cons var free)))
-      (match exp
-        ((or ($ $const) ($ $prim)) '())
-        (($ $call proc args)
-         (for-each clear-well-known! args)
-         (fold adjoin (adjoin proc '()) args))
-        (($ $primcall name args)
-         (for-each clear-well-known! args)
-         (fold adjoin '() args))
-        (($ $branch kt exp)
-         (visit-exp exp bound))
-        (($ $values args)
-         (for-each clear-well-known! args)
-         (fold adjoin '() args))
-        (($ $prompt escape? tag handler)
-         (clear-well-known! tag)
-         (adjoin tag '()))))
-
-    (let ((free (visit-cont exp '())))
-      (unless (null? free)
-        (error "Expected no free vars in toplevel thunk" free exp))
-      (values bound-vars free-vars named-funs (compute-well-known-labels)
-              letrec-conts))))
-
-(define (prune-free-vars free-vars named-funs well-known var-aliases)
-  (define (well-known? label)
-    (bitvector-ref well-known label))
-  (let ((eliminated (make-bitvector (label-counter) #f))
-        (label-aliases (make-vector (label-counter) #f)))
-    (let lp ((label 0))
-      (let ((label (bit-position #t well-known label)))
-        (when label
-          (match (hashq-ref free-vars label)
-            ;; Mark all well-known closures that have no free variables
-            ;; for elimination.
-            (() (bitvector-set! eliminated label #t))
-            ;; Replace well-known closures that have just one free
-            ;; variable by references to that free variable.
-            ((var)
-             (vector-set! label-aliases label var))
-            (_ #f))
-          (lp (1+ label)))))
-    ;; Iterative free variable elimination.
-    (let lp ()
-      (let ((recurse? #f))
-        (define (adjoin elt list)
-          ;; Normally you wouldn't see duplicates in a free variable
-          ;; list, but with aliases that is possible.
-          (if (memq elt list) list (cons elt list)))
-        (define (prune-free closure-label free)
-          (match free
-            (() '())
-            ((var . free)
-             (let lp ((var var) (alias-stack '()))
-               (match (hashq-ref named-funs var)
-                 (($ $cont label)
-                  (cond
-                   ((bitvector-ref eliminated label)
-                    (prune-free closure-label free))
-                   ((vector-ref label-aliases label)
-                    => (lambda (var)
-                         (cond
-                          ((memq label alias-stack)
-                           ;; We have found a set of mutually recursive
-                           ;; well-known procedures, each of which only
-                           ;; closes over one of the others.  Mark them
-                           ;; all for elimination.
-                           (for-each (lambda (label)
-                                       (bitvector-set! eliminated label #t)
-                                       (set! recurse? #t))
-                                     alias-stack)
-                           (prune-free closure-label free))
-                          (else
-                           (lp var (cons label alias-stack))))))
-                   ((eq? closure-label label)
-                    ;; Eliminate self-reference.
-                    (prune-free closure-label free))
-                   (else
-                    (adjoin var (prune-free closure-label free)))))
-                 (_ (adjoin var (prune-free closure-label free))))))))
-        (hash-for-each-handle
-         (lambda (pair)
-           (match pair
-             ((label . ()) #t)
-             ((label . free)
-              (let ((orig-nfree (length free))
-                    (free (prune-free label free)))
-                (set-cdr! pair free)
-                ;; If we managed to eliminate one or more free variables
-                ;; from a well-known function, it could be that we can
-                ;; eliminate or alias this function as well.
-                (when (and (well-known? label)
-                           (< (length free) orig-nfree))
-                  (match free
-                    (()
-                     (bitvector-set! eliminated label #t)
-                     (set! recurse? #t))
-                    ((var)
-                     (vector-set! label-aliases label var)
-                     (set! recurse? #t))
-                    (_ #t)))))))
-         free-vars)
-        ;; Iterate to fixed point.
-        (when recurse? (lp))))
-    ;; Populate var-aliases from label-aliases.
-    (hash-for-each (lambda (var cont)
-                     (match cont
-                       (($ $cont label)
-                        (let ((alias (vector-ref label-aliases label)))
-                          (when alias
-                            (vector-set! var-aliases var alias))))))
-                   named-funs)))
-
-(define (convert-one bound label fun free-vars named-funs well-known aliases
-                     letrec-conts)
-  (define (well-known? label)
-    (bitvector-ref well-known label))
-
-  (let ((free (hashq-ref free-vars label))
-        (self-known? (well-known? label))
-        (self (match fun (($ $kfun _ _ self) self))))
-    (define (convert-free-var var k)
-      "Convert one possibly free variable reference to a bound reference.
-
-If @var{var} is free, it is replaced by a closure reference via a
-@code{free-ref} primcall, and @var{k} is called with the new var.
-Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
-      (cond
-       ((list-index (cut eq? <> var) free)
-        => (lambda (free-idx)
-             (match (cons self-known? free)
-               ;; A reference to the one free var of a well-known function.
-               ((#t _) (k self))
-               ;; A reference to one of the two free vars in a well-known
-               ;; function.
-               ((#t _ _)
-                (let-fresh (k*) (var*)
-                  (build-cps-term
-                    ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
-                      ($continue k* #f
-                        ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
-               (_
-                (let-fresh (k* kidx) (idx var*)
-                  (build-cps-term
-                    ($letk ((kidx ($kargs ('idx) (idx)
-                                    ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
-                                      ($continue k* #f
-                                        ($primcall
-                                         (cond
-                                          ((not self-known?) 'free-ref)
-                                          ((<= free-idx #xff) 'vector-ref/immediate)
-                                          (else 'vector-ref))
-                                         (self idx)))))))
-                      ($continue kidx #f ($const free-idx)))))))))
-       ((eq? var bound) (k self))
-       (else (k var))))
-  
-    (define (convert-free-vars vars k)
-      "Convert a number of possibly free references to bound references.
-@var{k} is called with the bound references, and should return the
-term."
-      (match vars
-        (() (k '()))
-        ((var . vars)
-         (convert-free-var var
-                           (lambda (var)
-                             (convert-free-vars vars
-                                                (lambda (vars)
-                                                  (k (cons var vars)))))))))
-  
-    (define (allocate-closure src name var label known? free body)
-      "Allocate a new closure."
-      (match (cons known? free)
-        ((#f . _)
-         (let-fresh (k*) ()
-           (build-cps-term
-             ($letk ((k* ($kargs (name) (var) ,body)))
-               ($continue k* src
-                 ($closure label (length free)))))))
-        ((#t)
-         ;; Well-known closure with no free variables; elide the
-         ;; binding entirely.
-         body)
-        ((#t _)
-         ;; Well-known closure with one free variable; the free var is the
-         ;; closure, and no new binding need be made.
-         body)
-        ((#t _ _)
-         ;; Well-known closure with two free variables; the closure is a
-         ;; pair.
-         (let-fresh (kinit kfalse) (false)
-           (build-cps-term
-             ($letk ((kinit ($kargs (name) (var)
-                              ,body))
-                     (kfalse ($kargs ('false) (false)
-                               ($continue kinit src
-                                 ($primcall 'cons (false false))))))
-               ($continue kfalse src ($const #f))))))
-        ;; Well-known callee with more than two free variables; the closure
-        ;; is a vector.
-        ((#t . _)
-         (let ((nfree (length free)))
-           (let-fresh (kinit klen kfalse) (false len-var)
-             (build-cps-term
-               ($letk ((kinit ($kargs (name) (var) ,body))
-                       (kfalse
-                        ($kargs ('false) (false)
-                          ($letk ((klen
-                                   ($kargs ('len) (len-var)
-                                     ($continue kinit src
-                                       ($primcall (if (<= nfree #xff)
-                                                      'make-vector/immediate
-                                                      'make-vector)
-                                                  (len-var false))))))
-                            ($continue klen src ($const nfree))))))
-                 ($continue kfalse src ($const #f)))))))))
-
-    (define (init-closure src var known? closure-free body)
-      "Initialize the free variables @var{closure-free} in a closure
-bound to @var{var}, and continue with @var{body}."
-      (match (cons known? closure-free)
-        ;; Well-known callee with no free variables; no initialization
-        ;; necessary.
-        ((#t) body)
-        ;; Well-known callee with one free variable; no initialization
-        ;; necessary.
-        ((#t _) body)
-        ;; Well-known callee with two free variables; do a set-car! and
-        ;; set-cdr!.
-        ((#t v0 v1)
-         (let-fresh (kcar kcdr) ()
-           (convert-free-var
-            v0
-            (lambda (v0)
-              (build-cps-term
-                ($letk ((kcar ($kargs () ()
-                                ,(convert-free-var
-                                  v1
-                                  (lambda (v1)
-                                    (build-cps-term
-                                      ($letk ((kcdr ($kargs () () ,body)))
-                                        ($continue kcdr src
-                                          ($primcall 'set-cdr! (var v1))))))))))
-                  ($continue kcar src
-                    ($primcall 'set-car! (var v0)))))))))
-        ;; Otherwise residualize a sequence of vector-set! or free-set!,
-        ;; depending on whether the callee is well-known or not.
-        (_
-         (fold (lambda (free idx body)
-                 (let-fresh (k) (idxvar)
-                   (build-cps-term
-                     ($letk ((k ($kargs () () ,body)))
-                       ,(convert-free-var
-                         free
-                         (lambda (free)
-                           (build-cps-term
-                             ($letconst (('idx idxvar idx))
-                               ($continue k src
-                                 ($primcall (cond
-                                             ((not known?) 'free-set!)
-                                             ((<= idx #xff) 'vector-set!/immediate)
-                                             (else 'vector-set!))
-                                            (var idxvar free)))))))))))
-               body
-               closure-free
-               (iota (length closure-free))))))
-
-    ;; Load the closure for a known call.  The callee may or may not be
-    ;; known at all call sites.
-    (define (convert-known-proc-call var label self self-known? free k)
-      ;; Well-known closures with one free variable are replaced at their
-      ;; use sites by uses of the one free variable.  The use sites of a
-      ;; well-known closures are only in well-known proc calls, and in
-      ;; free lists of other closures.  Here we handle the call case; the
-      ;; free list case is handled by prune-free-vars.
-      (define (rename var)
-        (let ((var* (vector-ref aliases var)))
-          (if var*
-              (rename var*)
-              var)))
-      (match (cons (well-known? label)
-                   (hashq-ref free-vars label))
-        ((#t)
-         ;; Calling a well-known procedure with no free variables; pass #f
-         ;; as the closure.
-         (let-fresh (k*) (v*)
-           (build-cps-term
-             ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
-               ($continue k* #f ($const #f))))))
-        ((#t _)
-         ;; Calling a well-known procedure with one free variable; pass
-         ;; the free variable as the closure.
-         (convert-free-var (rename var) k))
-        (_
-         (convert-free-var var k))))
-
-    (define (visit-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont label ($ $kargs names vars body))
-         (label ($kargs names vars ,(visit-term body))))
-        (($ $cont label ($ $kfun src meta self tail clause))
-         (label ($kfun src meta self ,tail
-                  ,(and clause (visit-cont clause)))))
-        (($ $cont label ($ $kclause arity body alternate))
-         (label ($kclause ,arity ,(visit-cont body)
-                          ,(and alternate (visit-cont alternate)))))
-        (($ $cont) ,cont)))
-    (define (maybe-visit-cont cont)
-      (match cont
-        ;; We will inline the $kargs that binds letrec vars in place of
-        ;; the $rec expression.
-        (($ $cont label)
-         (and (not (hashq-ref letrec-conts label))
-              (visit-cont cont)))))
-    (define (visit-term term)
-      (match term
-        (($ $letk conts body)
-         (build-cps-term
-           ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body))))
-
-        (($ $continue k src (or ($ $const) ($ $prim)))
-         term)
-
-        (($ $continue k src ($ $fun ($ $cont kfun)))
-         (let ((fun-free (hashq-ref free-vars kfun)))
-           (match (cons (well-known? kfun) fun-free)
-             ((known?)
-              (build-cps-term
-                ($continue k src ,(if known?
-                                      (build-cps-exp ($const #f))
-                                      (build-cps-exp ($closure kfun 0))))))
-             ((#t _)
-              ;; A well-known closure of one free variable is replaced
-              ;; at each use with the free variable itself, so we don't
-              ;; need a binding at all; and yet, the continuation
-              ;; expects one value, so give it something.  DCE should
-              ;; clean up later.
-              (build-cps-term
-                ($continue k src ,(build-cps-exp ($const #f)))))
-             (_
-              (let-fresh () (var)
-                (allocate-closure
-                 src #f var kfun (well-known? kfun) fun-free
-                 (init-closure
-                  src var (well-known? kfun) fun-free
-                  (build-cps-term ($continue k src ($values (var)))))))))))
-
-        ;; Remove letrec.
-        (($ $continue k src ($ $rec names vars funs))
-         (let lp ((in (map list names vars funs))
-                  (bindings (lambda (body) body))
-                  (body (match (hashq-ref letrec-conts k)
-                          ;; Remove these letrec bindings, as we're
-                          ;; going to inline the body after building
-                          ;; each closure separately.
-                          (($ $kargs names syms body)
-                           (visit-term body)))))
-           (match in
-             (() (bindings body))
-             (((name var ($ $fun
-                            (and fun-body
-                                 ($ $cont kfun ($ $kfun src))))) . in)
-              (let ((fun-free (hashq-ref free-vars kfun)))
-                (lp in
-                    (lambda (body)
-                      (allocate-closure
-                       src name var kfun (well-known? kfun) fun-free
-                       (bindings body)))
-                    (init-closure
-                     src var (well-known? kfun) fun-free
-                     body)))))))
-
-        (($ $continue k src ($ $call proc args))
-         (match (hashq-ref named-funs proc)
-           (($ $cont kfun)
-            (convert-known-proc-call
-             proc kfun self self-known? free
-             (lambda (proc)
-               (convert-free-vars args
-                                  (lambda (args)
-                                    (build-cps-term
-                                      ($continue k src
-                                        ($callk kfun proc args))))))))
-           (#f
-            (convert-free-vars (cons proc args)
-                               (match-lambda
-                                ((proc . args)
-                                 (build-cps-term
-                                   ($continue k src
-                                     ($call proc args)))))))))
-
-        (($ $continue k src ($ $primcall name args))
-         (convert-free-vars args
-                            (lambda (args)
-                              (build-cps-term
-                                ($continue k src ($primcall name args))))))
-
-        (($ $continue k src ($ $branch kt ($ $primcall name args)))
-         (convert-free-vars args
-                            (lambda (args)
-                              (build-cps-term
-                                ($continue k src
-                                  ($branch kt ($primcall name args)))))))
-
-        (($ $continue k src ($ $branch kt ($ $values (arg))))
-         (convert-free-var arg
-                           (lambda (arg)
-                             (build-cps-term
-                               ($continue k src
-                                 ($branch kt ($values (arg))))))))
-
-        (($ $continue k src ($ $values args))
-         (convert-free-vars args
-                            (lambda (args)
-                              (build-cps-term
-                                ($continue k src ($values args))))))
-
-        (($ $continue k src ($ $prompt escape? tag handler))
-         (convert-free-var tag
-                           (lambda (tag)
-                             (build-cps-term
-                               ($continue k src
-                                 ($prompt escape? tag handler))))))))
-    (visit-cont (build-cps-cont (label ,fun)))))
-
-(define (convert-closures fun)
-  "Convert free reference in @var{exp} to primcalls to @code{free-ref},
-and allocate and initialize flat closures."
-  (let ((dfg (compute-dfg fun)))
-    (with-fresh-name-state-from-dfg dfg
-      (call-with-values (lambda () (analyze-closures fun dfg))
-        (lambda (bound-vars free-vars named-funs well-known letrec-conts)
-          (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
-                (aliases (make-vector (var-counter) #f)))
-            (prune-free-vars free-vars named-funs well-known aliases)
-            (build-cps-term
-              ($program
-               ,(map (lambda (label)
-                       (convert-one (hashq-ref bound-vars label) label
-                                    (lookup-cont label dfg)
-                                    free-vars named-funs well-known aliases
-                                    letrec-conts))
-                     labels)))))))))
diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm
deleted file mode 100644
index bbe779d27..000000000
--- a/module/language/cps/constructors.scm
+++ /dev/null
@@ -1,104 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Constructor inlining turns "list" primcalls into a series of conses,
-;;; and does similar transformations for "vector".
-;;;
-;;; Code:
-
-(define-module (language cps constructors)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-26)
-  #:use-module (language cps)
-  #:export (inline-constructors))
-
-(define (inline-constructors* fun)
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont sym ($ $kargs names syms body))
-       (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kfun src meta self tail clause))
-       (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
-      (($ $cont sym ($ $kclause arity body alternate))
-       (sym ($kclause ,arity ,(visit-cont body)
-                      ,(and alternate (visit-cont alternate)))))
-      (($ $cont)
-       ,cont)))
-  (define (visit-term term)
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ($letk ,(map visit-cont conts)
-         ,(visit-term body)))
-      (($ $continue k src ($ $primcall 'list args))
-       ,(let-fresh (kvalues) (val)
-          (build-cps-term
-            ($letk ((kvalues ($kargs ('val) (val)
-                               ($continue k src
-                                 ($primcall 'values (val))))))
-              ,(let lp ((args args) (k kvalues))
-                 (match args
-                   (()
-                    (build-cps-term
-                      ($continue k src ($const '()))))
-                   ((arg . args)
-                    (let-fresh (ktail) (tail)
-                      (build-cps-term
-                        ($letk ((ktail ($kargs ('tail) (tail)
-                                         ($continue k src
-                                           ($primcall 'cons (arg tail))))))
-                          ,(lp args ktail)))))))))))
-      (($ $continue k src ($ $primcall 'vector args))
-       ,(let-fresh (kalloc) (vec len init)
-          (define (initialize args n)
-            (match args
-              (()
-               (build-cps-term
-                 ($continue k src ($primcall 'values (vec)))))
-              ((arg . args)
-               (let-fresh (knext) (idx)
-                 (build-cps-term
-                   ($letk ((knext ($kargs () ()
-                                    ,(initialize args (1+ n)))))
-                     ($letconst (('idx idx n))
-                       ($continue knext src
-                         ($primcall 'vector-set! (vec idx arg))))))))))
-          (build-cps-term
-            ($letk ((kalloc ($kargs ('vec) (vec)
-                              ,(initialize args 0))))
-              ($letconst (('len len (length args))
-                          ('init init #f))
-                ($continue kalloc src
-                  ($primcall 'make-vector (len init))))))))
-      (($ $continue k src (and fun ($ $fun)))
-       ($continue k src ,(visit-fun fun)))
-      (($ $continue k src ($ $rec names syms funs))
-       ($continue k src ($rec names syms (map visit-fun funs))))
-      (($ $continue)
-       ,term)))
-  (define (visit-fun fun)
-    (rewrite-cps-exp fun
-      (($ $fun body)
-       ($fun ,(inline-constructors* body)))))
-
-  (visit-cont fun))
-
-(define (inline-constructors fun)
-  (with-fresh-name-state fun
-    (inline-constructors* fun)))
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
deleted file mode 100644
index 1f702310a..000000000
--- a/module/language/cps/contification.scm
+++ /dev/null
@@ -1,414 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Contification is a pass that turns $fun instances into $cont
-;;; instances if all calls to the $fun return to the same continuation.
-;;; This is a more rigorous variant of our old "fixpoint labels
-;;; allocation" optimization.
-;;;
-;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
-;;; and Weeks's "Contification using Dominators".
-;;;
-;;; Code:
-
-(define-module (language cps contification)
-  #:use-module (ice-9 match)
-  #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
-  #:use-module (srfi srfi-26)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps primitives)
-  #:use-module (language bytecode)
-  #:export (contify))
-
-(define (compute-contification fun)
-  (let* ((dfg (compute-dfg fun))
-         (scope-table (make-hash-table))
-         (call-substs '())
-         (cont-substs '())
-         (cont-splices (make-hash-table)))
-    (define (subst-call! sym arities body-ks)
-      (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
-    (define (subst-return! old-tail new-tail)
-      (set! cont-substs (acons old-tail new-tail cont-substs)))
-    (define (splice-conts! scope conts)
-      (for-each (match-lambda
-                 (($ $cont k) (hashq-set! scope-table k scope)))
-                conts)
-      (hashq-set! cont-splices scope
-                  (append conts (hashq-ref cont-splices scope '()))))
-
-    (define (lookup-return-cont k)
-      (match (assq-ref cont-substs k)
-        (#f k)
-        (k (lookup-return-cont k))))
-
-    ;; If K is a continuation that binds one variable, and it has only
-    ;; one predecessor, return that variable.
-    (define (bound-symbol k)
-      (match (lookup-cont k dfg)
-        (($ $kargs (_) (sym))
-         (match (lookup-predecessors k dfg)
-           ((_)
-            ;; K has one predecessor, the one that defined SYM.
-            sym)
-           (_ #f)))
-        (_ #f)))
-
-    (define (extract-arities clause)
-      (match clause
-        (($ $cont _ ($ $kclause arity body alternate))
-         (cons arity (extract-arities alternate)))
-        (#f '())))
-    (define (extract-bodies clause)
-      (match clause
-        (($ $cont _ ($ $kclause arity body alternate))
-         (cons body (extract-bodies alternate)))
-        (#f '())))
-
-    (define (contify-fun term-k sym self tail arities bodies)
-      (contify-funs term-k
-                    (list sym) (list self) (list tail)
-                    (list arities) (list bodies)))
-
-    ;; Given a set of mutually recursive functions bound to local
-    ;; variables SYMS, with self symbols SELFS, tail continuations
-    ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
-    ;; contify them if we can prove that they all return to the same
-    ;; continuation.  Returns a true value on success, and false
-    ;; otherwise.
-    (define (contify-funs term-k syms selfs tails arities bodies)
-      (define (unused? sym)
-        (null? (lookup-uses sym dfg)))
-
-      ;; Are the given args compatible with any of the arities?
-      (define (applicable? proc args)
-        (let lp ((arities (assq-ref (map cons syms arities) proc)))
-          (match arities
-            ((($ $arity req () #f () #f) . arities)
-             (or (= (length args) (length req))
-                 (lp arities)))
-            ;; If we reached the end of the arities, fail.  Also fail if
-            ;; the next arity in the list has optional, keyword, or rest
-            ;; arguments.
-            (_ #f))))
-
-      ;; If the use of PROC in continuation USE is a call to PROC that
-      ;; is compatible with one of the procedure's arities, return the
-      ;; target continuation.  Otherwise return #f.
-      (define (call-target use proc)
-        (match (find-call (lookup-cont use dfg))
-          (($ $continue k src ($ $call proc* args))
-           (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
-                ;; Converge more quickly by resolving already-contified
-                ;; call targets.
-                (lookup-return-cont k)))
-          (_ #f)))
-
-      ;; If this set of functions is always called with one
-      ;; continuation, not counting tail calls between the functions,
-      ;; return that continuation.
-      (define (find-common-continuation)
-        (let visit-syms ((syms syms) (k #f))
-          (match syms
-            (() k)
-            ((sym . syms)
-             (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
-               (match uses
-                 (() (visit-syms syms k))
-                 ((use . uses)
-                  (and=> (call-target use sym)
-                         (lambda (k*)
-                           (cond
-                            ((memq k* tails) (visit-uses uses k))
-                            ((not k) (visit-uses uses k*))
-                            ((eq? k k*) (visit-uses uses k))
-                            (else #f)))))))))))
-
-      ;; Given that the functions are called with the common
-      ;; continuation K, determine the scope at which to contify the
-      ;; functions.  If K is in scope in the term, we go ahead and
-      ;; contify them there.  Otherwise the scope is inside the letrec
-      ;; body, and so choose the scope in which the continuation is
-      ;; defined, whose free variables are a superset of the free
-      ;; variables of the functions.
-      ;;
-      ;; There is some slight trickiness here.  Call-target already uses
-      ;; the information we compute within this pass.  Previous
-      ;; contifications may cause functions to be contified not at their
-      ;; point of definition but at their point of non-recursive use.
-      ;; That will cause the scope nesting to change.  (It may
-      ;; effectively push a function deeper down the tree -- the second
-      ;; case above, a call within the letrec body.)  What if we contify
-      ;; to the tail of a previously contified function?  We have to
-      ;; track what the new scope tree will be when asking whether K
-      ;; will be bound in TERM-K's scope, not the scope tree that
-      ;; existed when we started the pass.
-      ;;
-      ;; FIXME: Does this choose the right scope for contified let-bound
-      ;; functions?
-      (define (find-contification-scope k)
-        (define (scope-contains? scope k)
-          (let ((k-scope (or (hashq-ref scope-table k)
-                             (let ((k-scope (lookup-block-scope k dfg)))
-                               (hashq-set! scope-table k k-scope)
-                               k-scope))))
-            (or (eq? scope k-scope)
-                (and k-scope (scope-contains? scope k-scope)))))
-
-        ;; Find the scope of K.
-        (define (continuation-scope k)
-          (or (hashq-ref scope-table k)
-              (let ((scope (lookup-block-scope k dfg)))
-                (hashq-set! scope-table k scope)
-                scope)))
-
-        (let ((k-scope (continuation-scope k)))
-          (if (scope-contains? k-scope term-k)
-              term-k
-              (match (lookup-cont k-scope dfg)
-                (($ $kfun src meta self tail clause)
-                 ;; K is the tail of some function.  If that function
-                 ;; has just one clause, return that clause.  Otherwise
-                 ;; bail.
-                 (match clause
-                   (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
-                    kargs)
-                   (_ #f)))
-                (_ k-scope)))))
-
-      ;; We are going to contify.  Mark all SYMs for replacement in
-      ;; calls, and mark the tail continuations for replacement by K.
-      ;; Arrange for the continuations to be spliced into SCOPE.
-      (define (enqueue-contification! k scope)
-        (for-each (lambda (sym tail arities bodies)
-                    (match bodies
-                      ((($ $cont body-k) ...)
-                       (subst-call! sym arities body-k)))
-                    (subst-return! tail k))
-                  syms tails arities bodies)
-        (splice-conts! scope (concatenate bodies))
-        #t)
-
-      ;; "Call me maybe"
-      (and (and-map unused? selfs)
-           (and=> (find-common-continuation)
-                  (lambda (k)
-                    (and=> (find-contification-scope k)
-                           (cut enqueue-contification! k <>))))))
-
-    (define (visit-fun term)
-      (match term
-        (($ $fun body)
-         (visit-cont body))))
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont sym ($ $kargs _ _ body))
-         (visit-term body sym))
-        (($ $cont sym ($ $kfun src meta self tail clause))
-         (when clause (visit-cont clause)))
-        (($ $cont sym ($ $kclause arity body alternate))
-         (visit-cont body)
-         (when alternate (visit-cont alternate)))
-        (($ $cont)
-         #t)))
-    (define (visit-term term term-k)
-      (match term
-        (($ $letk conts body)
-         (for-each visit-cont conts)
-         (visit-term body term-k))
-        (($ $continue k src exp)
-         (match exp
-           (($ $fun
-               ($ $cont fun-k
-                  ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
-            (if (and=> (bound-symbol k)
-                       (lambda (sym)
-                         (contify-fun term-k sym self tail-k
-                                      (extract-arities clause)
-                                      (extract-bodies clause))))
-                (begin
-                  (for-each visit-cont (extract-bodies clause)))
-                (visit-fun exp)))
-           (($ $rec names syms funs)
-            (define (split-components nsf)
-              ;; FIXME: Compute strongly-connected components.  Currently
-              ;; we just put non-recursive functions in their own
-              ;; components, and lump everything else in the remaining
-              ;; component.
-              (define (recursive? k)
-                (or-map (cut variable-free-in? <> k dfg) syms))
-              (let lp ((nsf nsf) (rec '()))
-                (match nsf
-                  (()
-                   (if (null? rec)
-                       '()
-                       (list rec)))
-                  (((and elt (n s ($ $fun ($ $cont kfun))))
-                    . nsf)
-                   (if (recursive? kfun)
-                       (lp nsf (cons elt rec))
-                       (cons (list elt) (lp nsf rec)))))))
-            (define (extract-arities+bodies clauses)
-              (values (map extract-arities clauses)
-                      (map extract-bodies clauses)))
-            (define (visit-component component)
-              (match component
-                (((name sym fun) ...)
-                 (match fun
-                   ((($ $fun
-                        ($ $cont fun-k
-                           ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
-                              clause)))
-                     ...)
-                    (call-with-values (lambda () (extract-arities+bodies clause))
-                      (lambda (arities bodies)
-                        ;; Technically the procedures are created in
-                        ;; term-k but bound for use in k.  But, there is
-                        ;; a tight link between term-k and k, as they
-                        ;; are in the same block.  Mark k as the
-                        ;; contification scope, because that's where
-                        ;; they'll be used.  Perhaps we can fix this
-                        ;; with the new CPS dialect that doesn't have
-                        ;; $letk.
-                        (if (contify-funs k sym self tail-k arities bodies)
-                            (for-each (cut for-each visit-cont <>) bodies)
-                            (for-each visit-fun fun)))))))))
-            (for-each visit-component
-                      (split-components (map list names syms funs))))
-           (_ #t)))))
-
-    (visit-cont fun)
-    (values call-substs cont-substs cont-splices)))
-
-(define (apply-contification fun call-substs cont-substs cont-splices)
-  (define (contify-call src proc args)
-    (and=> (assq-ref call-substs proc)
-           (lambda (clauses)
-             (let lp ((clauses clauses))
-               (match clauses
-                 (() (error "invalid contification"))
-                 (((($ $arity req () #f () #f) . k) . clauses)
-                  (if (= (length req) (length args))
-                      (build-cps-term
-                        ($continue k src
-                          ($values args)))
-                      (lp clauses)))
-                 ((_ . clauses) (lp clauses)))))))
-  (define (continue k src exp)
-    (define (lookup-return-cont k)
-      (match (assq-ref cont-substs k)
-        (#f k)
-        (k (lookup-return-cont k))))
-    (let ((k* (lookup-return-cont k)))
-      ;; We are contifying this return.  It must be a call or a
-      ;; primcall to values, return, or return-values.
-      (if (eq? k k*)
-          (build-cps-term ($continue k src ,exp))
-          (rewrite-cps-term exp
-            (($ $primcall 'return (val))
-             ($continue k* src ($primcall 'values (val))))
-            (($ $values vals)
-             ($continue k* src ($primcall 'values vals)))
-            (_ ($continue k* src ,exp))))))
-  (define (splice-continuations term-k term)
-    (match (hashq-ref cont-splices term-k)
-      (#f term)
-      ((cont ...)
-       (let lp ((term term))
-         (rewrite-cps-term term
-           (($ $letk conts* body)
-            ($letk ,(append conts* (filter-map visit-cont cont))
-              ,body))
-           (body
-            ($letk ,(filter-map visit-cont cont)
-              ,body)))))))
-  (define (visit-fun term)
-    (rewrite-cps-exp term
-      (($ $fun body)
-       ($fun ,(visit-cont body)))))
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs names syms body))
-       ;; Remove bindings for functions that have been contified.
-       ,(rewrite-cps-cont (filter (match-lambda
-                                   ((name sym) (not (assq sym call-substs))))
-                                  (map list names syms))
-          (((names syms) ...)
-           (label ($kargs names syms ,(visit-term body label))))))
-      (($ $cont label ($ $kfun src meta self tail clause))
-       (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
-      (($ $cont label ($ $kclause arity body alternate))
-       (label ($kclause ,arity ,(visit-cont body)
-                        ,(and alternate (visit-cont alternate)))))
-      (($ $cont)
-       ,cont)))
-  (define (visit-term term term-k)
-    (match term
-      (($ $letk conts body)
-       ;; Visit the body first, so we rewrite depth-first.
-       (let lp ((body (visit-term body term-k)))
-         ;; Because we attach contified functions on a particular
-         ;; term-k, and one term-k can correspond to an arbitrarily
-         ;; nested sequence of $letk instances, normalize so that all
-         ;; continuations are bound by one $letk -- guaranteeing that
-         ;; they are in the same scope.
-         (rewrite-cps-term body
-           (($ $letk conts* body)
-            ($letk ,(append conts* (filter-map visit-cont conts))
-              ,body))
-           (body
-            ($letk ,(filter-map visit-cont conts)
-              ,body)))))
-      (($ $continue k src exp)
-       (splice-continuations
-        term-k
-        (match exp
-          (($ $fun 
-              ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
-           ;; If the function's tail continuation has been substituted,
-           ;; that means it has been contified.
-           (continue k src
-                     (if (assq tail-k cont-substs)
-                         (build-cps-exp ($values ()))
-                         (visit-fun exp))))
-          (($ $rec names syms funs)
-           (match (filter (match-lambda
-                           ((n s f) (not (assq s call-substs))))
-                          (map list names syms funs))
-             (() (continue k src (build-cps-exp ($values ()))))
-             (((names syms funs) ...)
-              (continue k src
-                        (build-cps-exp
-                          ($rec names syms (map visit-fun funs)))))))
-          (($ $call proc args)
-           (or (contify-call src proc args)
-               (continue k src exp)))
-          (_ (continue k src exp)))))))
-  (visit-cont fun))
-
-(define (contify fun)
-  (call-with-values (lambda () (compute-contification fun))
-    (lambda (call-substs cont-substs cont-splices)
-      (if (null? call-substs)
-          fun
-          ;; Iterate to fixed point.
-          (contify
-           (apply-contification fun call-substs cont-substs cont-splices))))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
deleted file mode 100644
index c8a57ca0b..000000000
--- a/module/language/cps/cse.scm
+++ /dev/null
@@ -1,545 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Common subexpression elimination for CPS.
-;;;
-;;; Code:
-
-(define-module (language cps cse)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps effects-analysis)
-  #:use-module (language cps renumber)
-  #:use-module (language cps intset)
-  #:use-module (rnrs bytevectors)
-  #:export (eliminate-common-subexpressions))
-
-(define (cont-successors cont)
-  (match cont
-    (($ $kargs names syms body)
-     (let lp ((body body))
-       (match body
-         (($ $letk conts body) (lp body))
-         (($ $continue k src exp)
-          (match exp
-            (($ $prompt escape? tag handler) (list k handler))
-            (($ $branch kt) (list k kt))
-            (_ (list k)))))))
-
-    (($ $kreceive arity k) (list k))
-
-    (($ $kclause arity ($ $cont kbody)) (list kbody))
-
-    (($ $kfun src meta self tail clause)
-     (let lp ((clause clause))
-       (match clause
-         (($ $cont kclause ($ $kclause _ _ alt))
-          (cons kclause (lp alt)))
-         (#f '()))))
-
-    (($ $kfun src meta self tail #f) '())
-
-    (($ $ktail) '())))
-
-(define (compute-available-expressions dfg min-label label-count idoms)
-  "Compute and return the continuations that may be reached if flow
-reaches a continuation N.  Returns a vector of intsets, whose first
-index corresponds to MIN-LABEL, and so on."
-  (let* ((effects (compute-effects dfg min-label label-count))
-         ;; Vector of intsets, indicating that at a continuation N, the
-         ;; values from continuations M... are available.
-         (avail (make-vector label-count #f))
-         (revisit-label #f))
-
-    (define (label->idx label) (- label min-label))
-    (define (idx->label idx) (+ idx min-label))
-    (define (get-effects label) (vector-ref effects (label->idx label)))
-
-    (define (propagate! pred succ out)
-      (let* ((succ-idx (label->idx succ))
-             (in (match (lookup-predecessors succ dfg)
-                   ;; Fast path: normal control flow.
-                   ((_) out)
-                   ;; Slow path: control-flow join.
-                   (_ (cond
-                       ((vector-ref avail succ-idx)
-                        => (lambda (in)
-                             (intset-intersect in out)))
-                       (else out))))))
-        (when (and (<= succ pred)
-                   (or (not revisit-label) (< succ revisit-label))
-                   (not (eq? in (vector-ref avail succ-idx))))
-          ;; Arrange to revisit if this is not a forward edge and the
-          ;; available set changed.
-          (set! revisit-label succ))
-        (vector-set! avail succ-idx in)))
-
-    (define (clobber label in)
-      (let ((fx (get-effects label)))
-        (cond
-         ((not (causes-effect? fx &write))
-          ;; Fast-path if this expression clobbers nothing.
-          in)
-         (else
-          ;; Kill clobbered expressions.  There is no need to check on
-          ;; any label before than the last dominating label that
-          ;; clobbered everything.
-          (let ((first (let lp ((dom label))
-                         (let* ((dom (vector-ref idoms (label->idx dom))))
-                           (and (< min-label dom)
-                                (let ((fx (vector-ref effects (label->idx dom))))
-                                  (if (causes-all-effects? fx)
-                                      dom
-                                      (lp dom))))))))
-            (let lp ((i first) (in in))
-              (cond
-               ((intset-next in i)
-                => (lambda (i)
-                     (if (effect-clobbers? fx (vector-ref effects (label->idx i)))
-                         (lp (1+ i) (intset-remove in i))
-                         (lp (1+ i) in))))
-               (else in))))))))
-
-    (synthesize-definition-effects! effects dfg min-label label-count)
-
-    (vector-set! avail 0 empty-intset)
-
-    (let lp ((n 0))
-      (cond
-       ((< n label-count)
-        (let* ((label (idx->label n))
-               ;; It's possible for "in" to be #f if it has no
-               ;; predecessors, as is the case for the ktail of a
-               ;; function with an iloop.
-               (in (or (vector-ref avail n) empty-intset))
-               (out (intset-add (clobber label in) label)))
-          (lookup-predecessors label dfg)
-          (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
-            (match succs
-              (() (lp (1+ n)))
-              ((succ . succs)
-               (propagate! label succ out)
-               (visit-succs succs))))))
-       (revisit-label
-        (let ((n (label->idx revisit-label)))
-          (set! revisit-label #f)
-          (lp n)))
-       (else
-        (values avail effects))))))
-
-(define (compute-truthy-expressions dfg min-label label-count)
-  "Compute a \"truth map\", indicating which expressions can be shown to
-be true and/or false at each of LABEL-COUNT expressions in DFG, starting
-from MIN-LABEL.  Returns a vector of intsets, each intset twice as long
-as LABEL-COUNT.  The even elements of the intset indicate labels that
-may be true, and the odd ones indicate those that may be false.  It
-could be that both true and false proofs are available."
-  (let ((boolv (make-vector label-count #f))
-        (revisit-label #f))
-    (define (label->idx label) (- label min-label))
-    (define (idx->label idx) (+ idx min-label))
-    (define (true-idx idx) (ash idx 1))
-    (define (false-idx idx) (1+ (ash idx 1)))
-
-    (define (propagate! pred succ out)
-      (let* ((succ-idx (label->idx succ))
-             (in (match (lookup-predecessors succ dfg)
-                   ;; Fast path: normal control flow.
-                   ((_) out)
-                   ;; Slow path: control-flow join.
-                   (_ (cond
-                       ((vector-ref boolv succ-idx)
-                        => (lambda (in)
-                             (intset-intersect in out)))
-                       (else out))))))
-        (when (and (<= succ pred)
-                   (or (not revisit-label) (< succ revisit-label))
-                   (not (eq? in (vector-ref boolv succ-idx))))
-          (set! revisit-label succ))
-        (vector-set! boolv succ-idx in)))
-
-    (vector-set! boolv 0 empty-intset)
-
-    (let lp ((n 0))
-      (cond
-       ((< n label-count)
-        (let* ((label (idx->label n))
-               ;; It's possible for "in" to be #f if it has no
-               ;; predecessors, as is the case for the ktail of a
-               ;; function with an iloop.
-               (in (or (vector-ref boolv n) empty-intset)))
-          (define (default-propagate)
-            (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
-              (match succs
-                (() (lp (1+ n)))
-                ((succ . succs)
-                 (propagate! label succ in)
-                 (visit-succs succs)))))
-          (match (lookup-cont label dfg)
-            (($ $kargs names syms body)
-             (match (find-call body)
-               (($ $continue k src ($ $branch kt))
-                (propagate! label k (intset-add in (false-idx n)))
-                (propagate! label kt (intset-add in (true-idx n)))
-                (lp (1+ n)))
-               (_ (default-propagate))))
-            (_ (default-propagate)))))
-       (revisit-label
-        (let ((n (label->idx revisit-label)))
-          (set! revisit-label #f)
-          (lp n)))
-       (else boolv)))))
-
-;; Returns a map of label-idx -> (var-idx ...) indicating the variables
-;; defined by a given labelled expression.
-(define (compute-defs dfg min-label label-count)
-  (define (cont-defs k)
-    (match (lookup-cont k dfg)
-      (($ $kargs names vars) vars)
-      (_ '())))
-  (define (idx->label idx) (+ idx min-label))
-  (let ((defs (make-vector label-count '())))
-    (let lp ((n 0))
-      (when (< n label-count)
-        (vector-set!
-         defs
-         n
-         (match (lookup-cont (idx->label n) dfg)
-           (($ $kargs _ _ body)
-            (match (find-call body)
-              (($ $continue k) (cont-defs k))))
-           (($ $kreceive arity kargs)
-            (cont-defs kargs))
-           (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
-            syms)
-           (($ $kfun src meta self) (list self))
-           (($ $ktail) '())))
-        (lp (1+ n))))
-    defs))
-
-(define (compute-label-and-var-ranges fun)
-  (match fun
-    (($ $cont kfun ($ $kfun src meta self))
-     ((make-local-cont-folder min-label label-count min-var var-count)
-      (lambda (k cont min-label label-count min-var var-count)
-        (let ((min-label (min k min-label))
-              (label-count (1+ label-count)))
-          (match cont
-            (($ $kargs names vars body)
-             (values min-label label-count
-                     (fold min min-var vars) (+ var-count (length vars))))
-            (($ $kfun src meta self)
-             (values min-label label-count (min self min-var) (1+ var-count)))
-            (_
-             (values min-label label-count min-var var-count)))))
-      fun kfun 0 self 0))))
-
-;; Compute a vector containing, for each node, a list of the nodes that
-;; it immediately dominates.  These are the "D" edges in the DJ tree.
-
-(define (compute-equivalent-subexpressions fun dfg)
-  (define (compute min-label label-count min-var var-count idoms avail effects)
-    (let ((defs (compute-defs dfg min-label label-count))
-          (var-substs (make-vector var-count #f))
-          (equiv-labels (make-vector label-count #f))
-          (equiv-set (make-hash-table)))
-      (define (idx->label idx) (+ idx min-label))
-      (define (label->idx label) (- label min-label))
-      (define (idx->var idx) (+ idx min-var))
-      (define (var->idx var) (- var min-var))
-
-      (define (for-each/2 f l1 l2)
-        (unless (= (length l1) (length l2))
-          (error "bad lengths" l1 l2))
-        (let lp ((l1 l1) (l2 l2))
-          (when (pair? l1)
-            (f (car l1) (car l2))
-            (lp (cdr l1) (cdr l2)))))
-
-      (define (subst-var var)
-        ;; It could be that the var is free in this function; if so, its
-        ;; name will be less than min-var.
-        (let ((idx (var->idx var)))
-          (if (<= 0 idx)
-              (vector-ref var-substs idx)
-              var)))
-
-      (define (compute-exp-key exp)
-        (match exp
-          (($ $const val) (cons 'const val))
-          (($ $prim name) (cons 'prim name))
-          (($ $fun body) #f)
-          (($ $rec names syms funs) #f)
-          (($ $call proc args) #f)
-          (($ $callk k proc args) #f)
-          (($ $primcall name args)
-           (cons* 'primcall name (map subst-var args)))
-          (($ $branch _ ($ $primcall name args))
-           (cons* 'primcall name (map subst-var args)))
-          (($ $branch) #f)
-          (($ $values args) #f)
-          (($ $prompt escape? tag handler) #f)))
-
-      (define (add-auxiliary-definitions! label exp-key)
-        (let ((defs (vector-ref defs (label->idx label))))
-          (define (add-def! aux-key var)
-            (let ((equiv (hash-ref equiv-set aux-key '())))
-              (hash-set! equiv-set aux-key
-                         (acons label (list var) equiv))))
-          (match exp-key
-            (('primcall 'box val)
-             (match defs
-               ((box)
-                (add-def! `(primcall box-ref ,(subst-var box)) val))))
-            (('primcall 'box-set! box val)
-             (add-def! `(primcall box-ref ,box) val))
-            (('primcall 'cons car cdr)
-             (match defs
-               ((pair)
-                (add-def! `(primcall car ,(subst-var pair)) car)
-                (add-def! `(primcall cdr ,(subst-var pair)) cdr))))
-            (('primcall 'set-car! pair car)
-             (add-def! `(primcall car ,pair) car))
-            (('primcall 'set-cdr! pair cdr)
-             (add-def! `(primcall cdr ,pair) cdr))
-            (('primcall (or 'make-vector 'make-vector/immediate) len fill)
-             (match defs
-               ((vec)
-                (add-def! `(primcall vector-length ,(subst-var vec)) len))))
-            (('primcall 'vector-set! vec idx val)
-             (add-def! `(primcall vector-ref ,vec ,idx) val))
-            (('primcall 'vector-set!/immediate vec idx val)
-             (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
-            (('primcall (or 'allocate-struct 'allocate-struct/immediate)
-                        vtable size)
-             (match defs
-               (() #f) ;; allocate-struct in tail or kreceive position.
-               ((struct)
-                (add-def! `(primcall struct-vtable ,(subst-var struct))
-                          vtable))))
-            (('primcall 'struct-set! struct n val)
-             (add-def! `(primcall struct-ref ,struct ,n) val))
-            (('primcall 'struct-set!/immediate struct n val)
-             (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
-            (_ #t))))
-
-      ;; The initial substs vector is the identity map.
-      (let lp ((var min-var))
-        (when (< (var->idx var) var-count)
-          (vector-set! var-substs (var->idx var) var)
-          (lp (1+ var))))
-
-      ;; Traverse the labels in fun in forward order, which will visit
-      ;; dominators first.
-      (let lp ((label min-label))
-        (when (< (label->idx label) label-count)
-          (match (lookup-cont label dfg)
-            (($ $kargs names vars body)
-             (match (find-call body)
-               (($ $continue k src exp)
-                (let* ((exp-key (compute-exp-key exp))
-                       (equiv (hash-ref equiv-set exp-key '()))
-                       (lidx (label->idx label))
-                       (fx (vector-ref effects lidx))
-                       (avail (vector-ref avail lidx)))
-                  (let lp ((candidates equiv))
-                    (match candidates
-                      (()
-                       ;; No matching expressions.  Add our expression
-                       ;; to the equivalence set, if appropriate.  Note
-                       ;; that expressions that allocate a fresh object
-                       ;; or change the current fluid environment can't
-                       ;; be eliminated by CSE (though DCE might do it
-                       ;; if the value proves to be unused, in the
-                       ;; allocation case).
-                       (when (and exp-key
-                                  (not (causes-effect? fx &allocation))
-                                  (not (effect-clobbers?
-                                        fx
-                                        (&read-object &fluid))))
-                         (hash-set! equiv-set exp-key
-                                    (acons label (vector-ref defs lidx)
-                                           equiv))))
-                      (((and head (candidate . vars)) . candidates)
-                       (cond
-                        ((not (intset-ref avail candidate))
-                         ;; This expression isn't available here; try
-                         ;; the next one.
-                         (lp candidates))
-                        (else
-                         ;; Yay, a match.  Mark expression as equivalent.
-                         (vector-set! equiv-labels lidx head)
-                         ;; If we dominate the successor, mark vars
-                         ;; for substitution.
-                         (when (= label (vector-ref idoms (label->idx k)))
-                           (for-each/2
-                            (lambda (var subst-var)
-                              (vector-set! var-substs (var->idx var) subst-var))
-                            (vector-ref defs lidx)
-                            vars)))))))
-                  ;; If this expression defines auxiliary definitions,
-                  ;; as `cons' does for the results of `car' and `cdr',
-                  ;; define those.  Do so after finding equivalent
-                  ;; expressions, so that we can take advantage of
-                  ;; subst'd output vars.
-                  (add-auxiliary-definitions! label exp-key)))))
-            (_ #f))
-          (lp (1+ label))))
-      (values (compute-dom-edges idoms min-label)
-              equiv-labels min-label var-substs min-var)))
-
-  (call-with-values (lambda () (compute-label-and-var-ranges fun))
-    (lambda (min-label label-count min-var var-count)
-      (let ((idoms (compute-idoms dfg min-label label-count)))
-        (call-with-values
-            (lambda ()
-              (compute-available-expressions dfg min-label label-count idoms))
-          (lambda (avail effects)
-            (compute min-label label-count min-var var-count
-                     idoms avail effects)))))))
-
-(define (apply-cse fun dfg
-                   doms equiv-labels min-label var-substs min-var boolv)
-  (define (idx->label idx) (+ idx min-label))
-  (define (label->idx label) (- label min-label))
-  (define (idx->var idx) (+ idx min-var))
-  (define (var->idx var) (- var min-var))
-  (define (true-idx idx) (ash idx 1))
-  (define (false-idx idx) (1+ (ash idx 1)))
-
-  (define (subst-var var)
-    ;; It could be that the var is free in this function; if so,
-    ;; its name will be less than min-var.
-    (let ((idx (var->idx var)))
-      (if (<= 0 idx)
-          (vector-ref var-substs idx)
-          var)))
-
-  (define (visit-fun-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kfun src meta self tail clause))
-       (label ($kfun src meta self ,tail
-                ,(and clause (visit-fun-cont clause)))))
-      (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
-       (label ($kclause ,arity ,(visit-cont kbody body)
-                        ,(and alternate (visit-fun-cont alternate)))))))
-
-  (define (visit-cont label cont)
-    (rewrite-cps-cont cont
-      (($ $kargs names vars body)
-       (label ($kargs names vars ,(visit-term body label))))
-      (_ (label ,cont))))
-
-  (define (visit-term term label)
-    (define (visit-exp exp)
-      ;; We shouldn't see $fun here.
-      (rewrite-cps-exp exp
-        ((or ($ $const) ($ $prim)) ,exp)
-        (($ $call proc args)
-         ($call (subst-var proc) ,(map subst-var args)))
-        (($ $callk k proc args)
-         ($callk k (subst-var proc) ,(map subst-var args)))
-        (($ $primcall name args)
-         ($primcall name ,(map subst-var args)))
-        (($ $branch k exp)
-         ($branch k ,(visit-exp exp)))
-        (($ $values args)
-         ($values ,(map subst-var args)))
-        (($ $prompt escape? tag handler)
-         ($prompt escape? (subst-var tag) handler))))
-
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun body)
-         ($fun ,(cse body dfg)))))
-
-    (define (visit-exp* k src exp)
-      (match exp
-        (($ $fun)
-         (build-cps-term
-           ($continue k src ,(visit-fun exp))))
-        (($ $rec names syms funs)
-         (build-cps-term
-           ($continue k src ($rec names syms (map visit-fun funs)))))
-        (_
-         (cond
-          ((vector-ref equiv-labels (label->idx label))
-           => (match-lambda
-               ((equiv . vars)
-                (let* ((eidx (label->idx equiv)))
-                  (match exp
-                    (($ $branch kt exp)
-                     (let* ((bool (vector-ref boolv (label->idx label)))
-                            (t (intset-ref bool (true-idx eidx)))
-                            (f (intset-ref bool (false-idx eidx))))
-                       (if (eqv? t f)
-                           (build-cps-term
-                             ($continue k src
-                               ($branch kt ,(visit-exp exp))))
-                           (build-cps-term
-                             ($continue (if t kt k) src ($values ()))))))
-                    (_
-                     ;; FIXME: can we always continue with $values?  why
-                     ;; or why not?
-                     (rewrite-cps-term (lookup-cont k dfg)
-                       (($ $kargs)
-                        ($continue k src ($values vars)))
-                       (_
-                        ($continue k src ,(visit-exp exp))))))))))
-          (else
-           (build-cps-term
-             ($continue k src ,(visit-exp exp))))))))
-
-    (define (visit-dom-conts label)
-      (let ((cont (lookup-cont label dfg)))
-        (match cont
-          (($ $ktail) '())
-          (($ $kargs) (list (visit-cont label cont)))
-          (else
-           (cons (visit-cont label cont)
-                 (append-map visit-dom-conts
-                             (vector-ref doms (label->idx label))))))))
-
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ,(visit-term body label))
-      (($ $continue k src exp)
-       ,(let ((conts (append-map visit-dom-conts
-                                 (vector-ref doms (label->idx label)))))
-          (if (null? conts)
-              (visit-exp* k src exp)
-              (build-cps-term
-                ($letk ,conts ,(visit-exp* k src exp))))))))
-
-  (visit-fun-cont fun))
-
-(define (cse fun dfg)
-  (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
-    (lambda (doms equiv-labels min-label var-substs min-var)
-      (apply-cse fun dfg doms equiv-labels min-label var-substs min-var
-                 (compute-truthy-expressions dfg
-                                             min-label (vector-length doms))))))
-
-(define (eliminate-common-subexpressions fun)
-  (call-with-values (lambda () (renumber fun))
-    (lambda (fun nlabels nvars)
-      (cse fun (compute-dfg fun)))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
deleted file mode 100644
index 34ffc3a47..000000000
--- a/module/language/cps/dce.scm
+++ /dev/null
@@ -1,363 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Various optimizations can inline calls from one continuation to some
-;;; other continuation, usually in response to information about the
-;;; return arity of the call.  That leaves us with dangling
-;;; continuations that aren't reachable any more from the procedure
-;;; entry.  This pass will remove them.
-;;;
-;;; This pass also kills dead expressions: code that has no side
-;;; effects, and whose value is unused.  It does so by marking all live
-;;; values, and then discarding other values as dead.  This happens
-;;; recursively through procedures, so it should be possible to elide
-;;; dead procedures as well.
-;;;
-;;; Code:
-
-(define-module (language cps dce)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps effects-analysis)
-  #:use-module (language cps renumber)
-  #:use-module (language cps types)
-  #:export (eliminate-dead-code))
-
-(define-record-type $fun-data
-  (make-fun-data min-label effects live-conts defs)
-  fun-data?
-  (min-label fun-data-min-label)
-  (effects fun-data-effects)
-  (live-conts fun-data-live-conts)
-  (defs fun-data-defs))
-
-(define (compute-defs dfg min-label label-count)
-  (define (cont-defs k)
-    (match (lookup-cont k dfg)
-      (($ $kargs names vars) vars)
-      (_ #f)))
-  (define (idx->label idx) (+ idx min-label))
-  (let ((defs (make-vector label-count #f)))
-    (let lp ((n 0))
-      (when (< n label-count)
-        (vector-set!
-         defs
-         n
-         (match (lookup-cont (idx->label n) dfg)
-           (($ $kargs _ _ body)
-            (match (find-call body)
-              (($ $continue k src exp)
-               (match exp
-                 (($ $branch) #f)
-                 (_ (cont-defs k))))))
-           (($ $kreceive arity kargs)
-            (cont-defs kargs))
-           (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
-            syms)
-           (($ $kfun src meta self) (list self))
-           (($ $ktail) #f)))
-        (lp (1+ n))))
-    defs))
-
-(define (elide-type-checks! fun dfg effects min-label label-count)
-  (match fun
-    (($ $cont kfun ($ $kfun src meta min-var))
-     (let ((typev (infer-types fun dfg)))
-       (define (idx->label idx) (+ idx min-label))
-       (define (var->idx var) (- var min-var))
-       (define (visit-primcall lidx fx name args)
-         (when (primcall-types-check? typev (idx->label lidx) name args)
-           (vector-set! effects lidx
-                        (logand fx (lognot &type-check)))))
-       (let lp ((lidx 0))
-         (when (< lidx label-count)
-           (let ((fx (vector-ref effects lidx)))
-             (unless (causes-all-effects? fx)
-               (when (causes-effect? fx &type-check)
-                 (match (lookup-cont (idx->label lidx) dfg)
-                   (($ $kargs _ _ term)
-                    (match (find-call term)
-                      (($ $continue k src ($ $primcall name args))
-                       (visit-primcall lidx fx name args))
-                      (($ $continue k src ($ $branch _ ($primcall name args)))
-                       (visit-primcall lidx fx name args))
-                      (_ #f)))
-                   (_ #f)))))
-           (lp (1+ lidx))))))))
-
-(define (compute-live-code fun)
-  (let* ((fun-data-table (make-hash-table))
-         (dfg (compute-dfg fun #:global? #t))
-         (live-vars (make-bitvector (dfg-var-count dfg) #f))
-         (changed? #f))
-    (define (mark-live! var)
-      (unless (value-live? var)
-        (set! changed? #t)
-        (bitvector-set! live-vars var #t)))
-    (define (value-live? var)
-      (bitvector-ref live-vars var))
-    (define (ensure-fun-data fun)
-      (or (hashq-ref fun-data-table fun)
-          (call-with-values (lambda ()
-                              ((make-local-cont-folder label-count max-label)
-                               (lambda (k cont label-count max-label)
-                                 (values (1+ label-count) (max k max-label)))
-                               fun 0 -1))
-            (lambda (label-count max-label)
-              (let* ((min-label (- (1+ max-label) label-count))
-                     (effects (compute-effects dfg min-label label-count))
-                     (live-conts (make-bitvector label-count #f))
-                     (defs (compute-defs dfg min-label label-count))
-                     (fun-data (make-fun-data
-                                min-label effects live-conts defs)))
-                (elide-type-checks! fun dfg effects min-label label-count)
-                (hashq-set! fun-data-table fun fun-data)
-                (set! changed? #t)
-                fun-data)))))
-    (define (visit-fun fun)
-      (match (ensure-fun-data fun)
-        (($ $fun-data min-label effects live-conts defs)
-         (define (idx->label idx) (+ idx min-label))
-         (define (label->idx label) (- label min-label))
-         (define (known-allocation? var dfg)
-           (match (lookup-predecessors (lookup-def var dfg) dfg)
-             ((def-exp-k)
-              (match (lookup-cont def-exp-k dfg)
-                (($ $kargs _ _ term)
-                 (match (find-call term)
-                   (($ $continue k src ($ $values (var)))
-                    (known-allocation? var dfg))
-                   (($ $continue k src ($ $primcall))
-                    (let ((kidx (label->idx def-exp-k)))
-                      (and (>= kidx 0)
-                           (causes-effect? (vector-ref effects kidx)
-                                           &allocation))))
-                   (_ #f)))
-                (_ #f)))
-             (_ #f)))
-         (define (visit-grey-exp n exp)
-           (let ((defs (vector-ref defs n))
-                 (fx (vector-ref effects n)))
-             (or
-              ;; No defs; perhaps continuation is $ktail.
-              (not defs)
-              ;; Do we have a live def?
-              (or-map value-live? defs)
-              ;; Does this expression cause all effects?  If so, it's
-              ;; definitely live.
-              (causes-all-effects? fx)
-              ;; Does it cause a type check, but we weren't able to
-              ;; prove that the types check?
-              (causes-effect? fx &type-check)
-              ;; We might have a setter.  If the object being assigned
-              ;; to is live or was not created by us, then this
-              ;; expression is live.  Otherwise the value is still dead.
-              (and (causes-effect? fx &write)
-                   (match exp
-                     (($ $primcall
-                         (or 'vector-set! 'vector-set!/immediate
-                             'set-car! 'set-cdr!
-                             'box-set!)
-                         (obj . _))
-                      (or (value-live? obj)
-                          (not (known-allocation? obj dfg))))
-                     (_ #t))))))
-         (let lp ((n (1- (vector-length effects))))
-           (unless (< n 0)
-             (let ((cont (lookup-cont (idx->label n) dfg)))
-               (match cont
-                 (($ $kargs _ _ body)
-                  (let lp ((body body))
-                    (match body
-                      (($ $letk conts body) (lp body))
-                      (($ $continue k src exp)
-                       (unless (bitvector-ref live-conts n)
-                         (when (visit-grey-exp n exp)
-                           (set! changed? #t)
-                           (bitvector-set! live-conts n #t)))
-                       (when (bitvector-ref live-conts n)
-                         (match exp
-                           ((or ($ $const) ($ $prim))
-                            #f)
-                           (($ $fun body)
-                            (visit-fun body))
-                           (($ $rec names syms funs)
-                            (for-each (lambda (sym fun)
-                                        (when (value-live? sym)
-                                          (match fun
-                                            (($ $fun body)
-                                             (visit-fun body)))))
-                                      syms funs))
-                           (($ $prompt escape? tag handler)
-                            (mark-live! tag))
-                           (($ $call proc args)
-                            (mark-live! proc)
-                            (for-each mark-live! args))
-                           (($ $callk k proc args)
-                            (mark-live! proc)
-                            (for-each mark-live! args))
-                           (($ $primcall name args)
-                            (for-each mark-live! args))
-                           (($ $branch k ($ $primcall name args))
-                            (for-each mark-live! args))
-                           (($ $branch k ($ $values (arg)))
-                            (mark-live! arg))
-                           (($ $values args)
-                            (match (vector-ref defs n)
-                              (#f (for-each mark-live! args))
-                              (defs (for-each (lambda (use def)
-                                                (when (value-live? def)
-                                                  (mark-live! use)))
-                                              args defs))))))))))
-                 (($ $kreceive arity kargs) #f)
-                 (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
-                  (for-each mark-live! syms))
-                 (($ $kfun src meta self)
-                  (mark-live! self))
-                 (($ $ktail) #f))
-               (lp (1- n))))))))
-    (unless (= (dfg-var-count dfg) (var-counter))
-      (error "internal error" (dfg-var-count dfg) (var-counter)))
-    (let lp ()
-      (set! changed? #f)
-      (visit-fun fun)
-      (when changed? (lp)))
-    (values fun-data-table live-vars)))
-
-(define (process-eliminations fun fun-data-table live-vars)
-  (define (value-live? var)
-    (bitvector-ref live-vars var))
-  (define (make-adaptor name k defs)
-    (let* ((names (map (lambda (_) 'tmp) defs))
-           (syms (map (lambda (_) (fresh-var)) defs))
-           (live (filter-map (lambda (def sym)
-                               (and (value-live? def)
-                                    sym))
-                             defs syms)))
-      (build-cps-cont
-        (name ($kargs names syms
-                ($continue k #f ($values live)))))))
-  (define (visit-fun fun)
-    (match (hashq-ref fun-data-table fun)
-      (($ $fun-data min-label effects live-conts defs)
-       (define (label->idx label) (- label min-label))
-       (define (visit-cont cont)
-         (match (visit-cont* cont)
-           ((cont) cont)))
-       (define (visit-cont* cont)
-         (match cont
-           (($ $cont label cont)
-            (match cont
-              (($ $kargs names syms body)
-               (match (filter-map (lambda (name sym)
-                                    (and (value-live? sym)
-                                         (cons name sym)))
-                                  names syms)
-                 (((names . syms) ...)
-                  (list
-                   (build-cps-cont
-                     (label ($kargs names syms
-                              ,(visit-term body label))))))))
-              (($ $kfun src meta self tail clause)
-               (list
-                (build-cps-cont
-                  (label ($kfun src meta self ,tail
-                           ,(and clause (visit-cont clause)))))))
-              (($ $kclause arity body alternate)
-               (list
-                (build-cps-cont
-                  (label ($kclause ,arity
-                           ,(visit-cont body)
-                           ,(and alternate
-                                 (visit-cont alternate)))))))
-              (($ $kreceive ($ $arity req () rest () #f) kargs)
-               (let ((defs (vector-ref defs (label->idx label))))
-                 (if (and-map value-live? defs)
-                     (list (build-cps-cont (label ,cont)))
-                     (let-fresh (adapt) ()
-                       (list (make-adaptor adapt kargs defs)
-                             (build-cps-cont
-                               (label ($kreceive req rest adapt))))))))
-              (_ (list (build-cps-cont (label ,cont))))))))
-       (define (visit-conts conts)
-         (append-map visit-cont* conts))
-       (define (visit-term term term-k)
-         (match term
-           (($ $letk conts body)
-            (let ((body (visit-term body term-k)))
-              (match (visit-conts conts)
-                (() body)
-                (conts (build-cps-term ($letk ,conts ,body))))))
-           (($ $continue k src ($ $values args))
-            (match (vector-ref defs (label->idx term-k))
-              (#f term)
-              (defs
-                (let ((args (filter-map (lambda (use def)
-                                          (and (value-live? def) use))
-                                        args defs)))
-                  (build-cps-term
-                    ($continue k src ($values args)))))))
-           (($ $continue k src exp)
-            (if (bitvector-ref live-conts (label->idx term-k))
-                (match exp
-                  (($ $fun body)
-                   (build-cps-term
-                     ($continue k src ($fun ,(visit-fun body)))))
-                  (($ $rec names syms funs)
-                   (rewrite-cps-term
-                       (filter-map
-                        (lambda (name sym fun)
-                          (and (value-live? sym)
-                               (match fun
-                                 (($ $fun body)
-                                  (list name
-                                        sym
-                                        (build-cps-exp
-                                          ($fun ,(visit-fun body))))))))
-                        names syms funs)
-                     (()
-                      ($continue k src ($values ())))
-                     (((names syms funs) ...)
-                      ($continue k src ($rec names syms funs)))))
-                  (_
-                   (match (vector-ref defs (label->idx term-k))
-                     ((or #f ((? value-live?) ...))
-                      (build-cps-term
-                        ($continue k src ,exp)))
-                     (syms
-                      (let-fresh (adapt) ()
-                        (build-cps-term
-                          ($letk (,(make-adaptor adapt k syms))
-                            ($continue adapt src ,exp))))))))
-                (build-cps-term ($continue k src ($values ())))))))
-       (visit-cont fun))))
-  (visit-fun fun))
-
-(define (eliminate-dead-code fun)
-  (call-with-values (lambda () (renumber fun))
-    (lambda (fun nlabels nvars)
-      (parameterize ((label-counter nlabels)
-                     (var-counter nvars))
-        (call-with-values (lambda () (compute-live-code fun))
-          (lambda (fun-data-table live-vars)
-            (process-eliminations fun fun-data-table live-vars)))))))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
deleted file mode 100644
index 7a49f869f..000000000
--- a/module/language/cps/effects-analysis.scm
+++ /dev/null
@@ -1,499 +0,0 @@
-;;; Effects analysis on CPS
-
-;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 helper module to compute the set of effects caused by an
-;;; expression.  This information is useful when writing algorithms that
-;;; move code around, while preserving the semantics of an input
-;;; program.
-;;;
-;;; The effects set is represented as an integer with three parts.  The
-;;; low 4 bits indicate effects caused by an expression, as a bitfield.
-;;; The next 4 bits indicate the kind of memory accessed by the
-;;; expression, if it accesses mutable memory.  Finally the rest of the
-;;; bits indicate the field in the object being accessed, if known, or
-;;; -1 for unknown.
-;;;
-;;; In this way we embed a coarse type-based alias analysis in the
-;;; effects analysis.  For example, a "car" call is modelled as causing
-;;; a read to field 0 on a &pair, and causing a &type-check effect.  If
-;;; any intervening code sets the car of any pair, that will block
-;;; motion of the "car" call, because any write to field 0 of a pair is
-;;; seen by effects analysis as being a write to field 0 of all pairs.
-;;;
-;;; Code:
-
-(define-module (language cps effects-analysis)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (ice-9 match)
-  #:export (expression-effects
-            compute-effects
-            synthesize-definition-effects!
-
-            &allocation
-            &type-check
-            &read
-            &write
-
-            &fluid
-            &prompt
-            &car
-            &cdr
-            &vector
-            &box
-            &module
-            &struct
-            &string
-            &bytevector
-
-            &object
-            &field
-
-            &allocate
-            &read-object
-            &read-field
-            &write-object
-            &write-field
-
-            &no-effects
-            &all-effects
-
-            exclude-effects
-            effect-free?
-            constant?
-            causes-effect?
-            causes-all-effects?
-            effect-clobbers?))
-
-(define-syntax define-flags
-  (lambda (x)
-    (syntax-case x ()
-      ((_ all shift name ...)
-       (let ((count (length #'(name ...))))
-         (with-syntax (((n ...) (iota count))
-                       (count count))
-           #'(begin
-               (define-syntax name (identifier-syntax (ash 1 n)))
-               ...
-               (define-syntax all (identifier-syntax (1- (ash 1 count))))
-               (define-syntax shift (identifier-syntax count)))))))))
-
-(define-syntax define-enumeration
-  (lambda (x)
-    (define (count-bits n)
-      (let lp ((out 1))
-        (if (< n (ash 1 (1- out)))
-            out
-            (lp (1+ out)))))
-    (syntax-case x ()
-      ((_ mask shift name ...)
-       (let* ((len (length #'(name ...)))
-              (bits (count-bits len)))
-         (with-syntax (((n ...) (iota len))
-                       (bits bits))
-           #'(begin
-               (define-syntax name (identifier-syntax n))
-               ...
-               (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
-               (define-syntax shift (identifier-syntax bits)))))))))
-
-(define-flags &all-effect-kinds &effect-kind-bits
-  ;; Indicates that an expression may cause a type check.  A type check,
-  ;; for the purposes of this analysis, is the possibility of throwing
-  ;; an exception the first time an expression is evaluated.  If the
-  ;; expression did not cause an exception to be thrown, users can
-  ;; assume that evaluating the expression again will not cause an
-  ;; exception to be thrown.
-  ;;
-  ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
-  ;; it doesn't throw, it should be safe to elide a dominated, common
-  ;; subexpression (+ x y).
-  &type-check
-
-  ;; Indicates that an expression may return a fresh object.  The kind
-  ;; of object is indicated in the object kind field.
-  &allocation
-
-  ;; Indicates that an expression may cause a read from memory.  The
-  ;; kind of memory is given in the object kind field.  Some object
-  ;; kinds have finer-grained fields; those are expressed in the "field"
-  ;; part of the effects value.  -1 indicates "the whole object".
-  &read
-
-  ;; Indicates that an expression may cause a write to memory.
-  &write)
-
-(define-enumeration &memory-kind-mask &memory-kind-bits
-  ;; Indicates than an expression may access unknown kinds of memory.
-  &unknown-memory-kinds
-
-  ;; Indicates that an expression depends on the value of a fluid
-  ;; variable, or on the current fluid environment.
-  &fluid
-
-  ;; Indicates that an expression depends on the current prompt
-  ;; stack.
-  &prompt
-
-  ;; Indicates that an expression depends on the value of the car or cdr
-  ;; of a pair.
-  &pair
-
-  ;; Indicates that an expression depends on the value of a vector
-  ;; field.  The effect field indicates the specific field, or zero for
-  ;; an unknown field.
-  &vector
-
-  ;; Indicates that an expression depends on the value of a variable
-  ;; cell.
-  &box
-
-  ;; Indicates that an expression depends on the current module.
-  &module
-
-  ;; Indicates that an expression depends on the value of a struct
-  ;; field.  The effect field indicates the specific field, or zero for
-  ;; an unknown field.
-  &struct
-
-  ;; Indicates that an expression depends on the contents of a string.
-  &string
-
-  ;; Indicates that an expression depends on the contents of a
-  ;; bytevector.  We cannot be more precise, as bytevectors may alias
-  ;; other bytevectors.
-  &bytevector)
-
-(define-inlinable (&field kind field)
-  (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
-(define-inlinable (&object kind)
-  (&field kind -1))
-
-(define-inlinable (&allocate kind)
-  (logior &allocation (&object kind)))
-(define-inlinable (&read-field kind field)
-  (logior &read (&field kind field)))
-(define-inlinable (&read-object kind)
-  (logior &read (&object kind)))
-(define-inlinable (&write-field kind field)
-  (logior &write (&field kind field)))
-(define-inlinable (&write-object kind)
-  (logior &write (&object kind)))
-
-(define-syntax &no-effects (identifier-syntax 0))
-(define-syntax &all-effects
-  (identifier-syntax
-   (logior &all-effect-kinds (&object &unknown-memory-kinds))))
-
-(define-inlinable (constant? effects)
-  (zero? effects))
-
-(define-inlinable (causes-effect? x effects)
-  (not (zero? (logand x effects))))
-
-(define-inlinable (causes-all-effects? x)
-  (eqv? x &all-effects))
-
-(define (effect-clobbers? a b)
-  "Return true if A clobbers B.  This is the case if A is a write, and B
-is or might be a read or a write to the same location as A."
-  (define (locations-same?)
-    (let ((a (ash a (- &effect-kind-bits)))
-          (b (ash b (- &effect-kind-bits))))
-      (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
-          (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
-          (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
-               ;; A negative field indicates "the whole object".
-               ;; Non-negative fields indicate only part of the object.
-               (or (< a 0) (< b 0) (= a b))))))
-  (and (not (zero? (logand a &write)))
-       (not (zero? (logand b (logior &read &write))))
-       (locations-same?)))
-
-(define (lookup-constant-index sym dfg)
-  (call-with-values (lambda () (find-constant-value sym dfg))
-    (lambda (has-const? val)
-      (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
-
-(define-inlinable (indexed-field kind n dfg)
-  (cond
-   ((lookup-constant-index n dfg)
-    => (lambda (idx)
-         (&field kind idx)))
-   (else (&object kind))))
-
-(define *primitive-effects* (make-hash-table))
-
-(define-syntax-rule (define-primitive-effects* dfg
-                      ((name . args) effects ...)
-                      ...)
-  (begin
-    (hashq-set! *primitive-effects* 'name
-                (case-lambda*
-                 ((dfg . args) (logior effects ...))
-                 (_ &all-effects)))
-    ...))
-
-(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
-  (define-primitive-effects* dfg ((name . args) effects ...) ...))
-
-;; Miscellaneous.
-(define-primitive-effects
-  ((values . _)))
-
-;; Generic effect-free predicates.
-(define-primitive-effects
-  ((eq? . _))
-  ((eqv? . _))
-  ((equal? . _))
-  ((pair? arg))
-  ((null? arg))
-  ((nil? arg ))
-  ((symbol? arg))
-  ((variable? arg))
-  ((vector? arg))
-  ((struct? arg))
-  ((string? arg))
-  ((number? arg))
-  ((char? arg))
-  ((bytevector? arg))
-  ((keyword? arg))
-  ((bitvector? arg))
-  ((procedure? arg))
-  ((thunk? arg)))
-
-;; Fluids.
-(define-primitive-effects
-  ((fluid-ref f)                   (&read-object &fluid)       &type-check)
-  ((fluid-set! f v)                (&write-object &fluid)      &type-check)
-  ((push-fluid f v)                (&write-object &fluid)      &type-check)
-  ((pop-fluid)                     (&write-object &fluid)      &type-check))
-
-;; Prompts.
-(define-primitive-effects
-  ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
-
-;; Pairs.
-(define-primitive-effects
-  ((cons a b)                      (&allocate &pair))
-  ((list . _)                      (&allocate &pair))
-  ((car x)                         (&read-field &pair 0)       &type-check)
-  ((set-car! x y)                  (&write-field &pair 0)      &type-check)
-  ((cdr x)                         (&read-field &pair 1)       &type-check)
-  ((set-cdr! x y)                  (&write-field &pair 1)      &type-check)
-  ((memq x y)                      (&read-object &pair)        &type-check)
-  ((memv x y)                      (&read-object &pair)        &type-check)
-  ((list? arg)                     (&read-field &pair 1))
-  ((length l)                      (&read-field &pair 1)       &type-check))
-
-;; Variables.
-(define-primitive-effects
-  ((box v)                         (&allocate &box))
-  ((box-ref v)                     (&read-object &box)         &type-check)
-  ((box-set! v x)                  (&write-object &box)        &type-check))
-
-;; Vectors.
-(define (vector-field n dfg)
-  (indexed-field &vector n dfg))
-(define (read-vector-field n dfg)
-  (logior &read (vector-field n dfg)))
-(define (write-vector-field n dfg)
-  (logior &write (vector-field n dfg)))
-(define-primitive-effects* dfg
-  ((vector . _)                    (&allocate &vector))
-  ((make-vector n init)            (&allocate &vector)         &type-check)
-  ((make-vector/immediate n init)  (&allocate &vector))
-  ((vector-ref v n)                (read-vector-field n dfg)   &type-check)
-  ((vector-ref/immediate v n)      (read-vector-field n dfg)   &type-check)
-  ((vector-set! v n x)             (write-vector-field n dfg)  &type-check)
-  ((vector-set!/immediate v n x)   (write-vector-field n dfg)  &type-check)
-  ((vector-length v)                                           &type-check))
-
-;; Structs.
-(define (struct-field n dfg)
-  (indexed-field &struct n dfg))
-(define (read-struct-field n dfg)
-  (logior &read (struct-field n dfg)))
-(define (write-struct-field n dfg)
-  (logior &write (struct-field n dfg)))
-(define-primitive-effects* dfg
-  ((allocate-struct vt n)          (&allocate &struct)         &type-check)
-  ((allocate-struct/immediate v n) (&allocate &struct)         &type-check)
-  ((make-struct vt ntail . _)      (&allocate &struct)         &type-check)
-  ((make-struct/no-tail vt . _)    (&allocate &struct)         &type-check)
-  ((struct-ref s n)                (read-struct-field n dfg)   &type-check)
-  ((struct-ref/immediate s n)      (read-struct-field n dfg)   &type-check)
-  ((struct-set! s n x)             (write-struct-field n dfg)  &type-check)
-  ((struct-set!/immediate s n x)   (write-struct-field n dfg)  &type-check)
-  ((struct-vtable s)                                           &type-check))
-
-;; Strings.
-(define-primitive-effects
-  ((string-ref s n)                (&read-object &string)      &type-check)
-  ((string-set! s n c)             (&write-object &string)     &type-check)
-  ((number->string _)              (&allocate &string)         &type-check)
-  ((string->number _)              (&read-object &string)      &type-check)
-  ((string-length s)                                           &type-check))
-
-;; Bytevectors.
-(define-primitive-effects
-  ((bytevector-length _)                                       &type-check)
-
-  ((bv-u8-ref bv n)                (&read-object &bytevector)  &type-check)
-  ((bv-s8-ref bv n)                (&read-object &bytevector)  &type-check)
-  ((bv-u16-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-s16-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-u32-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-s32-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-u64-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-s64-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-f32-ref bv n)               (&read-object &bytevector)  &type-check)
-  ((bv-f64-ref bv n)               (&read-object &bytevector)  &type-check)
-
-  ((bv-u8-set! bv n x)             (&write-object &bytevector) &type-check)
-  ((bv-s8-set! bv n x)             (&write-object &bytevector) &type-check)
-  ((bv-u16-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-s16-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-u32-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-s32-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-u64-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-s64-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-f32-set! bv n x)            (&write-object &bytevector) &type-check)
-  ((bv-f64-set! bv n x)            (&write-object &bytevector) &type-check))
-
-;; Modules.
-(define-primitive-effects
-  ((current-module)                (&read-object &module))
-  ((cache-current-module! m scope) (&write-object &box))
-  ((resolve name bound?)           (&read-object &module)      &type-check)
-  ((cached-toplevel-box scope name bound?)                     &type-check)
-  ((cached-module-box mod name public? bound?)                 &type-check)
-  ((define! name val)              (&read-object &module) (&write-object &box)))
-
-;; Numbers.
-(define-primitive-effects
-  ((= . _)                         &type-check)
-  ((< . _)                         &type-check)
-  ((> . _)                         &type-check)
-  ((<= . _)                        &type-check)
-  ((>= . _)                        &type-check)
-  ((zero? . _)                     &type-check)
-  ((add . _)                       &type-check)
-  ((mul . _)                       &type-check)
-  ((sub . _)                       &type-check)
-  ((div . _)                       &type-check)
-  ((sub1 . _)                      &type-check)
-  ((add1 . _)                      &type-check)
-  ((quo . _)                       &type-check)
-  ((rem . _)                       &type-check)
-  ((mod . _)                       &type-check)
-  ((complex? _)                    &type-check)
-  ((real? _)                       &type-check)
-  ((rational? _)                   &type-check)
-  ((inf? _)                        &type-check)
-  ((nan? _)                        &type-check)
-  ((integer? _)                    &type-check)
-  ((exact? _)                      &type-check)
-  ((inexact? _)                    &type-check)
-  ((even? _)                       &type-check)
-  ((odd? _)                        &type-check)
-  ((ash n m)                       &type-check)
-  ((logand . _)                    &type-check)
-  ((logior . _)                    &type-check)
-  ((logxor . _)                    &type-check)
-  ((lognot . _)                    &type-check)
-  ((logtest a b)                   &type-check)
-  ((logbit? a b)                   &type-check)
-  ((sqrt _)                        &type-check)
-  ((abs _)                         &type-check))
-
-;; Characters.
-(define-primitive-effects
-  ((char<? . _)                    &type-check)
-  ((char<=? . _)                   &type-check)
-  ((char>=? . _)                   &type-check)
-  ((char>? . _)                    &type-check)
-  ((integer->char _)               &type-check)
-  ((char->integer _)               &type-check))
-
-(define (primitive-effects dfg name args)
-  (let ((proc (hashq-ref *primitive-effects* name)))
-    (if proc
-        (apply proc dfg args)
-        &all-effects)))
-
-(define (expression-effects exp dfg)
-  (match exp
-    ((or ($ $const) ($ $prim) ($ $values))
-     &no-effects)
-    ((or ($ $fun) ($ $rec))
-     (&allocate &unknown-memory-kinds))
-    (($ $prompt)
-     (&write-object &prompt))
-    ((or ($ $call) ($ $callk))
-     &all-effects)
-    (($ $branch k exp)
-     (expression-effects exp dfg))
-    (($ $primcall name args)
-     (primitive-effects dfg name args))))
-
-(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
-                          (label-count (dfg-label-count dfg)))
-  (let ((effects (make-vector label-count &no-effects)))
-    (define (idx->label idx) (+ idx min-label))
-    (let lp ((n 0))
-      (when (< n label-count)
-        (vector-set!
-         effects
-         n
-         (match (lookup-cont (idx->label n) dfg)
-           (($ $kargs names syms body)
-            (expression-effects (find-expression body) dfg))
-           (($ $kreceive arity kargs)
-            (match arity
-              (($ $arity _ () #f () #f) &type-check)
-              (($ $arity () () _ () #f) (&allocate &pair))
-              (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
-           (($ $kfun) &type-check)
-           (($ $kclause) &type-check)
-           (($ $ktail) &no-effects)))
-        (lp (1+ n))))
-    effects))
-
-;; There is a way to abuse effects analysis in CSE to also do scalar
-;; replacement, effectively adding `car' and `cdr' expressions to `cons'
-;; expressions, and likewise with other constructors and setters.  This
-;; routine adds appropriate effects to `cons' and `set-car!' and the
-;; like.
-;;
-;; This doesn't affect CSE's ability to eliminate expressions, given
-;; that allocations aren't eliminated anyway, and the new effects will
-;; just cause the allocations not to commute with e.g. set-car!  which
-;; is what we want anyway.
-(define* (synthesize-definition-effects! effects dfg min-label #:optional
-                                         (label-count (vector-length effects)))
-  (define (label->idx label) (- label min-label))
-  (let lp ((label min-label))
-    (when (< label (+ min-label label-count))
-      (let* ((lidx (label->idx label))
-             (fx (vector-ref effects lidx)))
-        (unless (zero? (logand (logior &write &allocation) fx))
-          (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
-        (lp (1+ label))))))
diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
deleted file mode 100644
index dadbd403a..000000000
--- a/module/language/cps/elide-values.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Primcalls that don't correspond to VM instructions are treated as if
-;;; they are calls, and indeed the later reify-primitives pass turns
-;;; them into calls.  Because no return arity checking is done for these
-;;; primitives, if a later optimization pass simplifies the primcall to
-;;; a VM operation, the tail of the simplification has to be a
-;;; primcall to 'values.  Most of these primcalls can be elided, and
-;;; that is the job of this pass.
-;;;
-;;; Code:
-
-(define-module (language cps elide-values)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-26)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:export (elide-values))
-
-(define (elide-values* fun conts)
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont sym ($ $kargs names syms body))
-       (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kfun src meta self tail clause))
-       (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
-      (($ $cont sym ($ $kclause arity body alternate))
-       (sym ($kclause ,arity ,(visit-cont body)
-                      ,(and alternate (visit-cont alternate)))))
-      (($ $cont)
-       ,cont)))
-  (define (visit-term term)
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ($letk ,(map visit-cont conts)
-         ,(visit-term body)))
-      (($ $continue k src ($ $primcall 'values vals))
-       ,(rewrite-cps-term (vector-ref conts k)
-          (($ $ktail)
-           ($continue k src ($values vals)))
-          (($ $kreceive ($ $arity req () rest () #f) kargs)
-           ,(cond
-             ((and (not rest) (= (length vals) (length req)))
-              (build-cps-term
-                ($continue kargs src ($values vals))))
-             ((and rest (>= (length vals) (length req)))
-              (let-fresh (krest) (rest)
-                (let ((vals* (append (list-head vals (length req))
-                                     (list rest))))
-                  (build-cps-term
-                    ($letk ((krest ($kargs ('rest) (rest)
-                                     ($continue kargs src
-                                       ($values vals*)))))
-                      ,(let lp ((tail (list-tail vals (length req)))
-                                (k krest))
-                         (match tail
-                           (()
-                            (build-cps-term ($continue k src
-                                              ($const '()))))
-                           ((v . tail)
-                            (let-fresh (krest) (rest)
-                              (build-cps-term
-                                ($letk ((krest ($kargs ('rest) (rest)
-                                                 ($continue k src
-                                                   ($primcall 'cons
-                                                              (v rest))))))
-                                  ,(lp tail krest))))))))))))
-             (else term)))
-          (($ $kargs args)
-           ,(if (< (length vals) (length args))
-                term
-                (let ((vals (list-head vals (length args))))
-                  (build-cps-term
-                    ($continue k src ($values vals))))))))
-      (($ $continue k src (and fun ($ $fun)))
-       ($continue k src ,(visit-fun fun)))
-      (($ $continue k src ($ $rec names syms funs))
-       ($continue k src ($rec names syms (map visit-fun funs))))
-      (($ $continue)
-       ,term)))
-  (define (visit-fun fun)
-    (rewrite-cps-exp fun
-      (($ $fun cont)
-       ($fun ,(visit-cont cont)))))
-
-  (visit-cont fun))
-
-(define (elide-values fun)
-  (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
-      (elide-values* fun conts))))
diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
deleted file mode 100644
index c224f4531..000000000
--- a/module/language/cps/prune-bailouts.scm
+++ /dev/null
@@ -1,101 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps prune-bailouts)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:export (prune-bailouts))
-
-(define (module-box src module name public? bound? val-proc)
-  (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
-    (build-cps-term
-      ($letconst (('module module-sym module)
-                  ('name name-sym name)
-                  ('public? public?-sym public?)
-                  ('bound? bound?-sym bound?))
-        ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
-          ($continue kbox src
-            ($primcall 'cached-module-box
-                       (module-sym name-sym public?-sym bound?-sym))))))))
-
-(define (primitive-ref name k src)
-  (module-box #f '(guile) name #f #t
-              (lambda (box)
-                (build-cps-term
-                  ($continue k src ($primcall 'box-ref (box)))))))
-
-(define (prune-bailouts* fun)
-  (define (visit-cont cont ktail)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs names vars body))
-       (label ($kargs names vars ,(visit-term body ktail))))
-      (($ $cont label ($ $kfun src meta self tail clause))
-       (label ($kfun src meta self ,tail
-                ,(and clause (visit-cont clause ktail)))))
-      (($ $cont label ($ $kclause arity body alternate))
-       (label ($kclause ,arity ,(visit-cont body ktail)
-                        ,(and alternate (visit-cont alternate ktail)))))
-      (_ ,cont)))
-
-  (define (visit-term term ktail)
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
-         ,(visit-term body ktail)))
-      (($ $continue k src exp)
-       ,(visit-exp k src exp ktail))))
-
-  (define (visit-exp k src exp ktail)
-    (rewrite-cps-term exp
-      (($ $fun) ($continue k src ,(visit-fun exp)))
-      (($ $rec names vars funs)
-       ($continue k src ($rec names vars (map visit-fun funs))))
-      (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
-       ,(if (eq? k ktail)
-            (build-cps-term ($continue k src ,exp))
-            (let-fresh (kprim kresult kreceive) (prim rest)
-              (build-cps-term
-                ($letk ((kresult ($kargs ('rest) (rest)
-                                   ($continue ktail src ($values ()))))
-                        (kreceive ($kreceive '() 'rest kresult))
-                        (kprim ($kargs ('prim) (prim)
-                                 ($continue kreceive src
-                                   ($call prim args)))))
-                  ,(primitive-ref name kprim src))))))
-      (_ ($continue k src ,exp))))
-
-  (define (visit-fun fun)
-    (rewrite-cps-exp fun
-      (($ $fun body)
-       ($fun ,(prune-bailouts* body)))))
-
-  (rewrite-cps-cont fun
-    (($ $cont kfun
-        ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
-     (kfun ($kfun src meta self (ktail ($ktail))
-             ,(and clause (visit-cont clause ktail)))))))
-
-(define (prune-bailouts fun)
-  (with-fresh-name-state fun
-    (prune-bailouts* fun)))
diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm
deleted file mode 100644
index 4839b71f7..000000000
--- a/module/language/cps/prune-top-level-scopes.scm
+++ /dev/null
@@ -1,114 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 simple pass to prune unneeded top-level scopes.
-;;;
-;;; Code:
-
-(define-module (language cps prune-top-level-scopes)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:export (prune-top-level-scopes))
-
-(define (compute-referenced-scopes fun)
-  (let ((scope-name->used? (make-hash-table))
-        (scope-var->used? (make-hash-table))
-        (k->scope-var (make-hash-table)))
-    ;; Visit uses before defs.  That way we know when visiting defs
-    ;; whether the scope is used or not.
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont k ($ $kargs (name) (var) body))
-         (visit-term body)
-         (when (hashq-get-handle scope-var->used? var)
-           (hashq-set! k->scope-var k var)))
-        (($ $cont k ($ $kargs names syms body))
-         (visit-term body))
-        (($ $cont k ($ $kfun src meta self tail clause))
-         (when clause (visit-cont clause)))
-        (($ $cont k ($ $kclause arity body alternate))
-         (visit-cont body)
-         (when alternate (visit-cont alternate)))
-        (($ $cont k ($ $kreceive))
-         #t)))
-    (define (visit-term term)
-      (match term
-        (($ $letk conts body)
-         (for-each visit-cont conts)
-         (visit-term body))
-        (($ $continue k src exp)
-         (match exp
-           (($ $fun) (visit-fun exp))
-           (($ $rec names syms funs)
-            (for-each visit-fun funs))
-           (($ $primcall 'cached-toplevel-box (scope name bound?))
-            (hashq-set! scope-var->used? scope #t))
-           (($ $primcall 'cache-current-module! (module scope))
-            (hashq-set! scope-var->used? scope #f))
-           (($ $const val)
-            ;; If there is an entry in the table for "k", it means "val"
-            ;; is a scope symbol, bound for use by cached-toplevel-box
-            ;; or cache-current-module!, or possibly both (though this
-            ;; is not currently the case).
-            (and=> (hashq-ref k->scope-var k)
-                   (lambda (scope-var)
-                     (when (hashq-ref scope-var->used? scope-var)
-                       ;; We have a use via cached-toplevel-box.  Mark
-                       ;; this scope as used.
-                       (hashq-set! scope-name->used? val #t))
-                     (when (and (hashq-ref scope-name->used? val)
-                                (not (hashq-ref scope-var->used? scope-var)))
-                       ;; There is a use, and this sym is used by
-                       ;; cache-current-module!.
-                       (hashq-set! scope-var->used? scope-var #t)))))
-           (_ #t)))))
-    (define (visit-fun fun)
-      (match fun
-        (($ $fun body)
-         (visit-cont body))))
-
-    (visit-cont fun)
-    scope-var->used?))
-
-(define (prune-top-level-scopes fun)
-  (let ((scope-var->used? (compute-referenced-scopes fun)))
-    (define (visit-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont sym ($ $kargs names syms body))
-         (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kfun src meta self tail clause))
-         (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
-        (($ $cont sym ($ $kclause arity body alternate))
-         (sym ($kclause ,arity ,(visit-cont body)
-                        ,(and alternate (visit-cont alternate)))))
-        (($ $cont sym ($ $kreceive))
-         ,cont)))
-    (define (visit-term term)
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ($letk ,(map visit-cont conts) ,(visit-term body)))
-        (($ $continue k src
-            (and ($ $primcall 'cache-current-module! (module scope))
-                 (? (lambda _
-                      (not (hashq-ref scope-var->used? scope))))))
-         ($continue k src ($primcall 'values ())))
-        (($ $continue)
-         ,term)))
-    (visit-cont fun)))
diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm
deleted file mode 100644
index 45e2389ff..000000000
--- a/module/language/cps/self-references.scm
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps self-references)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:export (resolve-self-references))
-
-(define* (resolve-self-references fun #:optional (env '()))
-  (define (subst var)
-    (or (assq-ref env var) var))
-
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs names vars body))
-       (label ($kargs names vars ,(visit-term body))))
-      (($ $cont label ($ $kfun src meta self tail clause))
-       (label ($kfun src meta self ,tail
-                ,(and clause (visit-cont clause)))))
-      (($ $cont label ($ $kclause arity body alternate))
-       (label ($kclause ,arity ,(visit-cont body)
-                        ,(and alternate (visit-cont alternate)))))
-      (_ ,cont)))
-
-  (define (visit-term term)
-    (rewrite-cps-term term
-      (($ $letk conts body)
-       ($letk ,(map visit-cont conts)
-         ,(visit-term body)))
-      (($ $continue k src exp)
-       ($continue k src ,(visit-exp exp)))))
-
-  (define (visit-exp exp)
-    (rewrite-cps-exp exp
-      ((or ($ $const) ($ $prim)) ,exp)
-      (($ $fun body)
-       ($fun ,(resolve-self-references body env)))
-      (($ $rec names vars funs)
-       ($rec names vars (map visit-recursive-fun funs vars)))
-      (($ $call proc args)
-       ($call (subst proc) ,(map subst args)))
-      (($ $callk k proc args)
-       ($callk k (subst proc) ,(map subst args)))
-      (($ $primcall name args)
-       ($primcall name ,(map subst args)))
-      (($ $branch k exp)
-       ($branch k ,(visit-exp exp)))
-      (($ $values args)
-       ($values ,(map subst args)))
-      (($ $prompt escape? tag handler)
-       ($prompt escape? (subst tag) handler))))
-
-  (define (visit-recursive-fun fun var)
-    (rewrite-cps-exp fun
-      (($ $fun (and cont ($ $cont _ ($ $kfun src meta self))))
-       ($fun ,(resolve-self-references cont (acons var self env))))))
-
-  (visit-cont fun))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
deleted file mode 100644
index 10e9d0aa2..000000000
--- a/module/language/cps/simplify.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; The fundamental lambda calculus reductions, like beta and eta
-;;; reduction and so on.  Pretty lame currently.
-;;;
-;;; Code:
-
-(define-module (language cps simplify)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps renumber)
-  #:export (simplify))
-
-(define (compute-eta-reductions fun)
-  (let ((table (make-hash-table)))
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont sym ($ $kargs names syms body))
-         (visit-term body sym syms))
-        (($ $cont sym ($ $kfun src meta self tail clause))
-         (when clause (visit-cont clause)))
-        (($ $cont sym ($ $kclause arity body alternate))
-         (visit-cont body)
-         (when alternate (visit-cont alternate)))
-        (($ $cont sym _) #f)))
-    (define (visit-term term term-k term-args)
-      (match term
-        (($ $letk conts body)
-         (for-each visit-cont conts)
-         (visit-term body term-k term-args))
-        (($ $continue k src ($ $values args))
-         (when (and (equal? term-args args) (not (eq? k term-k)))
-           (hashq-set! table term-k k)))
-        (($ $continue k src (and fun ($ $fun)))
-         (visit-fun fun))
-        (($ $continue k src ($ $rec names syms funs))
-         (for-each visit-fun funs))
-        (($ $continue k src _)
-         #f)))
-    (define (visit-fun fun)
-      (match fun
-        (($ $fun body)
-         (visit-cont body))))
-    (visit-cont fun)
-    table))
-
-(define (eta-reduce fun)
-  (let ((table (compute-eta-reductions fun))
-        (dfg (compute-dfg fun)))
-    (define (reduce* k scope values?)
-      (match (hashq-ref table k)
-        (#f k)
-        (k* 
-         (if (and (continuation-bound-in? k* scope dfg)
-                  (or values?
-                      (match (lookup-cont k* dfg)
-                        (($ $kargs) #t)
-                        (_ #f))))
-             (reduce* k* scope values?)
-             k))))
-    (define (reduce k scope)
-      (reduce* k scope #f))
-    (define (reduce-values k scope)
-      (reduce* k scope #t))
-    (define (reduce-const k src scope const)
-      (let lp ((k k) (seen '()) (const const))
-        (match (lookup-cont k dfg)
-          (($ $kargs (_) (arg) term)
-           (match (find-call term)
-             (($ $continue k* src* ($ $values (arg*)))
-              (and (eqv? arg arg*)
-                   (not (memq k* seen))
-                   (lp k* (cons k seen) const)))
-             (($ $continue k* src* ($ $primcall 'not (arg*)))
-              (and (eqv? arg arg*)
-                   (not (memq k* seen))
-                   (lp k* (cons k seen) (not const))))
-             (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
-              (and (eqv? arg arg*)
-                   (let ((k* (if const kt k*)))
-                     (and (continuation-bound-in? k* scope dfg)
-                          (build-cps-term
-                            ($continue k* src ($values ())))))))
-             (_
-              (and (continuation-bound-in? k scope dfg)
-                   (build-cps-term
-                     ($continue k src ($const const)))))))
-          (_ #f))))
-    (define (visit-cont cont scope)
-      (rewrite-cps-cont cont
-        (($ $cont sym ($ $kargs names syms body))
-         (sym ($kargs names syms ,(visit-term body sym))))
-        (($ $cont sym ($ $kfun src meta self tail clause))
-         (sym ($kfun src meta self ,tail
-                ,(and clause (visit-cont clause sym)))))
-        (($ $cont sym ($ $kclause arity body alternate))
-         (sym ($kclause ,arity ,(visit-cont body sym)
-                        ,(and alternate (visit-cont alternate sym)))))
-        (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
-         (sym ($kreceive req rest (reduce kargs scope))))))
-    (define (visit-term term scope)
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ($letk ,(map (cut visit-cont <> scope) conts)
-           ,(visit-term body scope)))
-        (($ $continue k src ($ $values args))
-         ($continue (reduce-values k scope) src ($values args)))
-        (($ $continue k src (and fun ($ $fun)))
-         ($continue (reduce k scope) src ,(visit-fun fun)))
-        (($ $continue k src ($ $rec names syms funs))
-         ($continue k src ($rec names syms (map visit-fun funs))))
-        (($ $continue k src ($ $const const))
-         ,(let ((k (reduce k scope)))
-            (or (reduce-const k src scope const)
-                (build-cps-term ($continue k src ($const const))))))
-        (($ $continue k src exp)
-         ($continue (reduce k scope) src ,exp))))
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun body)
-         ($fun ,(visit-cont body #f)))))
-    (visit-cont fun #f)))
-
-(define (compute-beta-reductions fun)
-  ;; A continuation's body can be inlined in place of a $values
-  ;; expression if the continuation is a $kargs.  It should only be
-  ;; inlined if it is used only once, and not recursively.
-  (let ((var-table (make-hash-table))
-        (k-table (make-hash-table))
-        (dfg (compute-dfg fun)))
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont sym ($ $kargs names syms body))
-         (visit-term body))
-        (($ $cont sym ($ $kfun src meta self tail clause))
-         (when clause (visit-cont clause)))
-        (($ $cont sym ($ $kclause arity body alternate))
-         (visit-cont body)
-         (when alternate (visit-cont alternate)))
-        (($ $cont sym (or ($ $ktail) ($ $kreceive)))
-         #f)))
-    (define (visit-term term)
-      (match term
-        (($ $letk conts body)
-         (for-each visit-cont conts)
-         (visit-term body))
-        (($ $continue k src ($ $values args))
-         (match (lookup-cont k dfg)
-           (($ $kargs names syms body)
-            (match (lookup-predecessors k dfg)
-              ((_)
-               ;; There is only one use, and it is this use.  We assume
-               ;; it's not recursive, as there would to be some other
-               ;; use for control flow to reach this loop.  Store the k
-               ;; -> body mapping in the table.  Also store the
-               ;; substitutions for the variables bound by the inlined
-               ;; continuation.
-               (for-each (cut hashq-set! var-table <> <>) syms args)
-               (hashq-set! k-table k body))
-              (_ #f)))
-           (_ #f)))
-        (($ $continue k src (and fun ($ $fun)))
-         (visit-fun fun))
-        (($ $continue k src ($ $rec names syms funs))
-         (for-each visit-fun funs))
-        (($ $continue k src _)
-         #f)))
-    (define (visit-fun fun)
-      (match fun
-        (($ $fun body)
-         (visit-cont body))))
-    (visit-cont fun)
-    (values var-table k-table)))
-
-(define (beta-reduce fun)
-  (let-values (((var-table k-table) (compute-beta-reductions fun)))
-    (define (subst var)
-      (cond ((hashq-ref var-table var) => subst)
-            (else var)))
-    (define (must-visit-cont cont)
-      (or (visit-cont cont)
-          (error "continuation must not be inlined" cont)))
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont sym cont)
-         (and (not (hashq-ref k-table sym))
-              (rewrite-cps-cont cont
-                (($ $kargs names syms body)
-                 (sym ($kargs names syms ,(visit-term body))))
-                (($ $kfun src meta self tail clause)
-                 (sym ($kfun src meta self ,tail
-                        ,(and clause (must-visit-cont clause)))))
-                (($ $kclause arity body alternate)
-                 (sym ($kclause ,arity ,(must-visit-cont body)
-                                ,(and alternate (must-visit-cont alternate)))))
-                (($ $kreceive)
-                 (sym ,cont)))))))
-    (define (visit-term term)
-      (match term
-        (($ $letk conts body)
-         (match (filter-map visit-cont conts)
-           (() (visit-term body))
-           (conts (build-cps-term
-                    ($letk ,conts ,(visit-term body))))))
-        (($ $continue k src exp)
-         (cond
-          ((hashq-ref k-table k) => visit-term)
-          (else
-           (build-cps-term ($continue k src ,(visit-exp exp))))))))
-    (define (visit-exp exp)
-      (match exp
-        ((or ($ $const) ($ $prim)) exp)
-        (($ $fun) (visit-fun exp))
-        (($ $rec names syms funs)
-         (build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
-        (($ $call proc args)
-         (let ((args (map subst args)))
-           (build-cps-exp ($call (subst proc) args))))
-        (($ $callk k proc args)
-         (let ((args (map subst args)))
-           (build-cps-exp ($callk k (subst proc) args))))
-        (($ $primcall name args)
-         (let ((args (map subst args)))
-           (build-cps-exp ($primcall name args))))
-        (($ $values args)
-         (let ((args (map subst args)))
-           (build-cps-exp ($values args))))
-        (($ $branch kt exp)
-         (build-cps-exp ($branch kt ,(visit-exp exp))))
-        (($ $prompt escape? tag handler)
-         (build-cps-exp ($prompt escape? (subst tag) handler)))))
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun body)
-         ($fun ,(must-visit-cont body)))))
-    (must-visit-cont fun)))
-
-;; Rewrite the scope tree to reflect the dominator tree.  Precondition:
-;; the fun has been renumbered, its min-label is 0, and its labels are
-;; packed.
-(define (redominate fun)
-  (let* ((dfg (compute-dfg fun))
-         (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
-         (doms (compute-dom-edges idoms 0)))
-    (define (visit-fun-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont label ($ $kfun src meta self tail clause))
-         (label ($kfun src meta self ,tail
-                  ,(and clause (visit-fun-cont clause)))))
-        (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
-         (label ($kclause ,arity ,(visit-cont kbody body)
-                          ,(and alternate (visit-fun-cont alternate)))))))
-
-    (define (visit-cont label cont)
-      (rewrite-cps-cont cont
-        (($ $kargs names vars body)
-         (label ($kargs names vars ,(visit-term body label))))
-        (_ (label ,cont))))
-
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun body)
-         ($fun ,(visit-fun-cont body)))))
-
-    (define (visit-exp k src exp)
-      (rewrite-cps-term exp
-        (($ $fun body)
-         ($continue k src ,(visit-fun exp)))
-        (($ $rec names syms funs)
-         ($continue k src ($rec names syms (map visit-fun funs))))
-        (_
-         ($continue k src ,exp))))
-
-    (define (visit-term term label)
-      (define (visit-dom-conts label)
-        (let ((cont (lookup-cont label dfg)))
-          (match cont
-            (($ $ktail) '())
-            (($ $kargs) (list (visit-cont label cont)))
-            (else
-             (cons (visit-cont label cont)
-                   (visit-dom-conts* (vector-ref doms label)))))))
-
-      (define (visit-dom-conts* labels)
-        (match labels
-          (() '())
-          ((label . labels)
-           (append (visit-dom-conts label)
-                   (visit-dom-conts* labels)))))
-
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ,(visit-term body label))
-        (($ $continue k src exp)
-         ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
-            (if (null? conts)
-                (visit-exp k src exp)
-                (build-cps-term
-                  ($letk ,conts ,(visit-exp k src exp))))))))
-
-    (visit-fun-cont fun)))
-
-(define (simplify fun)
-  ;; Renumbering prunes continuations that are made unreachable by
-  ;; eta/beta reductions.
-  (redominate (renumber (eta-reduce (beta-reduce fun)))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
deleted file mode 100644
index e5b76fb13..000000000
--- a/module/language/cps/specialize-primcalls.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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:
-;;;
-;;; Some bytecode operations can encode an immediate as an operand.
-;;; This pass tranforms generic primcalls to these specialized
-;;; primcalls, if possible.
-;;;
-;;; Code:
-
-(define-module (language cps specialize-primcalls)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:export (specialize-primcalls))
-
-(define (specialize-primcalls fun)
-  (let ((dfg (compute-dfg fun #:global? #t)))
-    (with-fresh-name-state-from-dfg dfg
-      (define (immediate-u8? sym)
-        (call-with-values (lambda () (find-constant-value sym dfg))
-          (lambda (has-const? val)
-            (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
-      (define (visit-cont cont)
-        (rewrite-cps-cont cont
-          (($ $cont sym ($ $kargs names syms body))
-           (sym ($kargs names syms ,(visit-term body))))
-          (($ $cont sym ($ $kfun src meta self tail clause))
-           (sym ($kfun src meta self ,tail
-                  ,(and clause (visit-cont clause)))))
-          (($ $cont sym ($ $kclause arity body alternate))
-           (sym ($kclause ,arity ,(visit-cont body)
-                          ,(and alternate (visit-cont alternate)))))
-          (($ $cont)
-           ,cont)))
-      (define (visit-term term)
-        (rewrite-cps-term term
-          (($ $letk conts body)
-           ($letk ,(map visit-cont conts)
-             ,(visit-term body)))
-          (($ $continue k src (and fun ($ $fun)))
-           ($continue k src ,(visit-fun fun)))
-          (($ $continue k src ($ $rec names syms funs))
-           ($continue k src ($rec names syms (map visit-fun funs))))
-          (($ $continue k src ($ $primcall name args))
-           ,(visit-primcall k src name args))
-          (($ $continue)
-           ,term)))
-      (define (visit-primcall k src name args)
-        ;; If we introduce a VM op from a primcall without a VM op, we
-        ;; will need to ensure that the return arity matches.  Rely on the
-        ;; elide-values pass to clean up.
-        (define-syntax-rule (adapt-void exp)
-          (let-fresh (k* kvoid) (val)
-            (build-cps-term
-              ($letk ((k* ($kargs ('val) (val)
-                            ($continue k src ($primcall 'values (val)))))
-                      (kvoid ($kargs () ()
-                               ($continue k* src ($const *unspecified*)))))
-                ($continue kvoid src exp)))))
-        (define-syntax-rule (adapt-val exp)
-          (let-fresh (k*) (val)
-            (build-cps-term
-              ($letk ((k* ($kargs ('val) (val)
-                            ($continue k src ($primcall 'values (val))))))
-                ($continue k* src exp)))))
-        (match (cons name args)
-          (('make-vector (? immediate-u8? n) init)
-           (adapt-val ($primcall 'make-vector/immediate (n init))))
-          (('vector-ref v (? immediate-u8? n))
-           (build-cps-term
-             ($continue k src ($primcall 'vector-ref/immediate (v n)))))
-          (('vector-set! v (? immediate-u8? n) x)
-           (build-cps-term
-             ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
-          (('allocate-struct v (? immediate-u8? n))
-           (adapt-val ($primcall 'allocate-struct/immediate (v n))))
-          (('struct-ref s (? immediate-u8? n))
-           (adapt-val ($primcall 'struct-ref/immediate (s n))))
-          (('struct-set! s (? immediate-u8? n) x)
-           (build-cps-term
-             ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
-          (_ 
-           (build-cps-term ($continue k src ($primcall name args))))))
-
-      (define (visit-fun fun)
-        (rewrite-cps-exp fun
-          (($ $fun body)
-           ($fun ,(visit-cont body)))))
-
-      (visit-cont fun))))
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
deleted file mode 100644
index ba66ec3ff..000000000
--- a/module/language/cps/type-fold.scm
+++ /dev/null
@@ -1,443 +0,0 @@
-;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-;;;
-;;; This library is free software: you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public 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 program.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; This pass uses the abstract interpretation provided by type analysis
-;;; to fold constant values and type predicates.  It is most profitably
-;;; run after CSE, to take advantage of scalar replacement.
-;;;
-;;; Code:
-
-(define-module (language cps type-fold)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps renumber)
-  #:use-module (language cps types)
-  #:use-module (system base target)
-  #:export (type-fold))
-
-
-
-
-;; Branch folders.
-
-(define &scalar-types
-  (logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
-
-(define *branch-folders* (make-hash-table))
-
-(define-syntax-rule (define-branch-folder name f)
-  (hashq-set! *branch-folders* 'name f))
-
-(define-syntax-rule (define-branch-folder-alias to from)
-  (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
-
-(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
-  (define-branch-folder name (lambda (arg min max) body ...)))
-
-(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
-                                                       arg1 min1 max1)
-                      body ...)
-  (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
-
-(define-syntax-rule (define-unary-type-predicate-folder name &type)
-  (define-unary-branch-folder (name type min max)
-    (let ((type* (logand type &type)))
-      (cond
-       ((zero? type*) (values #t #f))
-       ((eqv? type type*) (values #t #t))
-       (else (values #f #f))))))
-
-;; All the cases that are in compile-bytecode.
-(define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
-(define-unary-type-predicate-folder symbol? &symbol)
-(define-unary-type-predicate-folder variable? &box)
-(define-unary-type-predicate-folder vector? &vector)
-(define-unary-type-predicate-folder struct? &struct)
-(define-unary-type-predicate-folder string? &string)
-(define-unary-type-predicate-folder number? &number)
-(define-unary-type-predicate-folder char? &char)
-
-(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
-  (cond
-   ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
-    (values #t #f))
-   ((and (eqv? type0 type1)
-         (eqv? min0 min1 max0 max1)
-         (zero? (logand type0 (1- type0)))
-         (not (zero? (logand type0 &scalar-types))))
-    (values #t #t))
-   (else
-    (values #f #f))))
-(define-branch-folder-alias eqv? eq?)
-(define-branch-folder-alias equal? eq?)
-
-(define (compare-ranges type0 min0 max0 type1 min1 max1)
-  (and (zero? (logand (logior type0 type1) (lognot &real)))
-       (cond ((< max0 min1) '<)
-             ((> min0 max1) '>)
-             ((= min0 max0 min1 max1) '=)
-             ((<= max0 min1) '<=)
-             ((>= min0 max1) '>=)
-             (else #f))))
-
-(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
-  (case (compare-ranges type0 min0 max0 type1 min1 max1)
-    ((<) (values #t #t))
-    ((= >= >) (values #t #f))
-    (else (values #f #f))))
-
-(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
-  (case (compare-ranges type0 min0 max0 type1 min1 max1)
-    ((< <= =) (values #t #t))
-    ((>) (values #t #f))
-    (else (values #f #f))))
-
-(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
-  (case (compare-ranges type0 min0 max0 type1 min1 max1)
-    ((=) (values #t #t))
-    ((< >) (values #t #f))
-    (else (values #f #f))))
-
-(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
-  (case (compare-ranges type0 min0 max0 type1 min1 max1)
-    ((> >= =) (values #t #t))
-    ((<) (values #t #f))
-    (else (values #f #f))))
-
-(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
-  (case (compare-ranges type0 min0 max0 type1 min1 max1)
-    ((>) (values #t #t))
-    ((= <= <) (values #t #f))
-    (else (values #f #f))))
-
-(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
-  (define (logand-min a b)
-    (if (< a b 0)
-        (min a b)
-        0))
-  (define (logand-max a b)
-    (if (< a b 0)
-        0
-        (max a b)))
-  (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
-      (values #t (logtest min0 min1))
-      (values #f #f)))
-
-
-
-
-;; Strength reduction.
-
-(define *primcall-reducers* (make-hash-table))
-
-(define-syntax-rule (define-primcall-reducer name f)
-  (hashq-set! *primcall-reducers* 'name f))
-
-(define-syntax-rule (define-unary-primcall-reducer (name dfg k src
-                                                         arg type min max)
-                      body ...)
-  (define-primcall-reducer name
-    (lambda (dfg k src arg type min max) body ...)))
-
-(define-syntax-rule (define-binary-primcall-reducer (name dfg k src
-                                                          arg0 type0 min0 max0
-                                                          arg1 type1 min1 max1)
-                      body ...)
-  (define-primcall-reducer name
-    (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
-
-(define-binary-primcall-reducer (mul dfg k src
-                                     arg0 type0 min0 max0
-                                     arg1 type1 min1 max1)
-  (define (negate arg)
-    (let-fresh (kzero) (zero)
-      (build-cps-term
-        ($letk ((kzero ($kargs (#f) (zero)
-                         ($continue k src ($primcall 'sub (zero arg))))))
-          ($continue kzero src ($const 0))))))
-  (define (zero)
-    (build-cps-term ($continue k src ($const 0))))
-  (define (identity arg)
-    (build-cps-term ($continue k src ($values (arg)))))
-  (define (double arg)
-    (build-cps-term ($continue k src ($primcall 'add (arg arg)))))
-  (define (power-of-two constant arg)
-    (let ((n (let lp ((bits 0) (constant constant))
-               (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
-      (let-fresh (kbits) (bits)
-        (build-cps-term
-          ($letk ((kbits ($kargs (#f) (bits)
-                           ($continue k src ($primcall 'ash (arg bits))))))
-            ($continue kbits src ($const n)))))))
-  (define (mul/constant constant constant-type arg arg-type)
-    (and (or (= constant-type &exact-integer) (= constant-type arg-type))
-         (case constant
-           ;; (* arg -1) -> (- 0 arg)
-           ((-1) (negate arg))
-           ;; (* arg 0) -> 0 if arg is not a flonum or complex
-           ((0) (and (= constant-type &exact-integer)
-                     (zero? (logand arg-type
-                                    (lognot (logior &flonum &complex))))
-                     (zero)))
-           ;; (* arg 1) -> arg
-           ((1) (identity arg))
-           ;; (* arg 2) -> (+ arg arg)
-           ((2) (double arg))
-           (else (and (= constant-type arg-type &exact-integer)
-                      (positive? constant)
-                      (zero? (logand constant (1- constant)))
-                      (power-of-two constant arg))))))
-  (cond
-   ((logtest (logior type0 type1) (lognot &number)) #f)
-   ((= min0 max0) (mul/constant min0 type0 arg1 type1))
-   ((= min1 max1) (mul/constant min1 type1 arg0 type0))
-   (else #f)))
-
-(define-binary-primcall-reducer (logbit? dfg k src
-                                         arg0 type0 min0 max0
-                                         arg1 type1 min1 max1)
-  (define (convert-to-logtest bool-term)
-    (let-fresh (kt kf kmask kbool) (mask bool)
-     (build-cps-term
-       ($letk ((kt ($kargs () ()
-                     ($continue kbool src ($const #t))))
-               (kf ($kargs () ()
-                     ($continue kbool src ($const #f))))
-               (kbool ($kargs (#f) (bool)
-                        ,(bool-term bool)))
-               (kmask ($kargs (#f) (mask)
-                        ($continue kf src
-                          ($branch kt ($primcall 'logtest (mask arg1)))))))
-         ,(if (eq? min0 max0)
-              ($continue kmask src ($const (ash 1 min0)))
-              (let-fresh (kone) (one)
-                (build-cps-term
-                  ($letk ((kone ($kargs (#f) (one)
-                                  ($continue kmask src
-                                    ($primcall 'ash (one arg0))))))
-                    ($continue kone src ($const 1))))))))))
-  ;; Hairiness because we are converting from a primcall with unknown
-  ;; arity to a branching primcall.
-  (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
-    (and (= type0 &exact-integer)
-         (<= 0 min0 positive-fixnum-bits)
-         (<= 0 max0 positive-fixnum-bits)
-         (match (lookup-cont k dfg)
-           (($ $kreceive arity kargs)
-            (match arity
-              (($ $arity (_) () (not #f) () #f)
-               (convert-to-logtest
-                (lambda (bool)
-                  (let-fresh (knil) (nil)
-                    (build-cps-term
-                      ($letk ((knil ($kargs (#f) (nil)
-                                      ($continue kargs src
-                                        ($values (bool nil))))))
-                        ($continue knil src ($const '()))))))))
-              (_
-               (convert-to-logtest
-                (lambda (bool)
-                  (build-cps-term
-                    ($continue k src ($primcall 'values (bool)))))))))
-           (($ $ktail)
-            (convert-to-logtest
-             (lambda (bool)
-               (build-cps-term
-                 ($continue k src ($primcall 'return (bool)))))))))))
-
-
-
-
-;;
-
-(define (fold-and-reduce fun dfg min-label min-var)
-  (define (scalar-value type val)
-    (cond
-     ((eqv? type &exact-integer) val)
-     ((eqv? type &flonum) (exact->inexact val))
-     ((eqv? type &char) (integer->char val))
-     ((eqv? type &unspecified) *unspecified*)
-     ((eqv? type &false) #f)
-     ((eqv? type &true) #t)
-     ((eqv? type &nil) #nil)
-     ((eqv? type &null) '())
-     (else (error "unhandled type" type val))))
-  (let* ((typev (infer-types fun dfg))
-         (label-count ((make-local-cont-folder label-count)
-                       (lambda (k cont label-count) (1+ label-count))
-                       fun 0))
-         (folded? (make-bitvector label-count #f))
-         (folded-values (make-vector label-count #f))
-         (reduced-terms (make-vector label-count #f)))
-    (define (label->idx label) (- label min-label))
-    (define (var->idx var) (- var min-var))
-    (define (maybe-reduce-primcall! label k src name args)
-      (let* ((reducer (hashq-ref *primcall-reducers* name)))
-        (when reducer
-          (vector-set!
-           reduced-terms
-           (label->idx label)
-           (match args
-             ((arg0)
-              (call-with-values (lambda () (lookup-pre-type typev label arg0))
-                (lambda (type0 min0 max0)
-                  (reducer dfg k src arg0 type0 min0 max0))))
-             ((arg0 arg1)
-              (call-with-values (lambda () (lookup-pre-type typev label arg0))
-                (lambda (type0 min0 max0)
-                  (call-with-values (lambda () (lookup-pre-type typev label arg1))
-                    (lambda (type1 min1 max1)
-                      (reducer dfg k src arg0 type0 min0 max0
-                               arg1 type1 min1 max1))))))
-             (_ #f))))))
-    (define (maybe-fold-value! label name def)
-      (call-with-values (lambda () (lookup-post-type typev label def 0))
-        (lambda (type min max)
-          (cond
-           ((and (not (zero? type))
-                 (zero? (logand type (1- type)))
-                 (zero? (logand type (lognot &scalar-types)))
-                 (eqv? min max))
-            (bitvector-set! folded? (label->idx label) #t)
-            (vector-set! folded-values (label->idx label)
-                         (scalar-value type min))
-            #t)
-           (else #f)))))
-    (define (maybe-fold-unary-branch! label name arg)
-      (let* ((folder (hashq-ref *branch-folders* name)))
-        (when folder
-          (call-with-values (lambda () (lookup-pre-type typev label arg))
-            (lambda (type min max)
-              (call-with-values (lambda () (folder type min max))
-                (lambda (f? v)
-                  (bitvector-set! folded? (label->idx label) f?)
-                  (vector-set! folded-values (label->idx label) v))))))))
-    (define (maybe-fold-binary-branch! label name arg0 arg1)
-      (let* ((folder (hashq-ref *branch-folders* name)))
-        (when folder
-          (call-with-values (lambda () (lookup-pre-type typev label arg0))
-            (lambda (type0 min0 max0)
-              (call-with-values (lambda () (lookup-pre-type typev label arg1))
-                (lambda (type1 min1 max1)
-                  (call-with-values (lambda ()
-                                      (folder type0 min0 max0 type1 min1 max1))
-                    (lambda (f? v)
-                      (bitvector-set! folded? (label->idx label) f?)
-                      (vector-set! folded-values (label->idx label) v))))))))))
-    (define (visit-cont cont)
-      (match cont
-        (($ $cont label ($ $kargs _ _ body))
-         (visit-term body label))
-        (($ $cont label ($ $kclause arity body alternate))
-         (visit-cont body)
-         (visit-cont alternate))
-        (_ #f)))
-    (define (visit-term term label)
-      (match term
-        (($ $letk conts body)
-         (for-each visit-cont conts)
-         (visit-term body label))
-        (($ $continue k src ($ $primcall name args))
-         ;; We might be able to fold primcalls that define a value.
-         (match (lookup-cont k dfg)
-           (($ $kargs (_) (def))
-            ;(pk 'maybe-fold-value src name args)
-            (unless (maybe-fold-value! label name def)
-              (maybe-reduce-primcall! label k src name args)))
-           (_
-            (maybe-reduce-primcall! label k src name args))))
-        (($ $continue kf src ($ $branch kt ($ $primcall name args)))
-         ;; We might be able to fold primcalls that branch.
-         ;(pk 'maybe-fold-branch label src name args)
-         (match args
-           ((arg)
-            (maybe-fold-unary-branch! label name arg))
-           ((arg0 arg1)
-            (maybe-fold-binary-branch! label name arg0 arg1))))
-        (_ #f)))
-    (when typev
-      (match fun
-        (($ $cont kfun ($ $kfun src meta self tail clause))
-         (visit-cont clause))))
-    (values folded? folded-values reduced-terms)))
-
-(define (fold-constants* fun dfg)
-  (match fun
-    (($ $cont min-label ($ $kfun _ _ min-var))
-     (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
-       (lambda (folded? folded-values reduced-terms)
-         (define (label->idx label) (- label min-label))
-         (define (var->idx var) (- var min-var))
-         (define (visit-cont cont)
-           (rewrite-cps-cont cont
-             (($ $cont label ($ $kargs names syms body))
-              (label ($kargs names syms ,(visit-term body label))))
-             (($ $cont label ($ $kclause arity body alternate))
-              (label ($kclause ,arity ,(visit-cont body)
-                               ,(and alternate (visit-cont alternate)))))
-             (_ ,cont)))
-         (define (visit-term term label)
-           (rewrite-cps-term term
-             (($ $letk conts body)
-              ($letk ,(map visit-cont conts)
-                ,(visit-term body label)))
-             (($ $continue k src (and fun ($ $fun)))
-              ($continue k src ,(visit-fun fun)))
-             (($ $continue k src ($ $rec names vars funs))
-              ($continue k src ($rec names vars (map visit-fun funs))))
-             (($ $continue k src (and primcall ($ $primcall name args)))
-              ,(cond
-                ((bitvector-ref folded? (label->idx label))
-                 (let ((val (vector-ref folded-values (label->idx label))))
-                   ;; Uncomment for debugging.
-                   ;; (pk 'folded src primcall val)
-                   (let-fresh (k*) (v*)
-                     ;; Rely on DCE to elide this expression, if
-                     ;; possible.
-                     (build-cps-term
-                       ($letk ((k* ($kargs (#f) (v*)
-                                     ($continue k src ($const val)))))
-                         ($continue k* src ,primcall))))))
-                (else
-                 (or (vector-ref reduced-terms (label->idx label))
-                     term))))
-             (($ $continue kf src ($ $branch kt ($ $primcall)))
-              ,(if (bitvector-ref folded? (label->idx label))
-                   ;; Folded branch.
-                   (let ((val (vector-ref folded-values (label->idx label))))
-                     (build-cps-term
-                       ($continue (if val kt kf) src ($values ()))))
-                   term))
-             (_ ,term)))
-         (define (visit-fun fun)
-           (rewrite-cps-exp fun
-             (($ $fun body)
-              ($fun ,(fold-constants* body dfg)))))
-         (rewrite-cps-cont fun
-           (($ $cont kfun ($ $kfun src meta self tail clause))
-            (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
-
-(define (type-fold fun)
-  (let* ((fun (renumber fun))
-         (dfg (compute-dfg fun)))
-    (with-fresh-name-state-from-dfg dfg
-      (fold-constants* fun dfg))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
deleted file mode 100644
index 5e0b2d083..000000000
--- a/module/language/cps/types.scm
+++ /dev/null
@@ -1,1424 +0,0 @@
-;;; Type analysis on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-;;;
-;;; This library is free software: you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public 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 program.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; Type analysis computes the possible types and ranges that values may
-;;; have at all program positions.  This analysis can help to prove that
-;;; a primcall has no side-effects, if its arguments have the
-;;; appropriate type and range.  It can also enable constant folding of
-;;; type predicates and, in the future, enable the compiler to choose
-;;; untagged, unboxed representations for numbers.
-;;;
-;;; For the purposes of this analysis, a "type" is an aspect of a value
-;;; that will not change.  Guile's CPS intermediate language does not
-;;; carry manifest type information that asserts properties about given
-;;; values; instead, we recover this information via flow analysis,
-;;; garnering properties from type predicates, constant literals,
-;;; primcall results, and primcalls that assert that their arguments are
-;;; of particular types.
-;;;
-;;; A range denotes a subset of the set of values in a type, bounded by
-;;; a minimum and a maximum.  The precise meaning of a range depends on
-;;; the type.  For real numbers, the range indicates an inclusive lower
-;;; and upper bound on the integer value of a type.  For vectors, the
-;;; range indicates the length of the vector.  The range is limited to a
-;;; signed 32-bit value, with the smallest and largest values indicating
-;;; -inf.0 and +inf.0, respectively.  For some types, like pairs, the
-;;; concept of "range" makes no sense.  In these cases we consider the
-;;; range to be -inf.0 to +inf.0.
-;;;
-;;; Types are represented as a bitfield.  Fewer bits means a more precise
-;;; type.  Although normally only values that have a single type will
-;;; have an associated range, this is not enforced.  The range applies
-;;; to all types in the bitfield.  When control flow meets, the types and
-;;; ranges meet with the union operator.
-;;;
-;;; It is not practical to precisely compute value ranges in all cases.
-;;; For example, in the following case:
-;;;
-;;;   (let lp ((n 0)) (when (foo) (lp (1+ n))))
-;;;
-;;; The first time that range analysis visits the program, N is
-;;; determined to be the exact integer 0.  The second time, it is an
-;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on.
-;;; This analysis will terminate, but only after the positive half of
-;;; the 32-bit range has been fully explored and we decide that the
-;;; range of N is [0, +inf.0].  At the same time, we want to do range
-;;; analysis and type analysis at the same time, as there are
-;;; interactions between them, notably in the case of `sqrt' which
-;;; returns a complex number if its argument cannot be proven to be
-;;; non-negative.  So what we do is, once the types reach a fixed point,
-;;; we cause control-flow joins that would expand the range of a value
-;;; to saturate that range towards positive or infinity (as
-;;; appropriate).
-;;;
-;;; A naive approach to type analysis would build up a table that has
-;;; entries for all variables at all program points, but this has
-;;; N-squared complexity and quickly grows unmanageable.  Instead, we
-;;; use _intmaps_ from (language cps intmap) to share state between
-;;; connected program points.
-;;;
-;;; Code:
-
-(define-module (language cps types)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps intmap)
-  #:use-module (rnrs bytevectors)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
-  #:export (;; Specific types.
-            &exact-integer
-            &flonum
-            &complex
-            &fraction
-
-            &char
-            &unspecified
-            &unbound
-            &false
-            &true
-            &nil
-            &null
-            &symbol
-            &keyword
-
-            &procedure
-
-            &pointer
-            &fluid
-            &pair
-            &vector
-            &box
-            &struct
-            &string
-            &bytevector
-            &bitvector
-            &array
-            &hash-table
-
-            ;; Union types.
-            &number &real
-
-            infer-types
-            lookup-pre-type
-            lookup-post-type
-            primcall-types-check?))
-
-(define-syntax define-flags
-  (lambda (x)
-    (syntax-case x ()
-      ((_ all shift name ...)
-       (let ((count (length #'(name ...))))
-         (with-syntax (((n ...) (iota count))
-                       (count count))
-           #'(begin
-               (define-syntax name (identifier-syntax (ash 1 n)))
-               ...
-               (define-syntax all (identifier-syntax (1- (ash 1 count))))
-               (define-syntax shift (identifier-syntax count)))))))))
-
-;; More precise types have fewer bits.
-(define-flags &all-types &type-bits
-  &exact-integer
-  &flonum
-  &complex
-  &fraction
-
-  &char
-  &unspecified
-  &unbound
-  &false
-  &true
-  &nil
-  &null
-  &symbol
-  &keyword
-
-  &procedure
-
-  &pointer
-  &fluid
-  &pair
-  &vector
-  &box
-  &struct
-  &string
-  &bytevector
-  &bitvector
-  &array
-  &hash-table)
-
-(define-syntax &no-type (identifier-syntax 0))
-
-(define-syntax &number
-  (identifier-syntax (logior &exact-integer &flonum &complex &fraction)))
-(define-syntax &real
-  (identifier-syntax (logior &exact-integer &flonum &fraction)))
-
-(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1)))
-(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31))))
-
-;; Versions of min and max that do not coerce exact numbers to become
-;; inexact.
-(define min
-  (case-lambda
-    ((a b) (if (< a b) a b))
-    ((a b c) (min (min a b) c))
-    ((a b c d) (min (min a b) c d))))
-(define max
-  (case-lambda
-    ((a b) (if (> a b) a b))
-    ((a b c) (max (max a b) c))
-    ((a b c d) (max (max a b) c d))))
-
-
-
-(define-syntax-rule (define-compile-time-value name val)
-  (define-syntax name
-    (make-variable-transformer
-     (lambda (x)
-       (syntax-case x (set!)
-         (var (identifier? #'var)
-              (datum->syntax #'var val)))))))
-
-(define-compile-time-value min-fixnum most-negative-fixnum)
-(define-compile-time-value max-fixnum most-positive-fixnum)
-
-(define-inlinable (make-unclamped-type-entry type min max)
-  (vector type min max))
-(define-inlinable (type-entry-type tentry)
-  (vector-ref tentry 0))
-(define-inlinable (type-entry-clamped-min tentry)
-  (vector-ref tentry 1))
-(define-inlinable (type-entry-clamped-max tentry)
-  (vector-ref tentry 2))
-
-(define-syntax-rule (clamp-range val)
-  (cond
-   ((< val min-fixnum) min-fixnum)
-   ((< max-fixnum val) max-fixnum)
-   (else val)))
-
-(define-inlinable (make-type-entry type min max)
-  (vector type (clamp-range min) (clamp-range max)))
-(define-inlinable (type-entry-min tentry)
-  (let ((min (type-entry-clamped-min tentry)))
-    (if (eq? min min-fixnum) -inf.0 min)))
-(define-inlinable (type-entry-max tentry)
-  (let ((max (type-entry-clamped-max tentry)))
-    (if (eq? max max-fixnum) +inf.0 max)))
-
-(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))
-
-(define* (var-type-entry typeset var #:optional (default all-types-entry))
-  (intmap-ref typeset var (lambda (_) default)))
-
-(define (var-type typeset var)
-  (type-entry-type (var-type-entry typeset var)))
-(define (var-min typeset var)
-  (type-entry-min (var-type-entry typeset var)))
-(define (var-max typeset var)
-  (type-entry-max (var-type-entry typeset var)))
-
-;; Is the type entry A contained entirely within B?
-(define (type-entry<=? a b)
-  (match (cons a b)
-    ((#(a-type a-min a-max) . #(b-type b-min b-max))
-     (and (eqv? b-type (logior a-type b-type))
-          (<= b-min a-min)
-          (>= b-max a-max)))))
-
-(define (type-entry-union a b)
-  (cond
-   ((type-entry<=? b a) a)
-   ((type-entry<=? a b) b)
-   (else (make-type-entry
-          (logior (type-entry-type a) (type-entry-type b))
-          (min (type-entry-clamped-min a) (type-entry-clamped-min b))
-          (max (type-entry-clamped-max a) (type-entry-clamped-max b))))))
-
-(define (type-entry-intersection a b)
-  (cond
-   ((type-entry<=? a b) a)
-   ((type-entry<=? b a) b)
-   (else (make-type-entry
-          (logand (type-entry-type a) (type-entry-type b))
-          (max (type-entry-clamped-min a) (type-entry-clamped-min b))
-          (min (type-entry-clamped-max a) (type-entry-clamped-max b))))))
-
-(define (adjoin-var typeset var entry)
-  (intmap-add typeset var entry type-entry-union))
-
-(define (restrict-var typeset var entry)
-  (intmap-add typeset var entry type-entry-intersection))
-
-(define (constant-type val)
-  "Compute the type and range of VAL.  Return three values: the type,
-minimum, and maximum."
-  (define (return type val)
-    (if val
-        (make-type-entry type val val)
-        (make-type-entry type -inf.0 +inf.0)))
-  (cond
-   ((number? val)
-    (cond
-     ((exact-integer? val) (return &exact-integer val))
-     ((eqv? (imag-part val) 0)
-      (if (nan? val)
-          (make-type-entry &flonum -inf.0 +inf.0)
-          (make-type-entry
-           (if (exact? val) &fraction &flonum)
-           (if (rational? val) (inexact->exact (floor val)) val)
-           (if (rational? val) (inexact->exact (ceiling val)) val))))
-     (else (return &complex #f))))
-   ((eq? val '()) (return &null #f))
-   ((eq? val #nil) (return &nil #f))
-   ((eq? val #t) (return &true #f))
-   ((eq? val #f) (return &false #f))
-   ((char? val) (return &char (char->integer val)))
-   ((eqv? val *unspecified*) (return &unspecified #f))
-   ((symbol? val) (return &symbol #f))
-   ((keyword? val) (return &keyword #f))
-   ((pair? val) (return &pair #f))
-   ((vector? val) (return &vector (vector-length val)))
-   ((string? val) (return &string (string-length val)))
-   ((bytevector? val) (return &bytevector (bytevector-length val)))
-   ((bitvector? val) (return &bitvector (bitvector-length val)))
-   ((array? val) (return &array (array-rank val)))
-   ((not (variable-bound? (make-variable val))) (return &unbound #f))
-
-   (else (error "unhandled constant" val))))
-
-(define *type-checkers* (make-hash-table))
-(define *type-inferrers* (make-hash-table))
-
-(define-syntax-rule (define-type-helper name)
-  (define-syntax-parameter name
-    (lambda (stx)
-      (syntax-violation 'name
-                        "macro used outside of define-type"
-                        stx))))
-(define-type-helper define!)
-(define-type-helper restrict!)
-(define-type-helper &type)
-(define-type-helper &min)
-(define-type-helper &max)
-
-(define-syntax-rule (define-type-checker (name arg ...) body ...)
-  (hashq-set!
-   *type-checkers*
-   'name
-   (lambda (typeset arg ...)
-     (syntax-parameterize
-         ((&type (syntax-rules () ((_ val) (var-type typeset val))))
-          (&min  (syntax-rules () ((_ val) (var-min typeset val))))
-          (&max  (syntax-rules () ((_ val) (var-max typeset val)))))
-       body ...))))
-
-(define-syntax-rule (check-type arg type min max)
-  ;; If the arg is negative, it is a closure variable.
-  (and (>= arg 0)
-       (zero? (logand (lognot type) (&type arg)))
-       (<= min (&min arg))
-       (<= (&max arg) max)))
-
-(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
-  (hashq-set!
-   *type-inferrers*
-   'name
-   (lambda (in succ var ...)
-     (let ((out in))
-       (syntax-parameterize
-           ((define!
-              (syntax-rules ()
-                ((_ val type min max)
-                 (set! out (adjoin-var out val
-                                       (make-type-entry type min max))))))
-            (restrict!
-             (syntax-rules ()
-               ((_ val type min max)
-                (set! out (restrict-var out val
-                                        (make-type-entry type min max))))))
-            (&type (syntax-rules () ((_ val) (var-type in val))))
-            (&min  (syntax-rules () ((_ val) (var-min in val))))
-            (&max  (syntax-rules () ((_ val) (var-max in val)))))
-         body ...
-         out)))))
-
-(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
-  (define-type-inferrer* (name succ arg ...) body ...))
-
-(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
-  (define-type-inferrer* (name succ arg ...)
-    (let ((true? (not (zero? succ))))
-      body ...)))
-
-(define-syntax define-simple-type-checker
-  (lambda (x)
-    (define (parse-spec l)
-      (syntax-case l ()
-        (() '())
-        (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
-        (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
-        ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
-    (syntax-case x ()
-      ((_ (name arg-spec ...) result-spec ...)
-       (with-syntax
-           (((arg ...) (generate-temporaries #'(arg-spec ...)))
-            (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))))
-         #'(define-type-checker (name arg ...)
-             (and (check-type arg arg-type arg-min arg-max)
-                  ...)))))))
-
-(define-syntax define-simple-type-inferrer
-  (lambda (x)
-    (define (parse-spec l)
-      (syntax-case l ()
-        (() '())
-        (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
-        (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
-        ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
-    (syntax-case x ()
-      ((_ (name arg-spec ...) result-spec ...)
-       (with-syntax
-           (((arg ...) (generate-temporaries #'(arg-spec ...)))
-            (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))
-            ((res ...) (generate-temporaries #'(result-spec ...)))
-            (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...))))
-         #'(define-type-inferrer (name arg ... res ...)
-             (restrict! arg arg-type arg-min arg-max)
-             ...
-             (define! res res-type res-min res-max)
-             ...))))))
-
-(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...)
-  (begin
-    (define-simple-type-checker (name arg-spec ...))
-    (define-simple-type-inferrer (name arg-spec ...) result-spec ...)))
-
-(define-syntax-rule (define-simple-types
-                      ((name arg-spec ...) result-spec ...)
-                      ...)
-  (begin
-    (define-simple-type (name arg-spec ...) result-spec ...)
-    ...))
-
-(define-syntax-rule (define-type-checker-aliases orig alias ...)
-  (let ((check (hashq-ref *type-checkers* 'orig)))
-    (hashq-set! *type-checkers* 'alias check)
-    ...))
-(define-syntax-rule (define-type-inferrer-aliases orig alias ...)
-  (let ((check (hashq-ref *type-inferrers* 'orig)))
-    (hashq-set! *type-inferrers* 'alias check)
-    ...))
-(define-syntax-rule (define-type-aliases orig alias ...)
-  (begin
-    (define-type-checker-aliases orig alias ...)
-    (define-type-inferrer-aliases orig alias ...)))
-
-
-
-
-;;; This list of primcall type definitions follows the order of
-;;; effects-analysis.scm; please keep it in a similar order.
-;;;
-;;; There is no need to add checker definitions for expressions that do
-;;; not exhibit the &type-check effect, as callers should not ask if
-;;; such an expression does or does not type-check.  For those that do
-;;; exhibit &type-check, you should define a type inferrer unless the
-;;; primcall will never typecheck.
-;;;
-;;; Likewise there is no need to define inferrers for primcalls which
-;;; return &all-types values and which never raise exceptions from which
-;;; we can infer the types of incoming values.
-
-
-
-
-;;;
-;;; Generic effect-free predicates.
-;;;
-
-(define-predicate-inferrer (eq? a b true?)
-  ;; We can only propagate information down the true leg.
-  (when true?
-    (let ((type (logand (&type a) (&type b)))
-          (min (max (&min a) (&min b)))
-          (max (min (&max a) (&max b))))
-      (restrict! a type min max)
-      (restrict! b type min max))))
-(define-type-inferrer-aliases eq? eqv? equal?)
-
-(define-syntax-rule (define-simple-predicate-inferrer predicate type)
-  (define-predicate-inferrer (predicate val true?)
-    (let ((type (if true?
-                    type
-                    (logand (&type val) (lognot type)))))
-      (restrict! val type -inf.0 +inf.0))))
-(define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer null? &null)
-(define-simple-predicate-inferrer nil? &nil)
-(define-simple-predicate-inferrer symbol? &symbol)
-(define-simple-predicate-inferrer variable? &box)
-(define-simple-predicate-inferrer vector? &vector)
-(define-simple-predicate-inferrer struct? &struct)
-(define-simple-predicate-inferrer string? &string)
-(define-simple-predicate-inferrer bytevector? &bytevector)
-(define-simple-predicate-inferrer bitvector? &bitvector)
-(define-simple-predicate-inferrer keyword? &keyword)
-(define-simple-predicate-inferrer number? &number)
-(define-simple-predicate-inferrer char? &char)
-(define-simple-predicate-inferrer procedure? &procedure)
-(define-simple-predicate-inferrer thunk? &procedure)
-
-
-
-;;;
-;;; Fluids.  Note that we can't track bound-ness of fluids, as pop-fluid
-;;; can change boundness.
-;;;
-
-(define-simple-types
-  ((fluid-ref (&fluid 1)) &all-types)
-  ((fluid-set! (&fluid 0 1) &all-types))
-  ((push-fluid (&fluid 0 1) &all-types))
-  ((pop-fluid)))
-
-
-
-
-;;;
-;;; Prompts.  (Nothing to do.)
-;;;
-
-
-
-
-;;;
-;;; Pairs.
-;;;
-
-(define-simple-types
-  ((cons &all-types &all-types) &pair)
-  ((car &pair) &all-types)
-  ((set-car! &pair &all-types))
-  ((cdr &pair) &all-types)
-  ((set-cdr! &pair &all-types)))
-
-
-
-
-;;;
-;;; Variables.
-;;;
-
-(define-simple-types
-  ((box &all-types) (&box 1))
-  ((box-ref (&box 1)) &all-types))
-
-(define-simple-type-checker (box-set! (&box 0 1) &all-types))
-(define-type-inferrer (box-set! box val)
-  (restrict! box &box 1 1))
-
-
-
-
-;;;
-;;; Vectors.
-;;;
-
-;; This max-vector-len computation is a hack.
-(define *max-vector-len* (ash most-positive-fixnum -5))
-
-(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*)
-                                         &all-types))
-(define-type-inferrer (make-vector size init result)
-  (restrict! size &exact-integer 0 *max-vector-len*)
-  (define! result &vector (max (&min size) 0) (&max size)))
-
-(define-type-checker (vector-ref v idx)
-  (and (check-type v &vector 0 *max-vector-len*)
-       (check-type idx &exact-integer 0 (1- (&min v)))))
-(define-type-inferrer (vector-ref v idx result)
-  (restrict! v &vector (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max v)))
-  (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker (vector-set! v idx val)
-  (and (check-type v &vector 0 *max-vector-len*)
-       (check-type idx &exact-integer 0 (1- (&min v)))))
-(define-type-inferrer (vector-set! v idx val)
-  (restrict! v &vector (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max v))))
-
-(define-type-aliases make-vector make-vector/immediate)
-(define-type-aliases vector-ref vector-ref/immediate)
-(define-type-aliases vector-set! vector-set!/immediate)
-
-(define-simple-type-checker (vector-length &vector))
-(define-type-inferrer (vector-length v result)
-  (restrict! v &vector 0 *max-vector-len*)
-  (define! result &exact-integer (max (&min v) 0)
-    (min (&max v) *max-vector-len*)))
-
-
-
-
-;;;
-;;; Structs.
-;;;
-
-;; No type-checker for allocate-struct, as we can't currently check that
-;; vt is actually a vtable.
-(define-type-inferrer (allocate-struct vt size result)
-  (restrict! vt &struct vtable-offset-user +inf.0)
-  (restrict! size &exact-integer 0 +inf.0)
-  (define! result &struct (max (&min size) 0) (&max size)))
-
-(define-type-checker (struct-ref s idx)
-  (and (check-type s &struct 0 +inf.0)
-       (check-type idx &exact-integer 0 +inf.0)
-       ;; FIXME: is the field readable?
-       (< (&max idx) (&min s))))
-(define-type-inferrer (struct-ref s idx result)
-  (restrict! s &struct (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max s)))
-  (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker (struct-set! s idx val)
-  (and (check-type s &struct 0 +inf.0)
-       (check-type idx &exact-integer 0 +inf.0)
-       ;; FIXME: is the field writable?
-       (< (&max idx) (&min s))))
-(define-type-inferrer (struct-set! s idx val)
-  (restrict! s &struct (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max s))))
-
-(define-type-aliases allocate-struct allocate-struct/immediate)
-(define-type-aliases struct-ref struct-ref/immediate)
-(define-type-aliases struct-set! struct-set!/immediate)
-
-(define-simple-type (struct-vtable (&struct 0 +inf.0))
-  (&struct vtable-offset-user +inf.0))
-
-
-
-
-;;;
-;;; Strings.
-;;;
-
-(define *max-char* (1- (ash 1 24)))
-
-(define-type-checker (string-ref s idx)
-  (and (check-type s &string 0 +inf.0)
-       (check-type idx &exact-integer 0 +inf.0)
-       (< (&max idx) (&min s))))
-(define-type-inferrer (string-ref s idx result)
-  (restrict! s &string (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max s)))
-  (define! result &char 0 *max-char*))
-
-(define-type-checker (string-set! s idx val)
-  (and (check-type s &string 0 +inf.0)
-       (check-type idx &exact-integer 0 +inf.0)
-       (check-type val &char 0 *max-char*)
-       (< (&max idx) (&min s))))
-(define-type-inferrer (string-set! s idx val)
-  (restrict! s &string (1+ (&min idx)) +inf.0)
-  (restrict! idx &exact-integer 0 (1- (&max s)))
-  (restrict! val &char 0 *max-char*))
-
-(define-simple-type-checker (string-length &string))
-(define-type-inferrer (string-length s result)
-  (restrict! s &string 0 +inf.0)
-  (define! result &exact-integer (max (&min s) 0) (&max s)))
-
-(define-simple-type (number->string &number) (&string 0 +inf.0))
-(define-simple-type (string->number (&string 0 +inf.0))
-  ((logior &number &false) -inf.0 +inf.0))
-
-
-
-
-;;;
-;;; Bytevectors.
-;;;
-
-(define-simple-type-checker (bytevector-length &bytevector))
-(define-type-inferrer (bytevector-length bv result)
-  (restrict! bv &bytevector 0 +inf.0)
-  (define! result &exact-integer (max (&min bv) 0) (&max bv)))
-
-(define-syntax-rule (define-bytevector-accessors ref set type size min max)
-  (begin
-    (define-type-checker (ref bv idx)
-      (and (check-type bv &bytevector 0 +inf.0)
-           (check-type idx &exact-integer 0 +inf.0)
-           (< (&max idx) (- (&min bv) size))))
-    (define-type-inferrer (ref bv idx result)
-      (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
-      (restrict! idx &exact-integer 0 (- (&max bv) size))
-      (define! result type min max))
-    (define-type-checker (set bv idx val)
-      (and (check-type bv &bytevector 0 +inf.0)
-           (check-type idx &exact-integer 0 +inf.0)
-           (check-type val type min max)
-           (< (&max idx) (- (&min bv) size))))
-    (define-type-inferrer (set! bv idx val)
-      (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
-      (restrict! idx &exact-integer 0 (- (&max bv) size))
-      (restrict! val type min max))))
-
-(define-syntax-rule (define-short-bytevector-accessors ref set size signed?)
-  (define-bytevector-accessors ref set &exact-integer size
-    (if signed? (- (ash 1 (1- (* size 8)))) 0)
-    (1- (ash 1 (if signed? (1- (* size 8)) (* size 8))))))
-
-(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f)
-(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t)
-(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f)
-(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t)
-
-;; The range analysis only works on signed 32-bit values, so some limits
-;; are out of range.
-(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0)
-(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0)
-(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0)
-(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0)
-(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0)
-(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0)
-
-
-
-
-;;;
-;;; Numbers.
-;;;
-
-;; First, branching primitives with no results.
-(define-simple-type-checker (= &number &number))
-(define-predicate-inferrer (= a b true?)
-  (when (and true?
-             (zero? (logand (logior (&type a) (&type b)) (lognot &number))))
-    (let ((min (max (&min a) (&min b)))
-          (max (min (&max a) (&max b))))
-      (restrict! a &number min max)
-      (restrict! b &number min max))))
-
-(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1)
-  (define (infer-integer-ranges)
-    (match op
-      ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
-      ('<= (values min0 (min max0 max1) (max min0 min1) max1))
-      ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
-      ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
-  (define (infer-real-ranges)
-    (match op
-      ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
-      ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
-  (if (= (logior type0 type1) &exact-integer)
-      (infer-integer-ranges)
-      (infer-real-ranges)))
-
-(define-syntax-rule (define-comparison-inferrer (op inverse))
-  (define-predicate-inferrer (op a b true?)
-    (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
-      (call-with-values
-          (lambda ()
-            (restricted-comparison-ranges (if true? 'op 'inverse)
-                                          (&type a) (&min a) (&max a)
-                                          (&type b) (&min b) (&max b)))
-        (lambda (min0 max0 min1 max1)
-          (restrict! a &real min0 max0)
-          (restrict! b &real min1 max1))))))
-
-(define-simple-type-checker (< &real &real))
-(define-comparison-inferrer (< >=))
-
-(define-simple-type-checker (<= &real &real))
-(define-comparison-inferrer (<= >))
-
-(define-simple-type-checker (>= &real &real))
-(define-comparison-inferrer (>= <))
-
-(define-simple-type-checker (> &real &real))
-(define-comparison-inferrer (> <=))
-
-;; Arithmetic.
-(define-syntax-rule (define-unary-result! a result min max)
-  (let ((min* min)
-        (max* max)
-        (type (logand (&type a) &number)))
-    (cond
-     ((not (= type (&type a)))
-      ;; Not a number.  Punt and do nothing.
-      (define! result &all-types -inf.0 +inf.0))
-     ;; Complex numbers don't have a range.
-     ((eqv? type &complex)
-      (define! result &complex -inf.0 +inf.0))
-     (else
-      (define! result type min* max*)))))
-
-(define-syntax-rule (define-binary-result! a b result closed? min max)
-  (let ((min* min)
-        (max* max)
-        (a-type (logand (&type a) &number))
-        (b-type (logand (&type b) &number)))
-    (cond
-     ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
-      ;; One input not a number.  Perhaps we end up dispatching to
-      ;; GOOPS.
-      (define! result &all-types -inf.0 +inf.0))
-     ;; Complex and floating-point numbers are contagious.
-     ((or (eqv? a-type &complex) (eqv? b-type &complex))
-      (define! result &complex -inf.0 +inf.0))
-     ((or (eqv? a-type &flonum) (eqv? b-type &flonum))
-      (define! result &flonum min* max*))
-     ;; Exact integers are closed under some operations.
-     ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer))
-      (define! result &exact-integer min* max*))
-     (else
-      ;; Fractions may become integers.
-      (let ((type (logior a-type b-type)))
-        (define! result
-                 (if (zero? (logand type &fraction))
-                     type
-                     (logior type &exact-integer))
-                 min* max*))))))
-
-(define-simple-type-checker (add &number &number))
-(define-type-inferrer (add a b result)
-  (define-binary-result! a b result #t
-                         (+ (&min a) (&min b))
-                         (+ (&max a) (&max b))))
-
-(define-simple-type-checker (sub &number &number))
-(define-type-inferrer (sub a b result)
-  (define-binary-result! a b result #t
-                         (- (&min a) (&max b))
-                         (- (&max a) (&min b))))
-
-(define-simple-type-checker (mul &number &number))
-(define-type-inferrer (mul a b result)
-  (let ((min-a (&min a)) (max-a (&max a))
-        (min-b (&min b)) (max-b (&max b)))
-    (define (nan* a b)
-      ;; We only really get +inf.0 at runtime for flonums and compnums.
-      ;; If we have inferred that the arguments are not flonums and not
-      ;; compnums, then the result of (* +inf.0 0) at range inference
-      ;; time is 0 and not +nan.0.
-      (if (and (or (and (inf? a) (zero? b))
-                   (and (zero? a) (inf? b)))
-               (not (logtest (logior (&type a) (&type b))
-                             (logior &flonum &complex))))
-          0 
-          (* a b)))
-    (let ((-- (nan* min-a min-b))
-          (-+ (nan* min-a max-b))
-          (++ (nan* max-a max-b))
-          (+- (nan* max-a min-b)))
-      (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-))))
-        (define-binary-result! a b result #t
-                               (cond
-                                ((eqv? a b) 0)
-                                (has-nan? -inf.0)
-                                (else (min -- -+ ++ +-)))
-                               (if has-nan?
-                                   +inf.0
-                                   (max -- -+ ++ +-)))))))
-
-(define-type-checker (div a b)
-  (and (check-type a &number -inf.0 +inf.0)
-       (check-type b &number -inf.0 +inf.0)
-       ;; We only know that there will not be an exception if b is not
-       ;; zero.
-       (not (<= (&min b) 0 (&max b)))))
-(define-type-inferrer (div a b result)
-  (let ((min-a (&min a)) (max-a (&max a))
-        (min-b (&min b)) (max-b (&max b)))
-    (call-with-values
-        (lambda ()
-          (if (<= min-b 0 max-b)
-              ;; If the range of the divisor crosses 0, the result spans
-              ;; the whole range.
-              (values -inf.0 +inf.0)
-              ;; Otherwise min-b and max-b have the same sign, and cannot both
-              ;; be infinity.
-              (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b)))
-                    (-+- (if (inf? max-b) 0 (floor/ min-a max-b)))
-                    (++- (if (inf? max-b) 0 (floor/ max-a max-b)))
-                    (+-- (if (inf? min-b) 0 (floor/ max-a min-b)))
-                    (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b)))
-                    (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b)))
-                    (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b)))
-                    (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b))))
-                (values (min (min --- -+- ++- +--)
-                             (min --+ -++ +++ +-+))
-                        (max (max --- -+- ++- +--)
-                             (max --+ -++ +++ +-+))))))
-      (lambda (min max)
-        (define-binary-result! a b result #f min max)))))
-
-(define-simple-type-checker (add1 &number))
-(define-type-inferrer (add1 a result)
-  (define-unary-result! a result (1+ (&min a)) (1+ (&max a))))
-
-(define-simple-type-checker (sub1 &number))
-(define-type-inferrer (sub1 a result)
-  (define-unary-result! a result (1- (&min a)) (1- (&max a))))
-
-(define-type-checker (quo a b)
-  (and (check-type a &exact-integer -inf.0 +inf.0)
-       (check-type b &exact-integer -inf.0 +inf.0)
-       ;; We only know that there will not be an exception if b is not
-       ;; zero.
-       (not (<= (&min b) 0 (&max b)))))
-(define-type-inferrer (quo a b result)
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer -inf.0 +inf.0))
-
-(define-type-checker-aliases quo rem)
-(define-type-inferrer (rem a b result)
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  ;; Same sign as A.
-  (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b))))))
-    (cond
-     ((< (&min a) 0)
-      (if (< 0 (&max a))
-          (define! result &exact-integer (- max-abs-rem) max-abs-rem)
-          (define! result &exact-integer (- max-abs-rem) 0)))
-     (else
-      (define! result &exact-integer 0 max-abs-rem)))))
-
-(define-type-checker-aliases quo mod)
-(define-type-inferrer (mod a b result)
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  ;; Same sign as B.
-  (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b))))))
-    (cond
-     ((< (&min b) 0)
-      (if (< 0 (&max b))
-          (define! result &exact-integer (- max-abs-mod) max-abs-mod)
-          (define! result &exact-integer (- max-abs-mod) 0)))
-     (else
-      (define! result &exact-integer 0 max-abs-mod)))))
-
-;; Predicates.
-(define-syntax-rule (define-number-kind-predicate-inferrer name type)
-  (define-type-inferrer (name val result)
-    (cond
-     ((zero? (logand (&type val) type))
-      (define! result &false 0 0))
-     ((zero? (logand (&type val) (lognot type)))
-      (define! result &true 0 0))
-     (else
-      (define! result (logior &true &false) 0 0)))))
-(define-number-kind-predicate-inferrer complex? &number)
-(define-number-kind-predicate-inferrer real? &real)
-(define-number-kind-predicate-inferrer rational?
-  (logior &exact-integer &fraction))
-(define-number-kind-predicate-inferrer integer?
-  (logior &exact-integer &flonum))
-(define-number-kind-predicate-inferrer exact-integer?
-  &exact-integer)
-
-(define-simple-type-checker (exact? &number))
-(define-type-inferrer (exact? val result)
-  (restrict! val &number -inf.0 +inf.0)
-  (cond
-   ((zero? (logand (&type val) (logior &exact-integer &fraction)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
-
-(define-simple-type-checker (inexact? &number))
-(define-type-inferrer (inexact? val result)
-  (restrict! val &number -inf.0 +inf.0)
-  (cond
-   ((zero? (logand (&type val) (logior &flonum &complex)))
-    (define! result &false 0 0))
-   ((zero? (logand (&type val) (logand &number
-                                       (lognot (logior &flonum &complex)))))
-    (define! result &true 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
-
-(define-simple-type-checker (inf? &real))
-(define-type-inferrer (inf? val result)
-  (restrict! val &real -inf.0 +inf.0)
-  (cond
-   ((or (zero? (logand (&type val) (logior &flonum &complex)))
-        (and (not (inf? (&min val))) (not (inf? (&max val)))))
-    (define! result &false 0 0))
-   (else
-    (define! result (logior &true &false) 0 0))))
-
-(define-type-aliases inf? nan?)
-
-(define-simple-type (even? &exact-integer)
-  ((logior &true &false) 0 0))
-(define-type-aliases even? odd?)
-
-;; Bit operations.
-(define-simple-type-checker (ash &exact-integer &exact-integer))
-(define-type-inferrer (ash val count result)
-  (define (ash* val count)
-    ;; As we can only represent a 32-bit range, don't bother inferring
-    ;; shifts that might exceed that range.
-    (cond
-     ((inf? val) val) ; Preserves sign.
-     ((< -32 count 32) (ash val count))
-     ((zero? val) 0)
-     ((positive? val) +inf.0)
-     (else -inf.0)))
-  (restrict! val &exact-integer -inf.0 +inf.0)
-  (restrict! count &exact-integer -inf.0 +inf.0)
-  (let ((-- (ash* (&min val) (&min count)))
-        (-+ (ash* (&min val) (&max count)))
-        (++ (ash* (&max val) (&max count)))
-        (+- (ash* (&max val) (&min count))))
-    (define! result &exact-integer
-             (min -- -+ ++ +-)
-             (max -- -+ ++ +-))))
-
-(define (next-power-of-two n)
-  (let lp ((out 1))
-    (if (< n out)
-        out
-        (lp (ash out 1)))))
-
-(define-simple-type-checker (logand &exact-integer &exact-integer))
-(define-type-inferrer (logand a b result)
-  (define (logand-min a b)
-    (if (and (negative? a) (negative? b))
-        (min a b)
-        0))
-  (define (logand-max a b)
-    (if (and (positive? a) (positive? b))
-        (min a b)
-        0))
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
-           (logand-min (&min a) (&min b))
-           (logand-max (&max a) (&max b))))
-
-(define-simple-type-checker (logior &exact-integer &exact-integer))
-(define-type-inferrer (logior a b result)
-  ;; Saturate all bits of val.
-  (define (saturate val)
-    (1- (next-power-of-two val)))
-  (define (logior-min a b)
-    (cond ((and (< a 0) (<= 0 b)) a)
-          ((and (< b 0) (<= 0 a)) b)
-          (else (max a b))))
-  (define (logior-max a b)
-    ;; If either operand is negative, just assume the max is -1.
-    (cond
-     ((or (< a 0) (< b 0)) -1)
-     ((or (inf? a) (inf? b)) +inf.0)
-     (else (saturate (logior a b)))))
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
-           (logior-min (&min a) (&min b))
-           (logior-max (&max a) (&max b))))
-
-;; For our purposes, treat logxor the same as logior.
-(define-type-aliases logior logxor)
-
-(define-simple-type-checker (lognot &exact-integer))
-(define-type-inferrer (lognot a result)
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (define! result &exact-integer
-           (- -1 (&max a))
-           (- -1 (&min a))))
-
-(define-simple-type-checker (logtest &exact-integer &exact-integer))
-(define-predicate-inferrer (logtest a b true?)
-  (restrict! a &exact-integer -inf.0 +inf.0)
-  (restrict! b &exact-integer -inf.0 +inf.0))
-
-(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
-(define-type-inferrer (logbit? a b result)
-  (let ((a-min (&min a))
-        (a-max (&max a))
-        (b-min (&min b))
-        (b-max (&max b)))
-    (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
-             (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
-        (let ((type (if (logbit? a-min b-min) &true &false)))
-          (define! result type 0 0))
-        (define! result (logior &true &false) 0 0))))
-
-;; Flonums.
-(define-simple-type-checker (sqrt &number))
-(define-type-inferrer (sqrt x result)
-  (let ((type (&type x)))
-    (cond
-     ((and (zero? (logand type &complex)) (<= 0 (&min x)))
-      (define! result
-               (logior type &flonum)
-               (inexact->exact (floor (sqrt (&min x))))
-               (if (inf? (&max x))
-                   +inf.0
-                   (inexact->exact (ceiling (sqrt (&max x)))))))
-     (else
-      (define! result (logior type &flonum &complex) -inf.0 +inf.0)))))
-
-(define-simple-type-checker (abs &real))
-(define-type-inferrer (abs x result)
-  (let ((type (&type x)))
-    (cond
-     ((eqv? type (logand type &number))
-      (restrict! x &real -inf.0 +inf.0)
-      (define! result (logand type &real)
-        (min (abs (&min x)) (abs (&max x)))
-        (max (abs (&min x)) (abs (&max x)))))
-     (else
-      (define! result (logior (logand (&type x) (lognot &number))
-                              (logand (&type x) &real))
-        (max (&min x) 0)
-        (max (abs (&min x)) (abs (&max x))))))))
-
-
-
-
-;;;
-;;; Characters.
-;;;
-
-(define-simple-type (char<? &char &char)
-  ((logior &true &false) 0 0))
-(define-type-aliases char<? char<=? char>=? char>?)
-
-(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
-(define-type-inferrer (integer->char i result)
-  (restrict! i &exact-integer 0 #x10ffff)
-  (define! result &char (max (&min i) 0) (min (&max i) #x10ffff)))
-
-(define-simple-type-checker (char->integer &char))
-(define-type-inferrer (char->integer c result)
-  (restrict! c &char 0 #x10ffff)
-  (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff)))
-
-
-
-
-;;;
-;;; Type flow analysis: the meet (ahem) of the algorithm.
-;;;
-
-(define (infer-types* dfg min-label label-count)
-  "Compute types for all variables in @var{fun}.  Returns a hash table
-mapping symbols to types."
-  (let ((typev (make-vector label-count))
-        (idoms (compute-idoms dfg min-label label-count))
-        (revisit-label #f)
-        (types-changed? #f)
-        (saturate-ranges? #f))
-    (define (label->idx label) (- label min-label))
-
-    (define (get-entry label) (vector-ref typev (label->idx label)))
-
-    (define (in-types entry) (vector-ref entry 0))
-    (define (out-types entry succ) (vector-ref entry (1+ succ)))
-
-    (define (update-in-types! entry types) 
-      (vector-set! entry 0 types))
-    (define (update-out-types! entry succ types)
-      (vector-set! entry (1+ succ) types))
-
-    (define (prepare-initial-state!)
-      ;; The result is a vector with an entry for each label.  Each entry
-      ;; is a vector.  The first slot in the entry vector corresponds to
-      ;; the types that flow into the labelled expression.  The following
-      ;; slot is for the types that flow out to the first successor, and
-      ;; so on for additional successors.
-      (let lp ((label min-label))
-        (when (< label (+ min-label label-count))
-          (let* ((nsuccs (match (lookup-cont label dfg)
-                           (($ $kargs _ _ term)
-                            (match (find-call term)
-                              (($ $continue k src (or ($ $branch) ($ $prompt))) 2)
-                              (_ 1)))
-                           (($ $kfun src meta self tail clause) (if clause 1 0))
-                           (($ $kclause arity body alt) (if alt 2 1))
-                           (($ $kreceive) 1)
-                           (($ $ktail) 0)))
-                 (entry (make-vector (1+ nsuccs) #f)))
-            (vector-set! typev (label->idx label) entry)
-            (lp (1+ label)))))
-
-      ;; Initial state: nothing flows into the $kfun.
-      (let ((entry (get-entry min-label)))
-        (update-in-types! entry empty-intmap)))
-
-    (define (adjoin-vars types vars entry)
-      (match vars
-        (() types)
-        ((var . vars)
-         (adjoin-vars (adjoin-var types var entry) vars entry))))
-
-    (define (infer-primcall types succ name args result)
-      (cond
-       ((hashq-ref *type-inferrers* name)
-        => (lambda (inferrer)
-             ;; FIXME: remove the apply?
-             ;(pk 'primcall name args result)
-             (apply inferrer types succ
-                    (if result
-                        (append args (list result))
-                        args))))
-       (result
-        (adjoin-var types result all-types-entry))
-       (else
-        types)))
-
-    (define (type-entry-saturating-union a b)
-      (cond
-       ((type-entry<=? b a) a)
-       #;
-       ((and (not saturate-ranges?)
-         (eqv? (a-type ))
-         (type-entry<=? a b)) b)
-       (else (make-type-entry
-              (let* ((a-type (type-entry-type a))
-                     (b-type (type-entry-type b))
-                     (type (logior a-type b-type)))
-                (unless (eqv? a-type type)
-                  (set! types-changed? #t))
-                type)
-              (let ((a-min (type-entry-clamped-min a))
-                    (b-min (type-entry-clamped-min b)))
-                (if (< b-min a-min)
-                    (if saturate-ranges? min-fixnum b-min)
-                    a-min))
-              (let ((a-max (type-entry-clamped-max a))
-                    (b-max (type-entry-clamped-max b)))
-                (if (> b-max a-max)
-                    (if saturate-ranges? max-fixnum b-max)
-                    a-max))))))
-
-    (define (propagate-types! pred-label pred-entry succ-idx succ-label out)
-      ;; Update "in" set of continuation.
-      (let ((succ-entry (get-entry succ-label)))
-        (match (lookup-predecessors succ-label dfg)
-          ((_)
-           ;; A normal edge.
-           (update-in-types! succ-entry out))
-          (_
-           ;; A control-flow join.
-           (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label)))
-                  (succ-dom-entry (get-entry succ-dom-label))
-                  (old-in (in-types succ-entry))
-                  (in (if old-in
-                          (intmap-intersect old-in out
-                                            type-entry-saturating-union)
-                          out)))
-             ;; If the "in" set changed, update the entry and possibly
-             ;; arrange to iterate again.
-             (unless (eq? old-in in)
-               (update-in-types! succ-entry in)
-               ;; If the changed successor is a back-edge, ensure that
-               ;; we revisit the function.
-               (when (<= succ-label pred-label)
-                 (unless (and revisit-label (<= revisit-label succ-label))
-                   ;; (pk 'marking-revisit pred-label succ-label)
-                   (set! revisit-label succ-label))))))))
-      ;; Finally update "out" set for current expression.
-      (update-out-types! pred-entry succ-idx out))
-
-    (define (visit-exp label entry k types exp)
-      (define (propagate! succ-idx succ-label types)
-        (propagate-types! label entry succ-idx succ-label types))
-      ;; Each of these branches must propagate! to its successors.
-      (match exp
-        (($ $branch kt ($ $values (arg)))
-         ;; The "normal" continuation is the #f branch.
-         (let ((types (restrict-var types arg
-                                    (make-type-entry (logior &false &nil)
-                                                     0
-                                                     0))))
-           (propagate! 0 k types))
-         (let ((types (restrict-var types arg
-                                    (make-type-entry
-                                     (logand &all-types 
-                                             (lognot (logior &false &nil)))
-                                     -inf.0 +inf.0))))
-           (propagate! 1 kt types)))
-        (($ $branch kt ($ $primcall name args))
-         ;; The "normal" continuation is the #f branch.
-         (let ((types (infer-primcall types 0 name args #f)))
-           (propagate! 0 k types))
-         (let ((types (infer-primcall types 1 name args #f)))
-           (propagate! 1 kt types)))
-        (($ $prompt escape? tag handler)
-         ;; The "normal" continuation enters the prompt.
-         (propagate! 0 k types)
-         (propagate! 1 handler types))
-        (($ $primcall name args)
-         (propagate! 0 k
-                     (match (lookup-cont k dfg)
-                       (($ $kargs _ defs)
-                        (infer-primcall types 0 name args
-                                        (match defs ((var) var) (() #f))))
-                       (_
-                        ;(pk 'warning-no-restrictions name)
-                        types))))
-        (($ $values args)
-         (match (lookup-cont k dfg)
-           (($ $kargs _ defs)
-            (let ((in types))
-              (let lp ((defs defs) (args args) (out types))
-                (match (cons defs args)
-                  ((() . ())
-                   (propagate! 0 k out))
-                  (((def . defs) . (arg . args))
-                   (lp defs args
-                       (adjoin-var out def (var-type-entry in arg))))))))
-           (_
-            (propagate! 0 k types))))
-        ((or ($ $call) ($ $callk))
-         (propagate! 0 k types))
-        (($ $rec names vars funs)
-         (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))
-           (propagate! 0 k (adjoin-vars types vars proc-type))))
-        (_
-         (match (lookup-cont k dfg)
-           (($ $kargs (_) (var))
-            (let ((entry (match exp
-                           (($ $const val)
-                            (constant-type val))
-                           ((or ($ $prim) ($ $fun) ($ $closure))
-                            ;; Could be more precise here.
-                            (make-type-entry &procedure -inf.0 +inf.0)))))
-              (propagate! 0 k (adjoin-var types var entry))))))))
-
-    (prepare-initial-state!)
-
-    ;; Iterate over all labelled expressions in the function,
-    ;; propagating types and ranges to all successors.
-    (let lp ((label min-label))
-      ;(pk 'visit label)
-      (cond
-       ((< label (+ min-label label-count))
-        (let* ((entry (vector-ref typev (label->idx label)))
-               (types (in-types entry)))
-          (define (propagate! succ-idx succ-label types)
-            (propagate-types! label entry succ-idx succ-label types))
-          ;; Add types for new definitions, and restrict types of
-          ;; existing variables due to side effects.
-          (match (lookup-cont label dfg)
-            (($ $kargs names vars term)
-             (let visit-term ((term term) (types types))
-               (match term
-                 (($ $letk conts term)
-                  (visit-term term types))
-                 (($ $continue k src exp)
-                  (visit-exp label entry k types exp)))))
-            (($ $kreceive arity k)
-             (match (lookup-cont k dfg)
-               (($ $kargs names vars)
-                (propagate! 0 k
-                             (adjoin-vars types vars all-types-entry)))))
-            (($ $kfun src meta self tail clause)
-             (let ((types (adjoin-var types self all-types-entry)))
-               (match clause
-                 (#f #f)
-                 (($ $cont kclause)
-                  (propagate! 0 kclause types)))))
-            (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt)
-             (propagate! 0 kbody
-                         (adjoin-vars types vars all-types-entry))
-             (match alt
-               (#f #f)
-               (($ $cont kclause)
-                (propagate! 1 kclause types))))
-            (($ $ktail) #t)))
-
-        ;; And loop.
-        (lp (1+ label)))
-
-       ;; Iterate until we reach a fixed point.
-       (revisit-label
-        ;; Once the types have a fixed point, iterate until ranges also
-        ;; reach a fixed point, saturating ranges to accelerate
-        ;; convergence.
-        (unless types-changed?
-          (set! saturate-ranges? #t))
-        (set! types-changed? #f)
-        (let ((label revisit-label))
-          (set! revisit-label #f)
-          ;(pk 'looping)
-          (lp label)))
-
-       ;; All done!  Return the computed types.
-       (else typev)))))
-
-(define-record-type <type-analysis>
-  (make-type-analysis min-label label-count types)
-  type-analysis?
-  (min-label type-analysis-min-label)
-  (label-count type-analysis-label-count)
-  (types type-analysis-types))
-
-(define (infer-types fun dfg)
-  ;; Fun must be renumbered.
-  (match fun
-    (($ $cont min-label ($ $kfun))
-     (let ((label-count ((make-local-cont-folder label-count)
-                         (lambda (k cont label-count) (1+ label-count))
-                         fun 0)))
-       (make-type-analysis min-label label-count
-                           (infer-types* dfg min-label label-count))))))
-
-(define (lookup-pre-type analysis label def)
-  (match analysis
-    (($ <type-analysis> min-label label-count typev)
-     (let* ((entry (vector-ref typev (- label min-label)))
-            (tentry (var-type-entry (vector-ref entry 0) def)))
-       (values (type-entry-type tentry)
-               (type-entry-min tentry)
-               (type-entry-max tentry))))))
-
-(define (lookup-post-type analysis label def succ-idx)
-  (match analysis
-    (($ <type-analysis> min-label label-count typev)
-     (let* ((entry (vector-ref typev (- label min-label)))
-            (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def)))
-       (values (type-entry-type tentry)
-               (type-entry-min tentry)
-               (type-entry-max tentry))))))
-
-(define (primcall-types-check? analysis label name args)
-  (match (hashq-ref *type-checkers* name)
-    (#f #f)
-    (checker
-     (match analysis
-       (($ <type-analysis> min-label label-count typev)
-        (let ((entry (vector-ref typev (- label min-label))))
-          (apply checker (vector-ref entry 0) args)))))))