From d3dbf75ab38e16d59575dfd49c9c99b01c5bbc12 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 11 Apr 2014 10:21:04 +0200
Subject: [PATCH] with-fresh-name-state takes a cont, not a $fun

* module/language/cps.scm (with-fresh-name-state): Take a cont instead
  of a fun.

* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/reify-primitives.scm: Adapt.
---
 module/language/cps.scm                    | 5 +----
 module/language/cps/closure-conversion.scm | 6 +++---
 module/language/cps/constructors.scm       | 6 ++++--
 module/language/cps/elide-values.scm       | 2 +-
 module/language/cps/prune-bailouts.scm     | 6 ++++--
 module/language/cps/reify-primitives.scm   | 2 +-
 6 files changed, 14 insertions(+), 13 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index e6cb3cbd6..ddda6ff50 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -215,10 +215,7 @@
     body ...))
 
 (define-syntax-rule (with-fresh-name-state fun body ...)
-  (call-with-values (lambda ()
-                      (match fun
-                        (($ $fun free fun-k)
-                         (compute-max-label-and-var fun-k))))
+  (call-with-values (lambda () (compute-max-label-and-var fun))
     (lambda (max-label max-var)
       (parameterize ((label-counter (1+ max-label))
                      (var-counter (1+ max-var)))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 479a5906f..85bf30ec9 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -275,9 +275,9 @@ convert functions to flat closures."
 (define (convert-closures exp)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
-  (with-fresh-name-state exp
-    (match exp
-      (($ $fun () body)
+  (match exp
+    (($ $fun () body)
+     (with-fresh-name-state body
        (receive (body free) (cc body #f '())
          (unless (null? free)
            (error "Expected no free vars in toplevel thunk" exp body free))
diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm
index be1c964d8..e4ab6a9d0 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -99,5 +99,7 @@
      ($fun free ,(visit-cont body)))))
 
 (define (inline-constructors fun)
-  (with-fresh-name-state fun
-    (inline-constructors* fun)))
+  (match fun
+    (($ $fun free body)
+     (with-fresh-name-state body
+       (inline-constructors* fun)))))
diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index 754bcc7c6..c86702574 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -105,6 +105,6 @@
 (define (elide-values fun)
   (match fun
     (($ $fun free funk)
-     (with-fresh-name-state fun
+     (with-fresh-name-state funk
        (let ((conts (build-cont-table funk)))
          (elide-values* fun conts))))))
diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
index 81b2581ef..b241781a9 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -95,5 +95,7 @@
                      ,(and clause (visit-cont clause ktail))))))))
 
 (define (prune-bailouts fun)
-  (with-fresh-name-state fun
-    (prune-bailouts* fun)))
+  (match fun
+    (($ $fun free body)
+     (with-fresh-name-state body
+       (prune-bailouts* fun)))))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index c34d6c600..6a4bea058 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -109,7 +109,7 @@
 (define (reify-primitives fun)
   (match fun
     (($ $fun free body)
-     (with-fresh-name-state fun
+     (with-fresh-name-state body
        (let ((conts (build-cont-table body)))
          (define (visit-fun term)
            (rewrite-cps-exp term