Root higher-order CPS term is always $kfun $cont

[bpt/guile.git] / module / language / cps / prune-bailouts.scm

diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
index 9a8d517..3ba28d9 100644 (file)
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -50,8 +50,8 @@
     (rewrite-cps-cont cont
       (($ $cont label ($ $kargs names vars body))
        (label ($kargs names vars ,(visit-term body ktail))))
-      (($ $cont label ($ $kentry src meta self tail clause))
-       (label ($kentry src meta self ,tail
+      (($ $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)
@@ -61,7 +61,7 @@
   (define (visit-term term ktail)
     (rewrite-cps-term term
       (($ $letrec names vars funs body)
-       ($letrec names vars (map prune-bailouts* funs)
+       ($letrec names vars (map visit-fun funs)
                 ,(visit-term body ktail)))
       (($ $letk conts body)
        ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
@@ -71,7 +71,7 @@
 
   (define (visit-exp k src exp ktail)
     (rewrite-cps-term exp
-      (($ $fun) ($continue k src ,(prune-bailouts* exp)))
+      (($ $fun) ($continue k src ,(visit-fun exp)))
       (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
        ,(if (eq? k ktail)
             (build-cps-term ($continue k src ,exp))
@@ -86,13 +86,16 @@
                   ,(primitive-ref name kprim src))))))
       (_ ($continue k src ,exp))))
 
-  (rewrite-cps-exp fun
-    (($ $fun free
-        ($ $cont kentry
-           ($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
-     ($fun free
-           (kentry ($kentry src meta self (ktail ($ktail))
-                     ,(and clause (visit-cont clause ktail))))))))
+  (define (visit-fun fun)
+    (rewrite-cps-exp fun
+      (($ $fun free body)
+       ($fun free ,(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