mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
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.
This commit is contained in:
Andy Wingo
parent
2b06e90ca4
commit
5f7c8e5cb3
3 changed files with 91 additions and 94 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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-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-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 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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue