mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Better simplification of literal constants that continue to branches
* 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:
parent
ae67b159bb
commit
b9a5bac690
1 changed files with 29 additions and 1 deletions
|
@ -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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue