Better simplification of literal constants that continue to branches

[bpt/guile.git] / module / language / cps / elide-values.scm

diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index c770f88..6823deb 100644 (file)
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -40,8 +40,8 @@
     (rewrite-cps-cont cont
       (($ $cont sym ($ $kargs names syms body))
        (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+      (($ $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)))))
@@ -53,8 +53,8 @@
        ($letk ,(map visit-cont conts)
          ,(visit-term body)))
       (($ $letrec names syms funs body)
-       ($letrec names syms (map (cut elide-values* <> conts) funs)
-                ,(visit-term body)))
+       ($letrec names syms (map visit-fun funs)
+         ,(visit-term body)))
       (($ $continue k src ($ $primcall 'values vals))
        ,(rewrite-cps-term (vector-ref conts k)
           (($ $ktail)
@@ -94,13 +94,15 @@
                   (build-cps-term
                     ($continue k src ($values vals))))))))
       (($ $continue k src (and fun ($ $fun)))
-       ($continue k src ,(elide-values* fun conts)))
+       ($continue k src ,(visit-fun fun)))
       (($ $continue)
        ,term)))
+  (define (visit-fun fun)
+    (rewrite-cps-exp fun
+      (($ $fun free cont)
+       ($fun free ,(visit-cont cont)))))
 
-  (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta free ,(visit-cont body)))))
+  (visit-cont fun))
 
 (define (elide-values fun)
   (with-fresh-name-state fun