Simplification pass prunes all unreachable continuations

* module/language/cps/simplify.scm (prune-continuations): Prune
  continuations as a post-pass with a fresh DFG.  Using a
  pre-eta-conversion DFG as we were doing before missed some cases.

diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 1733161..98788b7 100644 (file)
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -40,40 +40,7 @@
 ;; aren't used), making it useful for this pass to include its own
 ;; little pruner.
 
-(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 ($ $kentry self tail clauses))
-         (for-each visit-cont clauses))
-        (($ $cont sym ($ $kclause arity body))
-         (visit-cont body))
-        (($ $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))
-        (($ $letrec names syms funs body)
-         (for-each visit-fun funs)
-         (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 _)
-         #f)))
-    (define (visit-fun fun)
-      (match fun
-        (($ $fun src meta free body)
-         (visit-cont body))))
-    (visit-fun fun)
-    table))
-
-(define (locally-prune-continuations fun dfg)
+(define* (prune-continuations fun #:optional (dfg (compute-dfg fun)))
   (let ((cfa (analyze-control-flow fun dfg)))
     (define (must-visit-cont cont)
       (or (visit-cont cont)
@@ -102,13 +69,50 @@
              (conts (build-cps-term ($letk ,conts ,body))))))
         (($ $letrec names syms funs body)
          (build-cps-term
-           ($letrec names syms funs ,(visit-term body))))
+           ($letrec names syms (map (cut prune-continuations <> dfg) funs)
+                    ,(visit-term body))))
+        (($ $continue k src (and fun ($ $fun)))
+         (build-cps-term
+           ($continue k src ,(prune-continuations fun dfg))))
         (($ $continue k src exp)
          term)))
     (rewrite-cps-exp fun
       (($ $fun src meta free body)
        ($fun src meta free ,(must-visit-cont body))))))
 
+(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 ($ $kentry self tail clauses))
+         (for-each visit-cont clauses))
+        (($ $cont sym ($ $kclause arity body))
+         (visit-cont body))
+        (($ $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))
+        (($ $letrec names syms funs body)
+         (for-each visit-fun funs)
+         (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 _)
+         #f)))
+    (define (visit-fun fun)
+      (match fun
+        (($ $fun src meta free body)
+         (visit-cont body))))
+    (visit-fun fun)
+    table))
+
 (define (eta-reduce fun)
   (let ((table (compute-eta-reductions fun))
         (dfg (compute-dfg fun)))
@@ -154,11 +158,9 @@
         (($ $continue k src exp)
          ($continue (reduce k scope) src ,exp))))
     (define (visit-fun fun)
-      (locally-prune-continuations
-       (rewrite-cps-exp fun
-         (($ $fun src meta free body)
-          ($fun src meta free ,(visit-cont body #f))))
-       dfg))
+      (rewrite-cps-exp fun
+        (($ $fun src meta free body)
+         ($fun src meta free ,(visit-cont body #f)))))
     (visit-fun fun)))
 
 (define (compute-beta-reductions fun)
@@ -273,4 +275,4 @@
     (visit-fun fun)))
 
 (define (simplify fun)
-  (eta-reduce (beta-reduce fun)))
+  (prune-continuations (eta-reduce (beta-reduce fun))))