mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

DCE works on first-order CPS

Browse source 
* module/language/cps2/dce.scm (compute-live-code): Use the live-labels
  set to indicate function liveness.  $closure and $callk mark their
  associated functions as live.
  (process-eliminations): Handle $closure.

* module/language/cps2/effects-analysis.scm (expression-effects): Handle
  $closure.
This commit is contained in:
Andy Wingo 2015-07-16 07:24:51 +02:00
parent 1b95487501
commit e419e9e3df
2 changed files with 21 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/language/cps2/dce.scm
View file

@ -165,6 +165,8 @@ sites."
(values live-labels live-vars))
(($ $fun body)
(values (intset-add live-labels body) live-vars))
(($ $closure body)
(values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
(live-labels live-labels) (live-vars live-vars))
@ -180,8 +182,9 @@ sites."
(values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk k proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
@ -303,7 +306,10 @@ sites."
(if (label-live? label)
(match exp
(($ $fun body)
(values (visit-fun body cps)
(values cps
term))
(($ $closure body nfree)
(values cps
term))
(($ $rec names vars funs)
(match (filter-map (lambda (name var fun)
@ -314,11 +320,7 @@ sites."
(values cps
(build-term ($continue k src ($values ())))))
(((names vars funs) ...)
(values (fold1 (lambda (fun cps)
(match fun
(($ $fun kfun)
(visit-fun kfun cps))))
funs cps)
(values cps
(build-term ($continue k src
($rec names vars funs)))))))
(_
@ -370,10 +372,17 @@ sites."
(label ($kreceive req rest adapt)))))))
(_
(adjoin-conts cps (label ,cont)))))
(define (visit-fun kfun cps)
(fold-local-conts visit-cont conts kfun cps))
(with-fresh-name-state conts
(persistent-intmap (visit-fun 0 empty-intmap))))
(persistent-intmap
(intmap-fold (lambda (label cont cps)
(match cont
(($ $kfun)
(if (label-live? label)
(fold-local-conts visit-cont conts label cps)
cps))
(_ cps)))
conts
empty-intmap))))
(define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses

2
module/language/cps2/effects-analysis.scm
View file

@ -438,7 +438,7 @@ is or might be a read or a write to the same location as A."
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
((or ($ $fun) ($ $rec))
((or ($ $fun) ($ $rec) ($ $closure))
(&allocate &unknown-memory-kinds))
(($ $prompt)
(&write-object &prompt))