Separate make-cont-folder into global and local variants

* module/language/cps.scm (make-global-cont-folder)
  (make-local-cont-folder): Separate this macro in two.  It's hot and
  the difference can be important for perf.

* module/language/cps/dfg.scm (compute-label-and-var-ranges):
* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code): Adapt.

module/language/cps.scm

@@ -136,7 +136,8 @@
 
             ;; Misc.
             parse-cps unparse-cps
-            make-cont-folder fold-conts fold-local-conts
+            make-global-cont-folder make-local-cont-folder
+            fold-conts fold-local-conts
             visit-cont-successors))
 
 ;; FIXME: Use SRFI-99, when Guile adds it.
@@ -449,7 +450,7 @@
     (_
      (error "unexpected cps" exp))))
 
-(define-syntax-rule (make-cont-folder global? seed ...)
+(define-syntax-rule (make-global-cont-folder seed ...)
   (lambda (proc cont seed ...)
     (define (fold-values proc in seed ...)
       (if (null? in)
@@ -492,22 +493,55 @@
 
         (($ $continue k src exp)
          (match exp
-           (($ $fun)
-            (if global?
-                (fun-folder exp seed ...)
-                (values seed ...)))
+           (($ $fun) (fun-folder exp seed ...))
            (_ (values seed ...))))
 
         (($ $letrec names syms funs body)
          (let-values (((seed ...) (term-folder body seed ...)))
-           (if global?
-               (fold-values fun-folder funs seed ...)
-               (values seed ...))))))
+           (fold-values fun-folder funs seed ...)))))
 
     (cont-folder cont seed ...)))
 
+(define-syntax-rule (make-local-cont-folder seed ...)
+  (lambda (proc cont seed ...)
+    (define (cont-folder cont seed ...)
+      (match cont
+        (($ $cont k (and cont ($ $kargs names syms body)))
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (term-folder body seed ...)))
+        (($ $cont k cont)
+         (proc k cont seed ...))))
+    (define (term-folder term seed ...)
+      (match term
+        (($ $letk conts body)
+         (let-values (((seed ...) (term-folder body seed ...)))
+           (let lp ((conts conts) (seed seed) ...)
+             (match conts
+               (() (values seed ...))
+               ((cont) (cont-folder cont seed ...))
+               ((cont . conts)
+                (let-values (((seed ...) (cont-folder cont seed ...)))
+                  (lp conts seed ...)))))))
+        (($ $letrec names syms funs body) (term-folder body seed ...))
+        (_ (values seed ...))))
+    (define (clause-folder clause seed ...)
+      (match clause
+        (($ $cont k (and cont ($ $kclause arity body alternate)))
+         (let-values (((seed ...) (proc k cont seed ...)))
+           (if alternate
+               (let-values (((seed ...) (cont-folder body seed ...)))
+                 (clause-folder alternate seed ...))
+               (cont-folder body seed ...))))))
+    (match cont
+      (($ $cont k (and cont ($ $kfun src meta self tail clause)))
+       (let*-values (((seed ...) (proc k cont seed ...))
+                     ((seed ...) (if clause
+                                     (clause-folder clause seed ...)
+                                     (values seed ...))))
+         (cont-folder tail seed ...))))))
+
 (define (compute-max-label-and-var fun)
-  ((make-cont-folder #t max-label max-var)
+  ((make-global-cont-folder max-label max-var)
    (lambda (label cont max-label max-var)
      (values (max label max-label)
              (match cont
@@ -521,15 +555,13 @@
                (($ $kfun src meta self)
                 (max self max-var))
                (_ max-var))))
-   fun
-   -1
-   -1))
+   fun -1 -1))
 
 (define (fold-conts proc seed fun)
-  ((make-cont-folder #t seed) proc fun seed))
+  ((make-global-cont-folder seed) proc fun seed))
 
 (define (fold-local-conts proc seed fun)
-  ((make-cont-folder #f seed) proc fun seed))
+  ((make-local-cont-folder seed) proc fun seed))
 
 (define (visit-cont-successors proc cont)
   (match cont

module/language/cps/cse.scm

@@ -230,7 +230,7 @@ be that both true and false proofs are available."
 (define (compute-label-and-var-ranges fun)
   (match fun
     (($ $cont kfun ($ $kfun src meta self))
-     ((make-cont-folder #f min-label label-count min-var var-count)
+     ((make-local-cont-folder 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))
               (label-count (1+ label-count)))

module/language/cps/dce.scm

@@ -90,7 +90,7 @@
     (define (ensure-fun-data fun)
       (or (hashq-ref fun-data-table fun)
           (call-with-values (lambda ()
-                              ((make-cont-folder #f label-count max-label)
+                              ((make-local-cont-folder label-count max-label)
                                (lambda (k cont label-count max-label)
                                  (values (1+ label-count) (max k max-label)))
                                fun 0 -1))

module/language/cps/dfg.scm

@@ -735,9 +735,8 @@ body continuation in the prompt."
 (define (compute-label-and-var-ranges fun global?)
   (define (min* a b)
     (if b (min a b) a))
-  (define-syntax-rule (do-fold global?)
-    ((make-cont-folder global?
-                       min-label max-label label-count
+  (define-syntax-rule (do-fold make-cont-folder)
+    ((make-cont-folder min-label max-label label-count
                        min-var max-var var-count)
      (lambda (label cont
                     min-label max-label label-count
@@ -778,8 +777,8 @@ body continuation in the prompt."
      fun
      #f -1 0 #f -1 0))
   (if global?
-      (do-fold #t)
-      (do-fold #f)))
+      (do-fold make-global-cont-folder)
+      (do-fold make-local-cont-folder)))
 
 (define* (compute-dfg fun #:key (global? #t))
   (call-with-values (lambda () (compute-label-and-var-ranges fun global?))