mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +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)) (values live-labels live-vars))
(($ $fun body) (($ $fun body)
(values (intset-add live-labels body) live-vars)) (values (intset-add live-labels body) live-vars))
(($ $closure body)
(values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...)) (($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns) (let lp ((vars vars) (kfuns kfuns)
(live-labels live-labels) (live-vars live-vars)) (live-labels live-labels) (live-vars live-vars))
@ -180,8 +182,9 @@ sites."
(values live-labels (adjoin-var tag live-vars))) (values live-labels (adjoin-var tag live-vars)))
(($ $call proc args) (($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) (values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk k proc args) (($ $callk kfun proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) (values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args) (($ $primcall name args)
(values live-labels (adjoin-vars args live-vars))) (values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args)) (($ $branch k ($ $primcall name args))
@ -303,7 +306,10 @@ sites."
(if (label-live? label) (if (label-live? label)
(match exp (match exp
(($ $fun body) (($ $fun body)
(values (visit-fun body cps) (values cps
term))
(($ $closure body nfree)
(values cps
term)) term))
(($ $rec names vars funs) (($ $rec names vars funs)
(match (filter-map (lambda (name var fun) (match (filter-map (lambda (name var fun)
@ -314,11 +320,7 @@ sites."
(values cps (values cps
(build-term ($continue k src ($values ()))))) (build-term ($continue k src ($values ())))))
(((names vars funs) ...) (((names vars funs) ...)
(values (fold1 (lambda (fun cps) (values cps
(match fun
(($ $fun kfun)
(visit-fun kfun cps))))
funs cps)
(build-term ($continue k src (build-term ($continue k src
($rec names vars funs))))))) ($rec names vars funs)))))))
(_ (_
@ -370,10 +372,17 @@ sites."
(label ($kreceive req rest adapt))))))) (label ($kreceive req rest adapt)))))))
(_ (_
(adjoin-conts cps (label ,cont))))) (adjoin-conts cps (label ,cont)))))
(define (visit-fun kfun cps)
(fold-local-conts visit-cont conts kfun cps))
(with-fresh-name-state conts (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) (define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses ;; 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 (match exp
((or ($ $const) ($ $prim) ($ $values)) ((or ($ $const) ($ $prim) ($ $values))
&no-effects) &no-effects)
((or ($ $fun) ($ $rec)) ((or ($ $fun) ($ $rec) ($ $closure))
(&allocate &unknown-memory-kinds)) (&allocate &unknown-memory-kinds))
(($ $prompt) (($ $prompt)
(&write-object &prompt)) (&write-object &prompt))