[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/11: Variadic intset-fold, intmap-fold
From: |
Andy Wingo |
Subject: |
[Guile-commits] 06/11: Variadic intset-fold, intmap-fold |
Date: |
Wed, 20 May 2015 17:32:57 +0000 |
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)))
- [Guile-commits] branch master updated (ef5f2fc -> 48b2f19), Andy Wingo, 2015/05/20
- [Guile-commits] 04/11: Add two-argument fixpoint arity, Andy Wingo, 2015/05/20
- [Guile-commits] 02/11: Fix fixpoint, Andy Wingo, 2015/05/20
- [Guile-commits] 01/11: Fix sub/- primcall bug, Andy Wingo, 2015/05/20
- [Guile-commits] 03/11: Fix bug compiling fixpoint combinator, Andy Wingo, 2015/05/20
- [Guile-commits] 07/11: Add arity to worklist-fold, Andy Wingo, 2015/05/20
- [Guile-commits] 06/11: Variadic intset-fold, intmap-fold,
Andy Wingo <=
- [Guile-commits] 08/11: intmaps and intsets print with abbreviated key ranges, Andy Wingo, 2015/05/20
- [Guile-commits] 09/11: Fix bug in CPS2 simplify's "transform-conts", Andy Wingo, 2015/05/20
- [Guile-commits] 05/11: Intmaps do not treat #f specially as a value, Andy Wingo, 2015/05/20
- [Guile-commits] 10/11: Port effects analysis to CPS2, Andy Wingo, 2015/05/20
- [Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2, Andy Wingo, 2015/05/20