[Guile-commits] 06/11: Variadic intset-fold, intmap-fold

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 5f7c8e5cb34787b6cccde785ca3887f920351d85
Author: Andy Wingo <address@hidden>
Date:   Tue May 19 08:18:19 2015 +0200

    Variadic intset-fold, intmap-fold
    
    * module/language/cps/intmap.scm (intmap-fold): Add two-seeded arity.
    * module/language/cps/intset.scm (intset-fold): Merge intset-fold2
      into this function, as a two-seeded arity.
    
    * module/language/cps2/simplify.scm (compute-eta-reductions):
      (compute-singly-referenced-labels, compute-beta-reductions): Adapt
      intset-fold2 callers.
---
 module/language/cps/intmap.scm    |   73 ++++++++++++++++----------
 module/language/cps/intset.scm    |  102 +++++++++++++++----------------------
 module/language/cps2/simplify.scm |   10 ++--
 3 files changed, 91 insertions(+), 94 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 8263f42..d453731 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -392,34 +392,51 @@
      (assert-readable! edit)
      (prev min shift root))))
 
-(define (intmap-fold f map seed)
-  (define (visit-branch node shift min seed)
-    (let ((shift (- shift *branch-bits*)))
-      (if (zero? shift)
-          (let lp ((i 0) (seed seed))
-            (if (< i *branch-size*)
-                (let ((elt (vector-ref node i)))
-                  (lp (1+ i)
-                      (if (present? elt)
-                          (f (+ i min) elt seed)
-                          seed)))
-                seed))
-          (let lp ((i 0) (seed seed))
-            (if (< i *branch-size*)
-                (let ((elt (vector-ref node i)))
-                  (lp (1+ i)
-                      (if (present? elt)
-                          (visit-branch elt shift (+ min (ash i shift)) seed)
-                          seed)))
-                seed)))))
-  (match map
-    (($ <intmap> min shift root)
-     (cond
-      ((absent? root) seed)
-      ((zero? shift) (f min root seed))
-      (else (visit-branch root shift min seed))))
-    (($ <transient-intmap>)
-     (intmap-fold f (persistent-intmap map) seed))))
+(define-syntax-rule (make-intmap-folder seed ...)
+  (lambda (f map seed ...)
+    (define (visit-branch node shift min seed ...)
+      (let ((shift (- shift *branch-bits*)))
+        (if (zero? shift)
+            (let lp ((i 0) (seed seed) ...)
+              (if (< i *branch-size*)
+                  (let ((elt (vector-ref node i)))
+                    (call-with-values (lambda ()
+                                        (if (present? elt)
+                                            (f (+ i min) elt seed ...)
+                                            (values seed ...)))
+                      (lambda (seed ...)
+                        (lp (1+ i) seed ...))))
+                  (values seed ...)))
+            (let lp ((i 0) (seed seed) ...)
+              (if (< i *branch-size*)
+                  (let ((elt (vector-ref node i)))
+                    (call-with-values
+                        (lambda ()
+                          (if (present? elt)
+                              (visit-branch elt shift (+ min (ash i shift))
+                                            seed ...)
+                              (values seed ...)))
+                      (lambda (seed ...)
+                        (lp (1+ i) seed ...))))
+                  (values seed ...))))))
+    (let fold ((map map))
+      (match map
+        (($ <intmap> min shift root)
+         (cond
+          ((absent? root) (values seed ...))
+          ((zero? shift) (f min root seed ...))
+          (else (visit-branch root shift min seed ...))))
+        (($ <transient-intmap>)
+         (fold (persistent-intmap map)))))))
+
+(define intmap-fold
+  (case-lambda
+    ((f map seed)
+     ((make-intmap-folder seed) f map seed))
+    ((f map seed0 seed1)
+     ((make-intmap-folder seed0 seed1) f map seed0 seed1))
+    ((f map seed0 seed1 seed2)
+     ((make-intmap-folder seed0 seed1 seed2) f map seed0 seed1 seed2))))
 
 (define* (intmap-union a b #:optional (meet meet-error))
   ;; Union A and B from index I; the result will be fresh.
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 60621d6..3276246 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -39,7 +39,6 @@
             intset-ref
             intset-next
             intset-fold
-            intset-fold2
             intset-union
             intset-intersect
             intset-subtract
@@ -386,67 +385,48 @@
      (assert-readable! edit)
      (next min shift root))))
 
-(define (intset-fold f set seed)
-  (define (visit-branch node shift min seed)
-    (cond
-     ((= shift *leaf-bits*)
-      (let lp ((i 0) (seed seed))
-        (if (< i *leaf-size*)
-            (lp (1+ i)
-                (if (logbit? i node)
-                    (f (+ i min) seed)
-                    seed))
-            seed)))
-     (else
-      (let ((shift (- shift *branch-bits*)))
-        (let lp ((i 0) (seed seed))
-          (if (< i *branch-size*)
-              (let ((elt (vector-ref node i)))
-                (lp (1+ i)
-                    (if elt
-                        (visit-branch elt shift (+ min (ash i shift)) seed)
-                        seed)))
-              seed))))))
-  (match set
-    (($ <intset> min shift root)
-     (cond
-      ((not root) seed)
-      (else (visit-branch root shift min seed))))
-    (($ <transient-intset>)
-     (intset-fold f (persistent-intset set) seed))))
-
-(define (intset-fold2 f set s0 s1)
-  (define (visit-branch node shift min s0 s1)
-    (cond
-     ((= shift *leaf-bits*)
-      (let lp ((i 0) (s0 s0) (s1 s1))
-        (if (< i *leaf-size*)
-            (if (logbit? i node)
-                (call-with-values (lambda () (f (+ i min) s0 s1))
-                  (lambda (s0 s1)
-                    (lp (1+ i) s0 s1)))
-                (lp (1+ i) s0 s1))
-            (values s0 s1))))
-     (else
-      (let ((shift (- shift *branch-bits*)))
-        (let lp ((i 0) (s0 s0) (s1 s1))
-          (if (< i *branch-size*)
-              (let ((elt (vector-ref node i)))
-                (if elt
-                    (call-with-values
-                        (lambda ()
-                          (visit-branch elt shift (+ min (ash i shift)) s0 s1))
-                      (lambda (s0 s1)
-                        (lp (1+ i) s0 s1)))
-                    (lp (1+ i) s0 s1)))
-              (values s0 s1)))))))
-  (match set
-    (($ <intset> min shift root)
-     (cond
-      ((not root) (values s0 s1))
-      (else (visit-branch root shift min s0 s1))))
-    (($ <transient-intset>)
-     (intset-fold2 f (persistent-intset set) s0 s1))))
+(define-syntax-rule (make-intset-folder seed ...)
+  (lambda (f set seed ...)
+    (define (visit-branch node shift min seed ...)
+      (cond
+       ((= shift *leaf-bits*)
+        (let lp ((i 0) (seed seed) ...)
+          (if (< i *leaf-size*)
+              (if (logbit? i node)
+                  (call-with-values (lambda () (f (+ i min) seed ...))
+                    (lambda (seed ...)
+                      (lp (1+ i) seed ...)))
+                  (lp (1+ i) seed ...))
+              (values seed ...))))
+       (else
+        (let ((shift (- shift *branch-bits*)))
+          (let lp ((i 0) (seed seed) ...)
+            (if (< i *branch-size*)
+                (let ((elt (vector-ref node i)))
+                  (if elt
+                      (call-with-values
+                          (lambda ()
+                            (visit-branch elt shift (+ min (ash i shift)) seed 
...))
+                        (lambda (seed ...)
+                          (lp (1+ i) seed ...)))
+                      (lp (1+ i) seed ...)))
+                (values seed ...)))))))
+    (match set
+      (($ <intset> min shift root)
+       (cond
+        ((not root) (values seed ...))
+        (else (visit-branch root shift min seed ...))))
+      (($ <transient-intset>)
+       (intset-fold f (persistent-intset set) seed ...)))))
+
+(define intset-fold
+  (case-lambda
+    ((f set seed)
+     ((make-intset-folder seed) f set seed))
+    ((f set s0 s1)
+     ((make-intset-folder s0 s1) f set s0 s1))
+    ((f set s0 s1 s2)
+     ((make-intset-folder s0 s1 s2) f set s0 s1 s2))))
 
 (define (intset-size shift root)
   (cond
diff --git a/module/language/cps2/simplify.scm 
b/module/language/cps2/simplify.scm
index 647eece..43960c6 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -95,9 +95,9 @@
            (values (intset-add*! nested-funs kfun) eta))
           (_
            (values nested-funs eta))))
-      (intset-fold2 visit-cont body nested-funs eta)))
+      (intset-fold visit-cont body nested-funs eta)))
   (define (visit-funs worklist eta)
-    (intset-fold2 visit-fun worklist empty-intset eta))
+    (intset-fold visit-fun worklist empty-intset eta))
   (persistent-intset
    (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
 
@@ -150,7 +150,7 @@
       (($ $kargs names syms ($ $continue k src exp))
        (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
   (let*-values (((single multiple) (values empty-intset empty-intset))
-                ((single multiple) (intset-fold2 add-ref body single 
multiple)))
+                ((single multiple) (intset-fold add-ref body single multiple)))
     (intset-subtract (persistent-intset single)
                      (persistent-intset multiple))))
 
@@ -176,9 +176,9 @@
            (values (intset-add* nested-funs kfun) beta))
           (_
            (values nested-funs beta))))
-      (intset-fold2 visit-cont body nested-funs beta)))
+      (intset-fold visit-cont body nested-funs beta)))
   (define (visit-funs worklist beta)
-    (intset-fold2 visit-fun worklist empty-intset beta))
+    (intset-fold visit-fun worklist empty-intset beta))
   (persistent-intset
    (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))