[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/10: Prepare DCE pass for first-order CPS2
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/10: Prepare DCE pass for first-order CPS2 |
Date: |
Thu, 16 Jul 2015 08:06:25 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 263b4099182c8d6f4e7e0f266f145c1d31f3ab33
Author: Andy Wingo <address@hidden>
Date: Wed Jul 15 17:15:03 2015 +0200
Prepare DCE pass for first-order CPS2
* module/language/cps2/dce.scm (compute-live-code): Prepare for handling
first-order CPS by tracking functions in the live label set.
---
module/language/cps2/dce.scm | 92 +++++++++++++++++++++++------------------
1 files changed, 52 insertions(+), 40 deletions(-)
diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm
index 28ef04f..6fa95f7 100644
--- a/module/language/cps2/dce.scm
+++ b/module/language/cps2/dce.scm
@@ -159,38 +159,37 @@ sites."
(($ $kargs _ vars) vars)
(_ #f)))
- (define (visit-live-exp label k exp live-exps live-vars)
+ (define (visit-live-exp label k exp live-labels live-vars)
(match exp
((or ($ $const) ($ $prim))
- (values live-exps live-vars))
+ (values live-labels live-vars))
(($ $fun body)
- (visit-fun body live-exps live-vars))
+ (values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
- (live-exps live-exps) (live-vars live-vars))
+ (live-labels live-labels) (live-vars live-vars))
(match (vector vars kfuns)
- (#(() ()) (values live-exps live-vars))
+ (#(() ()) (values live-labels live-vars))
(#((var . vars) (kfun . kfuns))
- (if (var-live? var live-vars)
- (call-with-values (lambda ()
- (visit-fun kfun live-exps live-vars))
- (lambda (live-exps live-vars)
- (lp vars kfuns live-exps live-vars)))
- (lp vars kfuns live-exps live-vars))))))
+ (lp vars kfuns
+ (if (var-live? var live-vars)
+ (intset-add live-labels kfun)
+ live-labels)
+ live-vars)))))
(($ $prompt escape? tag handler)
- (values live-exps (adjoin-var tag live-vars)))
+ (values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
- (values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
+ (values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk k proc args)
- (values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
+ (values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
- (values live-exps (adjoin-vars args live-vars)))
+ (values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
- (values live-exps (adjoin-vars args live-vars)))
+ (values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $values (arg)))
- (values live-exps (adjoin-var arg live-vars)))
+ (values live-labels (adjoin-var arg live-vars)))
(($ $values args)
- (values live-exps
+ (values live-labels
(match (cont-defs k)
(#f (adjoin-vars args live-vars))
(defs (fold (lambda (use def live-vars)
@@ -199,11 +198,11 @@ sites."
live-vars))
live-vars args defs)))))))
- (define (visit-exp label k exp live-exps live-vars)
+ (define (visit-exp label k exp live-labels live-vars)
(cond
- ((intset-ref live-exps label)
+ ((intset-ref live-labels label)
;; Expression live already.
- (visit-live-exp label k exp live-exps live-vars))
+ (visit-live-exp label k exp live-labels live-vars))
((let ((defs (cont-defs k))
(fx (intmap-ref effects label)))
(or
@@ -233,31 +232,44 @@ sites."
(not (intset-ref known-allocations obj))))
(_ #t)))))
;; Mark expression as live and visit.
- (visit-live-exp label k exp (intset-add live-exps label) live-vars))
+ (visit-live-exp label k exp (intset-add live-labels label) live-vars))
(else
;; Still dead.
- (values live-exps live-vars))))
+ (values live-labels live-vars))))
- (define (visit-fun label live-exps live-vars)
+ (define (visit-fun label live-labels live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
- (lambda (label cont live-exps live-vars)
+ (lambda (label cont live-labels live-vars)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
- (visit-exp label k exp live-exps live-vars))
+ (visit-exp label k exp live-labels live-vars))
(($ $kreceive arity kargs)
- (values live-exps live-vars))
+ (values live-labels live-vars))
(($ $kclause arity kargs kalt)
- (values live-exps (adjoin-vars (cont-defs kargs) live-vars)))
+ (values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
- (values live-exps (adjoin-var self live-vars)))
+ (values live-labels (adjoin-var self live-vars)))
(($ $ktail)
- (values live-exps live-vars))))
- conts label live-exps live-vars))
+ (values live-labels live-vars))))
+ conts label live-labels live-vars))
- (fixpoint (lambda (live-exps live-vars)
- (visit-fun 0 live-exps live-vars))
- empty-intset
+ (fixpoint (lambda (live-labels live-vars)
+ (let lp ((label 0)
+ (live-labels live-labels)
+ (live-vars live-vars))
+ (match (intset-next live-labels label)
+ (#f (values live-labels live-vars))
+ (label
+ (call-with-values
+ (lambda ()
+ (match (intmap-ref conts label)
+ (($ $kfun)
+ (visit-fun label live-labels live-vars))
+ (_ (values live-labels live-vars))))
+ (lambda (live-labels live-vars)
+ (lp (1+ label) live-labels live-vars)))))))
+ (intset 0)
empty-intset)))
(define-syntax adjoin-conts
@@ -271,9 +283,9 @@ sites."
((_ cps)
cps)))
-(define (process-eliminations conts live-exps live-vars)
- (define (exp-live? label)
- (intset-ref live-exps label))
+(define (process-eliminations conts live-labels live-vars)
+ (define (label-live? label)
+ (intset-ref live-labels label))
(define (value-live? var)
(intset-ref live-vars var))
(define (make-adaptor k src defs)
@@ -288,7 +300,7 @@ sites."
(define (visit-term label term cps)
(match term
(($ $continue k src exp)
- (if (exp-live? label)
+ (if (label-live? label)
(match exp
(($ $fun body)
(values (visit-fun body cps)
@@ -370,8 +382,8 @@ sites."
;; inference.
(let ((conts (renumber conts)))
(call-with-values (lambda () (compute-live-code conts))
- (lambda (live-exps live-vars)
- (process-eliminations conts live-exps live-vars)))))
+ (lambda (live-labels live-vars)
+ (process-eliminations conts live-labels live-vars)))))
;;; Local Variables:
;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
- [Guile-commits] branch master updated (981802c -> 90aabcc), Andy Wingo, 2015/07/16
- [Guile-commits] 01/10: closure-conversion docstring tweak, Andy Wingo, 2015/07/16
- [Guile-commits] 02/10: CPS2 closure conversion bugfixes, Andy Wingo, 2015/07/16
- [Guile-commits] 03/10: Enable CPS2 closure conversion, Andy Wingo, 2015/07/16
- [Guile-commits] 04/10: Prepare DCE pass for first-order CPS2,
Andy Wingo <=
- [Guile-commits] 06/10: DCE works on first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 05/10: compute-reachable-functions refactor, Andy Wingo, 2015/07/16
- [Guile-commits] 10/10: Fix type/range inference for mul, Andy Wingo, 2015/07/16
- [Guile-commits] 07/10: Beta reduction over first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 08/10: Optimize first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 09/10: Remove CPS optimization passes and closure conversion, Andy Wingo, 2015/07/16