Function defined by make-cont-folder takes a cont, not a $fun

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

* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/dfg.scm (compute-dfg):
* module/language/cps/elide-values.scm (elide-values):
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/renumber.scm (compute-new-labels-and-vars):
  (renumber): Adapt.

module/language/cps.scm

@@ -216,7 +216,9 @@
 
 (define-syntax-rule (with-fresh-name-state fun body ...)
   (call-with-values (lambda ()
-                      (compute-max-label-and-var fun))
+                      (match fun
+                        (($ $fun free fun-k)
+                         (compute-max-label-and-var fun-k))))
     (lambda (max-label max-var)
       (parameterize ((label-counter (1+ max-label))
                      (var-counter (1+ max-var)))
@@ -451,7 +453,7 @@
      (error "unexpected cps" exp))))
 
 (define-syntax-rule (make-cont-folder global? seed ...)
-  (lambda (proc fun seed ...)
+  (lambda (proc cont seed ...)
     (define (fold-values proc in seed ...)
       (if (null? in)
           (values seed ...)
@@ -505,7 +507,7 @@
                (fold-values fun-folder funs seed ...)
                (values seed ...))))))
 
-    (fun-folder fun seed ...)))
+    (cont-folder cont seed ...)))
 
 (define (compute-max-label-and-var fun)
   ((make-cont-folder #t max-label max-var)

module/language/cps/cse.scm

@@ -229,7 +229,7 @@ be that both true and false proofs are available."
 
 (define (compute-label-and-var-ranges fun)
   (match fun
-    (($ $fun free ($ $cont kfun ($ $kfun src meta self)))
+    (($ $fun free (and body ($ $cont kfun ($ $kfun src meta self))))
      ((make-cont-folder #f min-label label-count min-var var-count)
       (lambda (k cont min-label label-count min-var var-count)
         (let ((min-label (min k min-label))
@@ -250,7 +250,7 @@ be that both true and false proofs are available."
              (values min-label label-count (min self min-var) (1+ var-count)))
             (_
              (values min-label label-count min-var var-count)))))
-      fun kfun 0 self 0))))
+      body kfun 0 self 0))))
 
 (define (compute-idoms dfg min-label label-count)
   (define (label->idx label) (- label min-label))

module/language/cps/dce.scm

@@ -90,10 +90,12 @@
     (define (ensure-fun-data fun)
       (or (hashq-ref fun-data-table fun)
           (call-with-values (lambda ()
+                              (match fun
+                                (($ $fun free body)
                                  ((make-cont-folder #f label-count max-label)
                                   (lambda (k cont label-count max-label)
                                     (values (1+ label-count) (max k max-label)))
-                               fun 0 -1))
+                                  body 0 -1))))
             (lambda (label-count max-label)
               (let* ((min-label (- (1+ max-label) label-count))
                      (effects (compute-effects dfg min-label label-count))

module/language/cps/dfg.scm

@@ -895,7 +895,9 @@ body continuation in the prompt."
       (do-fold #f)))
 
 (define* (compute-dfg fun #:key (global? #t))
-  (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
+  (match fun
+    (($ $fun free body)
+     (call-with-values (lambda () (compute-label-and-var-ranges body global?))
        (lambda (min-label max-label label-count min-var max-var var-count)
          (when (or (zero? label-count) (zero? var-count))
            (error "internal error (no vars or labels for fun?)"))
@@ -911,7 +913,7 @@ body continuation in the prompt."
                       min-label min-var global?)
            (make-dfg conts preds defs uses scopes scope-levels
                      min-label max-label label-count
-                  min-var max-var var-count)))))
+                     min-var max-var var-count)))))))
 
 (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
   (parameterize ((label-counter (1+ (dfg-max-label dfg)))

module/language/cps/elide-values.scm

@@ -103,6 +103,8 @@
      ($fun free ,(visit-cont body)))))
 
 (define (elide-values fun)
+  (match fun
+    (($ $fun free funk)
      (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
+       (let ((conts (build-cont-table funk)))
-      (elide-values* fun conts))))
+         (elide-values* fun conts))))))

module/language/cps/reify-primitives.scm

@@ -107,8 +107,10 @@
 
 ;; FIXME: Operate on one function at a time, for efficiency.
 (define (reify-primitives fun)
+  (match fun
+    (($ $fun free body)
      (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
+       (let ((conts (build-cont-table body)))
          (define (visit-fun term)
            (rewrite-cps-exp term
              (($ $fun free body)
@@ -164,4 +166,4 @@
                             (else (primitive-ref name k* src)))))))))
                  (_ term)))))
 
-      (visit-fun fun))))
+         (visit-fun fun))))))

module/language/cps/renumber.scm

@@ -74,7 +74,10 @@
             (lp (1+ n) next))))))
 
 (define (compute-new-labels-and-vars fun)
-  (call-with-values (lambda () (compute-max-label-and-var fun))
+  (call-with-values (lambda ()
+                      (match fun
+                        (($ $fun free body)
+                         (compute-max-label-and-var body))))
     (lambda (max-label max-var)
       (let ((labels (make-vector (1+ max-label) #f))
             (next-label 0)
@@ -177,6 +180,8 @@
         (values labels vars next-label next-var)))))
 
 (define (renumber fun)
+  (match fun
+    (($ $fun free cont)
      (call-with-values (lambda () (compute-new-labels-and-vars fun))
        (lambda (labels vars nlabels nvars)
          (define (relabel label) (vector-ref labels label))
@@ -261,4 +266,4 @@
            (rewrite-cps-exp fun
              (($ $fun free body)
               ($fun (map rename free) ,(must-visit-cont body)))))
-      (values (visit-fun fun) nlabels nvars))))
+         (values (visit-fun fun) nlabels nvars))))))