From fea115c33f35b95c89ebb9142faaa06a43d83036 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 4 Oct 2013 18:03:29 +0200
Subject: [PATCH] Fix nested contification bugs

* module/language/cps/contification.scm (contify): Exhaustively replace
  contified tail continuations, to fix a bug in nested tail-recursive
  contifications.  Likewise, call lookup-return-cont when searching for
  common return continuations.
---
 module/language/cps/contification.scm | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index 469cd28f6..dda6ee362 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -49,7 +49,9 @@
     (define (subst-return! old-tail new-tail)
       (set! cont-substs (acons old-tail new-tail cont-substs)))
     (define (lookup-return-cont k)
-      (or (assq-ref cont-substs k) k))
+      (match (assq-ref cont-substs k)
+        (#f k)
+        (k (lookup-return-cont k))))
 
     (define (add-pending-contifications! scope conts)
       (for-each (match-lambda
@@ -78,7 +80,8 @@
                    (((($ $arity req () #f () #f) . k) . clauses)
                     (if (= (length req) (length args))
                         (build-cps-term
-                          ($continue k ($values args)))
+                          ($continue (lookup-return-cont k)
+                            ($values args)))
                         (lp clauses)))
                    ((_ . clauses) (lp clauses)))))))
 
@@ -121,7 +124,7 @@
         (match (find-call (lookup-cont use cont-table))
           (($ $continue k ($ $call proc* args))
            (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
-                k))
+                (lookup-return-cont k)))
           (_ #f)))
 
       (and