Speed up compute-label-and-var-ranges

[bpt/guile.git] / module / language / cps / dfg.scm

diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 89922ab..4f32fce 100644 (file)
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -881,47 +881,51 @@ BODY for each body continuation in the prompt."
 (define (compute-label-and-var-ranges fun global?)
   (define (min* a b)
     (if b (min a b) a))
-  ((make-cont-folder global?
-                     min-label max-label label-count
-                     min-var max-var var-count)
-   (lambda (label cont
-                  min-label max-label label-count
-                  min-var max-var var-count)
-     (let ((min-label (min* label min-label))
-           (max-label (max label max-label)))
-       (define (visit-letrec body min-var max-var var-count)
-         (match body
-           (($ $letk conts body)
-            (visit-letrec body min-var max-var var-count))
-           (($ $letrec names vars funs body)
-            (visit-letrec body
-                          (cond (min-var (fold min min-var vars))
-                                ((pair? vars) (fold min (car vars) (cdr vars)))
-                                (else min-var))
-                          (fold max max-var vars)
-                          (+ var-count (length vars))))
-           (($ $continue) (values min-var max-var var-count))))
-       (match cont
-         (($ $kargs names vars body)
-          (call-with-values
-              (lambda ()
-                (if global?
-                    (visit-letrec body min-var max-var var-count)
-                    (values min-var max-var var-count)))
-            (lambda (min-var max-var var-count)
-              (values min-label max-label (1+ label-count)
-                      (cond (min-var (fold min min-var vars))
-                            ((pair? vars) (fold min (car vars) (cdr vars)))
-                            (else min-var))
-                      (fold max max-var vars)
-                      (+ var-count (length vars))))))
-         (($ $kentry self)
-          (values min-label max-label (1+ label-count)
-                  (min* self min-var) (max self max-var) (1+ var-count)))
-         (_ (values min-label max-label (1+ label-count)
-                    min-var max-var var-count)))))
-   fun
-   #f -1 0 #f -1 0))
+  (define-syntax-rule (do-fold global?)
+    ((make-cont-folder global?
+                       min-label max-label label-count
+                       min-var max-var var-count)
+     (lambda (label cont
+                    min-label max-label label-count
+                    min-var max-var var-count)
+       (let ((min-label (min* label min-label))
+             (max-label (max label max-label)))
+         (define (visit-letrec body min-var max-var var-count)
+           (match body
+             (($ $letk conts body)
+              (visit-letrec body min-var max-var var-count))
+             (($ $letrec names vars funs body)
+              (visit-letrec body
+                            (cond (min-var (fold min min-var vars))
+                                  ((pair? vars) (fold min (car vars) (cdr vars)))
+                                  (else min-var))
+                            (fold max max-var vars)
+                            (+ var-count (length vars))))
+             (($ $continue) (values min-var max-var var-count))))
+         (match cont
+           (($ $kargs names vars body)
+            (call-with-values
+                (lambda ()
+                  (if global?
+                      (visit-letrec body min-var max-var var-count)
+                      (values min-var max-var var-count)))
+              (lambda (min-var max-var var-count)
+                (values min-label max-label (1+ label-count)
+                        (cond (min-var (fold min min-var vars))
+                              ((pair? vars) (fold min (car vars) (cdr vars)))
+                              (else min-var))
+                        (fold max max-var vars)
+                        (+ var-count (length vars))))))
+           (($ $kentry self)
+            (values min-label max-label (1+ label-count)
+                    (min* self min-var) (max self max-var) (1+ var-count)))
+           (_ (values min-label max-label (1+ label-count)
+                      min-var max-var var-count)))))
+     fun
+     #f -1 0 #f -1 0))
+  (if global?
+      (do-fold #t)
+      (do-fold #f)))
 
 (define* (compute-dfg fun #:key (global? #t))
   (call-with-values (lambda () (compute-label-and-var-ranges fun global?))