From 2c3c086ef3411c8ddf1dfa11024b188a5068c1b0 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 1 Apr 2014 11:59:03 +0200
Subject: [PATCH] Add visit-cont-successors helper

* module/language/cps/dfg.scm (lookup-successors, control-point?): Use
  the new helper.

* module/language/cps.scm (visit-cont-successors): New helper.
---
 module/language/cps.scm     | 29 +++++++++++++++++++++-
 module/language/cps/dfg.scm | 48 +++++++------------------------------
 2 files changed, 37 insertions(+), 40 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index cb2cf03a7..c1bb30478 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -136,7 +136,8 @@
 
             ;; Misc.
             parse-cps unparse-cps
-            make-cont-folder fold-conts fold-local-conts))
+            make-cont-folder fold-conts fold-local-conts
+            visit-cont-successors))
 
 ;; FIXME: Use SRFI-99, when Guile adds it.
 (define-syntax define-record-type*
@@ -521,3 +522,29 @@
 
 (define (fold-local-conts proc seed fun)
   ((make-cont-folder #f seed) proc fun seed))
+
+(define (visit-cont-successors proc 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) (proc k handler))
+            (_ (proc k)))))))
+
+    (($ $kif kt kf) (proc kt kf))
+
+    (($ $kreceive arity k) (proc k))
+
+    (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
+
+    (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
+
+    (($ $kentry self tail ($ $cont clause)) (proc clause))
+
+    (($ $kentry self tail #f) (proc))
+
+    (($ $ktail) (proc))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 768dcab31..52d7b3a82 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -931,30 +931,8 @@ BODY for each body continuation in the prompt."
   (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
 
 (define (lookup-successors k dfg)
-  (match (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))
-    (($ $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))
-            (_ (list k)))))))
-
-    (($ $kif kt kf) (list kt kf))
-
-    (($ $kreceive arity k) (list k))
-
-    (($ $kclause arity ($ $cont kbody) #f) (list kbody))
-
-    (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (list kbody kalt))
-
-    (($ $kentry self tail ($ $cont clause)) (list clause))
-
-    (($ $kentry self tail #f) '())
-
-    (($ $ktail) '())))
+  (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
+    (visit-cont-successors list cont)))
 
 (define (lookup-def var dfg)
   (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
@@ -1069,21 +1047,13 @@ BODY for each body continuation in the prompt."
 (define (control-point? k dfg)
   (match (lookup-predecessors k dfg)
     ((pred)
-     (match (vector-ref (dfg-cont-table dfg) (- pred (dfg-min-label dfg)))
-       (($ $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) #t)
-               (_ #f))))))
-       (($ $kif) #t)
-       (($ $kreceive) #f)
-       (($ $kclause) #f)
-       (($ $kentry) #f)
-       (($ $ktail) #t)))
+     (let ((cont (vector-ref (dfg-cont-table dfg)
+                             (- pred (dfg-min-label dfg)))))
+       (visit-cont-successors (case-lambda
+                                (() #t)
+                                ((succ0) #f)
+                                ((succ1 succ2) #t))
+                              cont)))
     (_ #t)))
 
 (define (lookup-bound-syms k dfg)
-- 
2.20.1