Public make-cont-folder

* module/language/cps.scm (make-cont-folder): Add global? parameter, and
  make public.
  (fold-conts): Adapt.
  (fold-local-conts): Use make-cont-folder, and take a function instead
  of a continuation.

* module/language/cps/arities.scm (fix-clause-arities, fix-arities*):
* module/language/cps/compile-bytecode.scm (collect-conts):
* module/language/cps/elide-values.scm (elide-values*): Adapt to
  fold-local-conts change.

module/language/cps.scm

@@ -136,7 +136,7 @@
 
             ;; Misc.
             parse-cps unparse-cps
-            fold-conts fold-local-conts))
+            make-cont-folder fold-conts fold-local-conts))
 
 ;; FIXME: Use SRFI-99, when Guile adds it.
 (define-syntax define-record-type*
@@ -439,7 +439,7 @@
     (_
      (error "unexpected cps" exp))))
 
-(define-syntax-rule (make-cont-folder seed ...)
+(define-syntax-rule (make-cont-folder global? seed ...)
   (lambda (proc fun seed ...)
     (define (fold-values proc in seed ...)
       (if (null? in)
@@ -477,17 +477,22 @@
 
         (($ $continue k src exp)
          (match exp
-           (($ $fun) (fun-folder exp seed ...))
+           (($ $fun)
+            (if global?
+                (fun-folder exp seed ...)
+                (values seed ...)))
            (_ (values seed ...))))
 
         (($ $letrec names syms funs body)
          (let-values (((seed ...) (term-folder body seed ...)))
-           (fold-values fun-folder funs seed ...)))))
+           (if global?
+               (fold-values fun-folder funs seed ...)
+               (values seed ...))))))
 
     (fun-folder fun seed ...)))
 
 (define (compute-max-label-and-var fun)
-  ((make-cont-folder max-label max-var)
+  ((make-cont-folder #t max-label max-var)
    (lambda (label cont max-label max-var)
      (values (max label max-label)
              (match cont
@@ -501,32 +506,7 @@
    -1))
 
 (define (fold-conts proc seed fun)
-  ((make-cont-folder seed) proc fun seed))
+  ((make-cont-folder #t seed) proc fun seed))
 
-(define (fold-local-conts proc seed cont)
+(define (fold-local-conts proc seed fun)
-  (define (cont-folder cont seed)
+  ((make-cont-folder #f seed) proc fun seed))
-    (match cont
-      (($ $cont k cont)
-       (let ((seed (proc k cont seed)))
-         (match cont
-           (($ $kargs names syms body)
-            (term-folder body seed))
-
-           (($ $kentry self tail clauses)
-            (fold cont-folder (cont-folder tail seed) clauses))
-
-           (($ $kclause arity body)
-            (cont-folder body seed))
-
-           (_ seed))))))
-
-  (define (term-folder term seed)
-    (match term
-      (($ $letk conts body)
-       (fold cont-folder (term-folder body seed) conts))
-
-      (($ $continue) seed)
-
-      (($ $letrec names syms funs body) (term-folder body seed))))
-
-  (cont-folder cont seed))

module/language/cps/arities.scm

@@ -32,9 +32,8 @@
   #:use-module (language cps primitives)
   #:export (fix-arities))
 
-(define (fix-clause-arities clause)
+(define (fix-clause-arities clause conts)
-  (let ((conts (build-local-cont-table clause))
+  (let ((ktail (match clause
-        (ktail (match clause
                  (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
     (define (visit-term term)
       (rewrite-cps-term term
@@ -184,9 +183,10 @@
        (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
 
 (define (fix-arities* fun)
-  (rewrite-cps-exp fun
+  (let ((conts (build-local-cont-table fun)))
-    (($ $fun src meta free body)
+    (rewrite-cps-exp fun
-     ($fun src meta free ,(fix-clause-arities body)))))
+      (($ $fun src meta free body)
+       ($fun src meta free ,(fix-clause-arities body conts))))))
 
 (define (fix-arities fun)
   (with-fresh-name-state fun

module/language/cps/compile-bytecode.scm

@@ -91,9 +91,7 @@
          (when idx
            (vector-set! contv idx cont))))
      '()
-     (match f
+     f)
-       (($ $fun src meta free entry)
-        entry)))
     contv))
 
 (define (compile-fun f asm)

module/language/cps/elide-values.scm

@@ -36,8 +36,7 @@
   #:export (elide-values))
 
 (define (elide-values* fun)
-  (let ((conts (build-local-cont-table
+  (let ((conts (build-local-cont-table fun)))
-                (match fun (($ $fun src meta free body) body)))))
     (define (visit-cont cont)
       (rewrite-cps-cont cont
         (($ $cont sym ($ $kargs names syms body))