From 5f7c8e5cb34787b6cccde785ca3887f920351d85 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 19 May 2015 08:18:19 +0200 Subject: [PATCH] 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 8263f42c7..d45373147 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 - (($ min shift root) - (cond - ((absent? root) seed) - ((zero? shift) (f min root seed)) - (else (visit-branch root shift min seed)))) - (($ ) - (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 + (($ min shift root) + (cond + ((absent? root) (values seed ...)) + ((zero? shift) (f min root seed ...)) + (else (visit-branch root shift min seed ...)))) + (($ ) + (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 60621d60f..327624646 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 - (($ min shift root) - (cond - ((not root) seed) - (else (visit-branch root shift min seed)))) - (($ ) - (intset-fold f (persistent-intset set) seed)))) +(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 + (($ min shift root) + (cond + ((not root) (values seed ...)) + (else (visit-branch root shift min seed ...)))) + (($ ) + (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 - (($ min shift root) - (cond - ((not root) (values s0 s1)) - (else (visit-branch root shift min s0 s1)))) - (($ ) - (intset-fold2 f (persistent-intset set) s0 s1)))) +(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 647eece1f..43960c607 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)))