dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fix replacement of CSE with lexical-ref

Browse source 
* module/language/tree-il/cse.scm (cse): Fix dominator unrolling for
  lexical propagation.

* test-suite/tests/cse.test ("cse"): Add test.
This commit is contained in:
Andy Wingo 2012-04-16 16:25:19 -07:00
commit 73001b06f6
2 changed files with 24 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

27
module/language/tree-il/cse.scm
View file

@ -353,29 +353,30 @@
(expressions-equal? exp exp*))
(_ #f)))
(define (unroll db from to)
(or (<= from to)
(match (vlist-ref db (1- from))
(define (unroll db base n)
(or (zero? n)
(match (vlist-ref db base)
(('lambda . h*)
;; See note in find-dominating-expression.
(and (not (depends-on-effects? effects &all-effects))
(unroll db (1- from) to)))
(unroll db (1+ base) (1- n))))
((#(exp* effects* ctx*) . h*)
(and (effects-commute? effects effects*)
(unroll db (1- from) to))))))
(unroll db (1+ base) (1- n)))))))
(let ((h (hash-expression exp)))
(and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h))
(let ((env-len (vlist-length env)))
(let lp ((n 0) (db-len (vlist-length db)))
(let ((env-len (vlist-length env))
(db-len (vlist-length db)))
(let lp ((n 0) (m 0))
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
(and (unroll db db-len db-len*)
(and (unroll db m (- db-len db-len*))
(if (and (= h h*) (expressions-equal? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym)
(lp (1+ n) db-len*)))))))))))
(lp (1+ n) (- db-len db-len*))))))))))))
(define (intersection db+ db-)
(vhash-fold-right
@ -414,8 +415,12 @@
(logior &zero-values
&allocation)))
(has-dominating-effect? exp effects db)))
(log 'elide ctx (unparse-tree-il exp))
(values (make-void #f) db*))
(cond
((void? exp)
(values exp db*))
(else
(log 'elide ctx (unparse-tree-il exp))
(values (make-void #f) db*))))
((and (boolean-valued-expression? exp ctx)
(find-dominating-test exp effects db))
=> (lambda (exp)