mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Better simplification of literal constants that continue to branches

Browse source 
* module/language/cps/simplify.scm (eta-reduce): Constants that continue
  to branches eta-reduce to the true or false branch.
This commit is contained in:
Andy Wingo 2014-07-20 20:52:06 +02:00
parent ae67b159bb
commit b9a5bac690
1 changed files with 29 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

30
module/language/cps/simplify.scm
View file

@ -85,6 +85,30 @@
(reduce* k scope #f))
(define (reduce-values k scope)
(reduce* k scope #t))
(define (reduce-const k src scope const)
(let lp ((k k) (seen '()) (const const))
(match (lookup-cont k dfg)
(($ $kargs (_) (arg) term)
(match (find-call term)
(($ $continue k* src* ($ $values (arg*)))
(and (eqv? arg arg*)
(not (memq k* seen))
(lp k* (cons k seen) const)))
(($ $continue k* src* ($ $primcall 'not (arg*)))
(and (eqv? arg arg*)
(not (memq k* seen))
(lp k* (cons k seen) (not const))))
(($ $continue k* src* ($ $branch kt ($ $values (arg*))))
(and (eqv? arg arg*)
(let ((k* (if const kt k*)))
(and (continuation-bound-in? k* scope dfg)
(build-cps-term
($continue k* src ($values ())))))))
(_
(and (continuation-bound-in? k scope dfg)
(build-cps-term
($continue k src ($const const)))))))
(_ #f))))
(define (visit-cont cont scope)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
@ -104,11 +128,15 @@
,(visit-term body scope)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
,(visit-term body scope)))
,(visit-term body scope)))
(($ $continue k src ($ $values args))
($continue (reduce-values k scope) src ($values args)))
(($ $continue k src (and fun ($ $fun)))
($continue (reduce k scope) src ,(visit-fun fun)))
(($ $continue k src ($ $const const))
,(let ((k (reduce k scope)))
(or (reduce-const k src scope const)
(build-cps-term ($continue k src ($const const))))))
(($ $continue k src exp)
($continue (reduce k scope) src ,exp))))
(define (visit-fun fun)