mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

Variadic intset-fold, intmap-fold

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-05-19 08:18:19 +02:00
parent 2b06e90ca4
commit 5f7c8e5cb3
3 changed files with 91 additions and 94 deletions
Download patch file Download diff file Expand all files Collapse all files

73
module/language/cps/intmap.scm
View file

@ -392,34 +392,51 @@
(assert-readable! edit) (assert-readable! edit)
(prev min shift root)))) (prev min shift root))))
(define (intmap-fold f map seed) (define-syntax-rule (make-intmap-folder seed ...)
(define (visit-branch node shift min seed) (lambda (f map seed ...)
(let ((shift (- shift *branch-bits*))) (define (visit-branch node shift min seed ...)
(if (zero? shift) (let ((shift (- shift *branch-bits*)))
(let lp ((i 0) (seed seed)) (if (zero? shift)
(if (< i *branch-size*) (let lp ((i 0) (seed seed) ...)
(let ((elt (vector-ref node i))) (if (< i *branch-size*)
(lp (1+ i) (let ((elt (vector-ref node i)))
(if (present? elt) (call-with-values (lambda ()
(f (+ i min) elt seed) (if (present? elt)
seed))) (f (+ i min) elt seed ...)
seed)) (values seed ...)))
(let lp ((i 0) (seed seed)) (lambda (seed ...)
(if (< i *branch-size*) (lp (1+ i) seed ...))))
(let ((elt (vector-ref node i))) (values seed ...)))
(lp (1+ i) (let lp ((i 0) (seed seed) ...)
(if (present? elt) (if (< i *branch-size*)
(visit-branch elt shift (+ min (ash i shift)) seed) (let ((elt (vector-ref node i)))
seed))) (call-with-values
seed))))) (lambda ()
(match map (if (present? elt)
(($ <intmap> min shift root) (visit-branch elt shift (+ min (ash i shift))
(cond seed ...)
((absent? root) seed) (values seed ...)))
((zero? shift) (f min root seed)) (lambda (seed ...)
(else (visit-branch root shift min seed)))) (lp (1+ i) seed ...))))
(($ <transient-intmap>) (values seed ...))))))
(intmap-fold f (persistent-intmap map) 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)) (define* (intmap-union a b #:optional (meet meet-error))
;; Union A and B from index I; the result will be fresh. ;; Union A and B from index I; the result will be fresh.

102
module/language/cps/intset.scm
View file

@ -39,7 +39,6 @@
intset-ref intset-ref
intset-next intset-next
intset-fold intset-fold
intset-fold2
intset-union intset-union
intset-intersect intset-intersect
intset-subtract intset-subtract
@ -386,67 +385,48 @@
(assert-readable! edit) (assert-readable! edit)
(next min shift root)))) (next min shift root))))
(define (intset-fold f set seed) (define-syntax-rule (make-intset-folder seed ...)
(define (visit-branch node shift min seed) (lambda (f set seed ...)
(cond (define (visit-branch node shift min seed ...)
((= shift *leaf-bits*) (cond
(let lp ((i 0) (seed seed)) ((= shift *leaf-bits*)
(if (< i *leaf-size*) (let lp ((i 0) (seed seed) ...)
(lp (1+ i) (if (< i *leaf-size*)
(if (logbit? i node) (if (logbit? i node)
(f (+ i min) seed) (call-with-values (lambda () (f (+ i min) seed ...))
seed)) (lambda (seed ...)
seed))) (lp (1+ i) seed ...)))
(else (lp (1+ i) seed ...))
(let ((shift (- shift *branch-bits*))) (values seed ...))))
(let lp ((i 0) (seed seed)) (else
(if (< i *branch-size*) (let ((shift (- shift *branch-bits*)))
(let ((elt (vector-ref node i))) (let lp ((i 0) (seed seed) ...)
(lp (1+ i) (if (< i *branch-size*)
(if elt (let ((elt (vector-ref node i)))
(visit-branch elt shift (+ min (ash i shift)) seed) (if elt
seed))) (call-with-values
seed)))))) (lambda ()
(match set (visit-branch elt shift (+ min (ash i shift)) seed ...))
(($ <intset> min shift root) (lambda (seed ...)
(cond (lp (1+ i) seed ...)))
((not root) seed) (lp (1+ i) seed ...)))
(else (visit-branch root shift min seed)))) (values seed ...)))))))
(($ <transient-intset>) (match set
(intset-fold f (persistent-intset set) seed)))) (($ <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-fold2 f set s0 s1) (define intset-fold
(define (visit-branch node shift min s0 s1) (case-lambda
(cond ((f set seed)
((= shift *leaf-bits*) ((make-intset-folder seed) f set seed))
(let lp ((i 0) (s0 s0) (s1 s1)) ((f set s0 s1)
(if (< i *leaf-size*) ((make-intset-folder s0 s1) f set s0 s1))
(if (logbit? i node) ((f set s0 s1 s2)
(call-with-values (lambda () (f (+ i min) s0 s1)) ((make-intset-folder s0 s1 s2) f set s0 s1 s2))))
(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 (intset-size shift root) (define (intset-size shift root)
(cond (cond

10
module/language/cps2/simplify.scm
View file

@ -95,9 +95,9 @@
(values (intset-add*! nested-funs kfun) eta)) (values (intset-add*! nested-funs kfun) eta))
(_ (_
(values nested-funs 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) (define (visit-funs worklist eta)
(intset-fold2 visit-fun worklist empty-intset eta)) (intset-fold visit-fun worklist empty-intset eta))
(persistent-intset (persistent-intset
(worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))) (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
@ -150,7 +150,7 @@
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset)) (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) (intset-subtract (persistent-intset single)
(persistent-intset multiple)))) (persistent-intset multiple))))
@ -176,9 +176,9 @@
(values (intset-add* nested-funs kfun) beta)) (values (intset-add* nested-funs kfun) beta))
(_ (_
(values nested-funs 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) (define (visit-funs worklist beta)
(intset-fold2 visit-fun worklist empty-intset beta)) (intset-fold visit-fun worklist empty-intset beta))
(persistent-intset (persistent-intset
(worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))) (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))