X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/6119a9059543e1985b8dd504e70d7a690db62ec2..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/cse.scm

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index ad1c4b36e..593346ee9 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -29,174 +29,186 @@
   #: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 (compute-always-available-expressions effects)
-  "Return the set of continuations whose values are always available
-within their dominance frontier.  This is the case for effects that have
-no dependencies and which cause no effects besides &type-check."
-  (let ((out (make-bitvector (vector-length effects) #f)))
-    (let lp ((n 0))
-      (cond
-       ((< n (vector-length effects))
-        (when (zero? (exclude-effects (vector-ref effects n) &type-check))
-          (bitvector-set! out n #t))
-        (lp (1+ n)))
-       (else out)))))
+(define (cont-successors cont)
+  (match cont
+    (($ $kargs names syms body)
+     (let lp ((body body))
+       (match body
+         (($ $letk conts body) (lp body))
+         (($ $letrec names vars funs 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 '()))))
 
-(define (compute-available-expressions dfg min-label label-count)
+    (($ $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 bitvectors, whose first
+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))
-         (always-avail (compute-always-available-expressions effects))
-         ;; Vector of bitvectors, indicating that at a continuation N,
-         ;; the values from continuations M... are available.
-         (avail-in (make-vector label-count #f))
-         (avail-out (make-vector label-count #f)))
+         ;; 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))
-      (when (< n label-count)
-        (let ((in (make-bitvector label-count #f))
-              (out (make-bitvector label-count #f)))
-          (vector-set! avail-in n in)
-          (vector-set! avail-out n out)
-          (lp (1+ n)))))
-
-    (let ((tmp (make-bitvector label-count #f)))
-      (define (bitvector-copy! dst src)
-        (bitvector-fill! dst #f)
-        (bit-set*! dst src #t))
-      (define (intersect! dst src)
-        (bitvector-copy! tmp src)
-        (bit-invert! tmp)
-        (bit-set*! dst tmp #f))
-      (let lp ((n 0) (first? #t) (changed? #f))
-        (cond
-         ((< n label-count)
-          (let* ((in (vector-ref avail-in n))
-                 (prev-count (bit-count #t in))
-                 (out (vector-ref avail-out n))
-                 (fx (vector-ref effects n)))
-            ;; Intersect avail-out from predecessors into "in".
-            (let lp ((preds (lookup-predecessors (idx->label n) dfg))
-                     (initialized? #f))
-              (match preds
-                (() #t)
-                ((pred . preds)
-                 (let ((pred (label->idx pred)))
-                   (cond
-                    ((and first? (<= n pred))
-                     ;; Avoid intersecting back-edges and cross-edges on
-                     ;; the first iteration.
-                     (lp preds initialized?))
-                    (else
-                     (if initialized?
-                         (intersect! in (vector-ref avail-out pred))
-                         (bitvector-copy! in (vector-ref avail-out pred)))
-                     (lp preds #t)))))))
-            (let ((new-count (bit-count #t in)))
-              (unless (= prev-count new-count)
-                ;; Copy "in" to "out".
-                (bitvector-copy! out in)
-                ;; Kill expressions that don't commute.
-                (cond
-                 ((causes-all-effects? fx &all-effects)
-                  ;; Fast-path if this expression clobbers the world.
-                  (intersect! out always-avail))
-                 ((effect-free? (exclude-effects fx &type-check))
-                  ;; Fast-path if this expression clobbers nothing.
-                  #t)
-                 (else
-                  ;; Loop of sadness.
-                  (bitvector-copy! tmp out)
-                  (bit-set*! tmp always-avail #f)
-                  (let lp ((i 0))
-                    (let ((i (bit-position #t tmp i)))
-                      (when i
-                        (unless (effects-commute? (vector-ref effects i) fx)
-                          (bitvector-set! out i #f))
-                        (lp (1+ i))))))))
-              (bitvector-set! out n #t)
-              (lp (1+ n) first? (or changed? (not (= prev-count new-count)))))))
-         (else
-          (if (or first? changed?)
-              (lp 0 #f #f)
-              (values avail-in effects))))))))
+      (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 bitvectors, each bitvector twice as
-long as LABEL-COUNT.  The first half of the bitvector indicates labels
-that may be true, and the second half those that may be false.  It could
-be that both true and false proofs are available."
-  (let ((boolv (make-vector label-count #f)))
+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) idx)
-    (define (false-idx idx) (+ idx label-count))
+    (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))
-      (when (< n label-count)
-        (let ((bool (make-bitvector (* label-count 2) #f)))
-          (vector-set! boolv n bool)
-          (lp (1+ n)))))
-
-    (let ((tmp (make-bitvector (* label-count 2) #f)))
-      (define (bitvector-copy! dst src)
-        (bitvector-fill! dst #f)
-        (bit-set*! dst src #t))
-      (define (intersect! dst src)
-        (bitvector-copy! tmp src)
-        (bit-invert! tmp)
-        (bit-set*! dst tmp #f))
-      (let lp ((n 0) (first? #t) (changed? #f))
-        (cond
-         ((< n label-count)
-          (let* ((label (idx->label n))
-                 (bool (vector-ref boolv n))
-                 (prev-count (bit-count #t bool)))
-            ;; Intersect truthiness from all predecessors.
-            (let lp ((preds (lookup-predecessors label dfg))
-                     (initialized? #f))
-              (match preds
-                (() #t)
-                ((pred . preds)
-                 (let ((pidx (label->idx pred)))
-                   (cond
-                    ((and first? (<= n pidx))
-                     ;; Avoid intersecting back-edges and cross-edges on
-                     ;; the first iteration.
-                     (lp preds initialized?))
-                    (else
-                     (if initialized?
-                         (intersect! bool (vector-ref boolv pidx))
-                         (bitvector-copy! bool (vector-ref boolv pidx)))
-                     (match (lookup-predecessors pred dfg)
-                       ((test)
-                        (let ((tidx (label->idx test)))
-                          (match (lookup-cont pred dfg)
-                            (($ $kif kt kf)
-                             (when (eqv? kt label)
-                               (bitvector-set! bool (true-idx tidx) #t))
-                             (when (eqv? kf label)
-                               (bitvector-set! bool (false-idx tidx) #t)))
-                            (_ #t))))
-                       (_ #t))
-                     (lp preds #t)))))))
-            (lp (1+ n) first?
-                (or changed?
-                    (not (= prev-count (bit-count #t bool)))))))
-         (else
-          (if (or first? changed?)
-              (lp 0 #f #f)
-              boolv)))))))
+      (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.
@@ -220,7 +232,6 @@ be that both true and false proofs are available."
             (cont-defs kargs))
            (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
             syms)
-           (($ $kif) '())
            (($ $kfun src meta self) (list self))
            (($ $ktail) '())))
         (lp (1+ n))))
@@ -251,73 +262,12 @@ be that both true and false proofs are available."
              (values min-label label-count min-var var-count)))))
       fun kfun 0 self 0))))
 
-(define (compute-idoms dfg min-label label-count)
-  (define (label->idx label) (- label min-label))
-  (define (idx->label idx) (+ idx min-label))
-  (let ((idoms (make-vector label-count #f)))
-    (define (common-idom d0 d1)
-      ;; We exploit the fact that a reverse post-order is a topological
-      ;; sort, and so the idom of a node is always numerically less than
-      ;; the node itself.
-      (cond
-       ((= d0 d1) d0)
-       ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
-       (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
-    (define (compute-idom preds)
-      (define (has-idom? pred)
-        (vector-ref idoms (label->idx pred)))
-      (match preds
-        (() min-label)
-        ((pred . preds)
-         (if (has-idom? pred)
-             (let lp ((idom pred) (preds preds))
-               (match preds
-                 (() idom)
-                 ((pred . preds)
-                  (lp (if (has-idom? pred)
-                          (common-idom idom pred)
-                          idom)
-                      preds))))
-             (compute-idom preds)))))
-    ;; This is the iterative O(n^2) fixpoint algorithm, originally from
-    ;; Allen and Cocke ("Graph-theoretic constructs for program flow
-    ;; analysis", 1972).  See the discussion in Cooper, Harvey, and
-    ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
-    (let iterate ((n 0) (changed? #f))
-      (cond
-       ((< n label-count)
-        (let ((idom (vector-ref idoms n))
-              (idom* (compute-idom (lookup-predecessors (idx->label n) dfg))))
-          (cond
-           ((eqv? idom idom*)
-            (iterate (1+ n) changed?))
-           (else
-            (vector-set! idoms n idom*)
-            (iterate (1+ n) #t)))))
-       (changed?
-        (iterate 0 #f))
-       (else idoms)))))
-
 ;; 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-dom-edges idoms min-label)
-  (define (label->idx label) (- label min-label))
-  (define (idx->label idx) (+ idx min-label))
-  (define (vector-push! vec idx val)
-    (let ((v vec) (i idx))
-      (vector-set! v i (cons val (vector-ref v i)))))
-  (let ((doms (make-vector (vector-length idoms) '())))
-    (let lp ((n 0))
-      (when (< n (vector-length idoms))
-        (let ((idom (vector-ref idoms n)))
-          (vector-push! doms (label->idx idom) (idx->label n)))
-        (lp (1+ n))))
-    doms))
 
 (define (compute-equivalent-subexpressions fun dfg)
-  (define (compute min-label label-count min-var var-count avail effects)
-    (let ((idoms (compute-idoms dfg min-label label-count))
-          (defs (compute-defs dfg min-label label-count))
+  (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)))
@@ -344,7 +294,6 @@ be that both true and false proofs are available."
 
       (define (compute-exp-key exp)
         (match exp
-          (($ $void) 'void)
           (($ $const val) (cons 'const val))
           (($ $prim name) (cons 'prim name))
           (($ $fun free body) #f)
@@ -352,6 +301,9 @@ be that both true and false proofs are available."
           (($ $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)))
 
@@ -362,11 +314,17 @@ be that both true and false proofs are available."
               (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 ,pair) car)
-                (add-def! `(primcall cdr ,pair) cdr))))
+                (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)
@@ -374,7 +332,7 @@ be that both true and false proofs are available."
             (('primcall (or 'make-vector 'make-vector/immediate) len fill)
              (match defs
                ((vec)
-                (add-def! `(primcall vector-length ,vec) len))))
+                (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)
@@ -382,8 +340,10 @@ be that both true and false proofs are available."
             (('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 ,struct) vtable))))
+                (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)
@@ -407,11 +367,8 @@ be that both true and false proofs are available."
                 (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)))
-                  ;; If this expression defines auxiliary definitions,
-                  ;; as `cons' does for the results of `car' and `cdr',
-                  ;; define those.
-                  (add-auxiliary-definitions! label exp-key)
                   (let lp ((candidates equiv))
                     (match candidates
                       (()
@@ -423,16 +380,16 @@ be that both true and false proofs are available."
                        ;; if the value proves to be unused, in the
                        ;; allocation case).
                        (when (and exp-key
-                                  (not (causes-effects?
-                                        (vector-ref effects lidx)
-                                        (logior &fluid-environment
-                                                &allocation))))
+                                  (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 (bitvector-ref avail (label->idx candidate)))
+                        ((not (intset-ref avail candidate))
                          ;; This expression isn't available here; try
                          ;; the next one.
                          (lp candidates))
@@ -446,7 +403,13 @@ be that both true and false proofs are available."
                             (lambda (var subst-var)
                               (vector-set! var-substs (var->idx var) subst-var))
                             (vector-ref defs lidx)
-                            vars)))))))))))
+                            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)
@@ -454,11 +417,13 @@ be that both true and false proofs are available."
 
   (call-with-values (lambda () (compute-label-and-var-ranges fun))
     (lambda (min-label label-count min-var var-count)
-      (call-with-values
-          (lambda ()
-            (compute-available-expressions dfg min-label label-count))
-        (lambda (avail effects)
-          (compute min-label label-count min-var var-count avail effects))))))
+      (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)
@@ -466,8 +431,8 @@ be that both true and false proofs are available."
   (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) idx)
-  (define (false-idx idx) (+ idx (vector-length equiv-labels)))
+  (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,
@@ -479,8 +444,6 @@ be that both true and false proofs are available."
 
   (define (visit-fun-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs names vars body))
-       (label ($kargs names vars ,(visit-term body label))))
       (($ $cont label ($ $kfun src meta self tail clause))
        (label ($kfun src meta self ,tail
                 ,(and clause (visit-fun-cont clause)))))
@@ -498,13 +461,15 @@ be that both true and false proofs are available."
     (define (visit-exp exp)
       ;; We shouldn't see $fun here.
       (rewrite-cps-exp exp
-        ((or ($ $void) ($ $const) ($ $prim)) ,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)
@@ -522,23 +487,25 @@ be that both true and false proofs are available."
            => (match-lambda
                ((equiv . vars)
                 (let* ((eidx (label->idx equiv)))
-                  (rewrite-cps-term (lookup-cont k dfg)
-                    (($ $kif kt kf)
-                     ,(let* ((bool (vector-ref boolv (label->idx label)))
-                             (t (bitvector-ref bool (true-idx eidx)))
-                             (f (bitvector-ref bool (false-idx eidx))))
-                        (if (eqv? t f)
-                            (build-cps-term
-                              ($continue k src ,(visit-exp exp)))
-                            (build-cps-term
-                              ($continue (if t kt kf) src ($values ()))))))
-                    (($ $kargs)
-                     ($continue k src ($values vars)))
-                    ;; There is no point in adding a case for $ktail, as
-                    ;; only $values, $call, or $callk can continue to
-                    ;; $ktail.
+                  (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 ()))))))
                     (_
-                     ($continue k src ,(visit-exp exp))))))))
+                     ;; 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))))))))