mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

Use intmaps in CSE equivalent expression table

Browse source 
* module/language/cps/cse.scm (make-equivalent-expression-table)
  (intmap-select, add-equivalent-expression!)
  (lookup-equivalent-expressions): New helpers.
  (eliminate-common-subexpressions-in-fun): Adapt.
This commit is contained in:
Andy Wingo 2020-05-29 12:18:19 +02:00
parent a92c623a66
commit 19ab4d6947
1 changed files with 43 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

62
module/language/cps/cse.scm
View file

@ -227,8 +227,28 @@ false. It could be that both true and false proofs are available."
(($ $prompt k kh) (intset k kh)) (($ $prompt k kh) (intset k kh))
(($ $throw) empty-intset))) (($ $throw) empty-intset)))
(define (intmap-select map keys)
(persistent-intmap
(intmap-fold (lambda (k v out)
(if (intset-ref keys k)
(intmap-add! out k v)
out))
map empty-intmap)))
(define (make-equivalent-expression-table)
;; Table associating expressions with equivalent variables, indexed by
;; the label that defines them.
(make-hash-table))
(define (add-equivalent-expression! table key label vars)
(let ((equiv (hash-ref table key empty-intmap)))
(hash-set! table key (intmap-add equiv label vars))))
(define (lookup-equivalent-expressions table key avail)
(match (hash-ref table key)
(#f empty-intmap)
(equiv (intmap-select equiv avail))))
(define (eliminate-common-subexpressions-in-fun kfun conts out substs) (define (eliminate-common-subexpressions-in-fun kfun conts out substs)
(define equiv-set (make-hash-table)) (define equivalent-expressions (make-equivalent-expression-table))
(define (true-idx idx) (ash idx 1)) (define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1))) (define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var substs var) (define (subst-var substs var)
@ -259,9 +279,8 @@ false. It could be that both true and false proofs are available."
(define (add-auxiliary-definitions! label defs substs term-key) (define (add-auxiliary-definitions! label defs substs term-key)
(define (add-def! aux-key var) (define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '()))) (add-equivalent-expression! equivalent-expressions aux-key label
(hash-set! equiv-set aux-key (list var)))
(acons label (list var) equiv))))
(define-syntax add-definitions (define-syntax add-definitions
(syntax-rules (<-) (syntax-rules (<-)
((add-definitions) ((add-definitions)
@ -355,32 +374,24 @@ false. It could be that both true and false proofs are available."
(term-key (term-key
(match analysis (match analysis
(($ <analysis> effects clobbers preds avail truthy-labels) (($ <analysis> effects clobbers preds avail truthy-labels)
(let ((avail (intmap-ref avail label))) (match (lookup-equivalent-expressions equivalent-expressions
(let lp ((candidates (hash-ref equiv-set term-key '()))) term-key
(match candidates (intmap-ref avail label))
(() ((? (lambda (x) (eq? x empty-intmap)))
;; No available expression; residualize.
(residualize)) (residualize))
(((candidate . vars) . candidates) (equiv
(cond
((not (intset-ref avail candidate))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(else
(match term (match term
(($ $continue k src) (($ $continue k src)
;; Yay, a match; eliminate the expression. (eliminate k src (intmap-ref equiv (intmap-next equiv))))
(eliminate k src vars))
(($ $branch kf kt src) (($ $branch kf kt src)
(let* ((bool (intmap-ref truthy-labels label)) (let ((bool (intmap-ref truthy-labels label)))
(t (intset-ref bool (true-idx candidate))) (let lp ((candidate (intmap-prev equiv)))
(match candidate
(#f (residualize))
(_ (let ((t (intset-ref bool (true-idx candidate)))
(f (intset-ref bool (false-idx candidate)))) (f (intset-ref bool (false-idx candidate))))
(if (eqv? t f) (if (eqv? t f)
;; Can't fold the branch; keep on (lp (intmap-prev equiv (1- candidate)))
;; looking for another candidate.
(lp candidates)
;; Nice, the branch folded.
(fold-branch t kf kt src))))))))))))))))) (fold-branch t kf kt src)))))))))))))))))
(define (visit-label label cont out substs analysis) (define (visit-label label cont out substs analysis)
@ -433,8 +444,7 @@ false. It could be that both true and false proofs are available."
;; value proves to be unused, in the allocation case). ;; value proves to be unused, in the allocation case).
(when (and (not (causes-effect? fx &allocation)) (when (and (not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid)))) (not (effect-clobbers? fx (&read-object &fluid))))
(let ((equiv (hash-ref equiv-set term-key '()))) (add-equivalent-expression! equivalent-expressions term-key pred vars)))
(hash-set! equiv-set term-key (acons pred vars equiv)))))
;; If the predecessor defines auxiliary definitions, as ;; If the predecessor defines auxiliary definitions, as
;; `cons' does for the results of `car' and `cdr', define ;; `cons' does for the results of `car' and `cdr', define
;; those as well. ;; those as well.