[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/10: compute-reachable-functions refactor
From: |
Andy Wingo |
Subject: |
[Guile-commits] 05/10: compute-reachable-functions refactor |
Date: |
Thu, 16 Jul 2015 08:06:26 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 1b95487501e2c55bc63b3f71931993cdb52f9ec8
Author: Andy Wingo <address@hidden>
Date: Thu Jul 16 07:22:59 2015 +0200
compute-reachable-functions refactor
* module/language/cps2/utils.scm (compute-reachable-functions): New
function.
* module/language/cps2/verify.scm (check-label-partition)
(compute-reachable-labels): Use the new function.
* module/language/cps2/simplify.scm (compute-singly-referenced-vars):
Allow $closure.
(compute-eta-reductions, compute-beta-reductions): Use
compute-reachable-functions, which besides being a simplification also
allows simplification to work on first-order CPS.
---
module/language/cps2/simplify.scm | 74 +++++++++++++++---------------------
module/language/cps2/utils.scm | 39 +++++++++++++++++++
module/language/cps2/verify.scm | 46 +++-------------------
3 files changed, 77 insertions(+), 82 deletions(-)
diff --git a/module/language/cps2/simplify.scm
b/module/language/cps2/simplify.scm
index 685327a..b87b044 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -74,7 +74,7 @@
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
(values single multiple))
(($ $call proc args)
(ref* (cons proc args)))
@@ -118,30 +118,24 @@
(() #t)
((var . vars)
(and (intset-ref singly-used var) (singly-used? vars)))))
- (define (visit-fun kfun nested-funs eta)
- (let ((body (compute-function-body conts kfun)))
- (define (visit-cont label nested-funs eta)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src ($ $values vars)))
- (values nested-funs
- (intset-maybe-add! eta label
- (match (intmap-ref conts k)
- (($ $kargs)
- (and (not (eqv? label k)) ; A
- (not (intset-ref eta label)) ;
B
- (singly-used? vars)))
- (_ #f)))))
- (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
- (values (intset-add! nested-funs kfun) eta))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
- (values (intset-add*! nested-funs kfun) eta))
- (_
- (values nested-funs eta))))
- (intset-fold visit-cont body nested-funs eta)))
- (define (visit-funs worklist eta)
- (intset-fold visit-fun worklist empty-intset eta))
+ (define (visit-fun kfun body eta)
+ (define (visit-cont label eta)
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src ($ $values vars)))
+ (intset-maybe-add! eta label
+ (match (intmap-ref conts k)
+ (($ $kargs)
+ (and (not (eqv? label k)) ; A
+ (not (intset-ref eta label)) ; B
+ (singly-used? vars)))
+ (_ #f))))
+ (_
+ eta)))
+ (intset-fold visit-cont body eta))
(persistent-intset
- (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))))
+ (intmap-fold visit-fun
+ (compute-reachable-functions conts kfun)
+ empty-intset))))
(define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun)))
@@ -197,32 +191,26 @@
(persistent-intset multiple))))
(define (compute-beta-reductions conts kfun)
- (define (visit-fun kfun nested-funs beta)
- (let* ((body (compute-function-body conts kfun))
- (single (compute-singly-referenced-labels conts body)))
- (define (visit-cont label nested-funs beta)
+ (define (visit-fun kfun body beta)
+ (let ((single (compute-singly-referenced-labels conts body)))
+ (define (visit-cont label beta)
(match (intmap-ref conts label)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only
;; be inlined if it is used only once, and not recursively.
(($ $kargs _ _ ($ $continue k src ($ $values)))
- (values nested-funs
- (intset-maybe-add! beta label
- (and (intset-ref single k)
- (match (intmap-ref conts k)
- (($ $kargs) #t)
- (_ #f))))))
- (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
- (values (intset-add nested-funs kfun) beta))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
- (values (intset-add* nested-funs kfun) beta))
+ (intset-maybe-add! beta label
+ (and (intset-ref single k)
+ (match (intmap-ref conts k)
+ (($ $kargs) #t)
+ (_ #f)))))
(_
- (values nested-funs beta))))
- (intset-fold visit-cont body nested-funs beta)))
- (define (visit-funs worklist beta)
- (intset-fold visit-fun worklist empty-intset beta))
+ beta)))
+ (intset-fold visit-cont body beta)))
(persistent-intset
- (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
+ (intmap-fold visit-fun
+ (compute-reachable-functions conts kfun)
+ empty-intset)))
(define (compute-beta-var-substitutions conts label-set)
(define (add-var-substs label var-map)
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index e4ed473..d96b776 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -48,6 +48,7 @@
;; Flow analysis.
compute-constant-values
compute-function-body
+ compute-reachable-functions
compute-successors
invert-graph
compute-predecessors
@@ -231,6 +232,44 @@ disjoint, an error will be signalled."
(visit-cont k labels))
(_ labels)))))))))))
+(define (compute-reachable-functions conts kfun)
+ "Compute a mapping LABEL->LABEL..., where each key is a reachable
+$kfun and each associated value is the body of the function, as an
+intset."
+ (define (intset-cons i set) (intset-add set i))
+ (define (visit-fun kfun body to-visit)
+ (intset-fold
+ (lambda (label to-visit)
+ (define (return kfun*) (fold intset-cons to-visit kfun*))
+ (define (return1 kfun) (intset-add to-visit kfun))
+ (define (return0) to-visit)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ (($ $fun label) (return1 label))
+ (($ $rec _ _ (($ $fun labels) ...)) (return labels))
+ (($ $closure label nfree) (return1 label))
+ (($ $callk label) (return1 label))
+ (_ (return0))))
+ (_ (return0))))
+ body
+ to-visit))
+ (let lp ((to-visit (intset kfun)) (visited empty-intmap))
+ (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
+ (if (eq? to-visit empty-intset)
+ visited
+ (call-with-values
+ (lambda ()
+ (intset-fold
+ (lambda (kfun to-visit visited)
+ (let ((body (compute-function-body conts kfun)))
+ (values (visit-fun kfun body to-visit)
+ (intmap-add visited kfun body))))
+ to-visit
+ empty-intset
+ visited))
+ lp)))))
+
(define (compute-successors conts kfun)
(define (visit label succs)
(let visit ((label kfun) (succs empty-intmap))
diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm
index c833d0d..79b43f4 100644
--- a/module/language/cps2/verify.scm
+++ b/module/language/cps2/verify.scm
@@ -182,56 +182,24 @@ definitions that are available at LABEL."
(compute-available-definitions conts kfun)
first-order)))
-(define (reachable-functions conts kfun)
- (worklist-fold*
- (lambda (kfun kfuns)
- ;(pk 'verify kfun kfuns)
- (let ((kfuns (intset-add kfuns kfun)))
- (values (intset-fold
- (lambda (label nested)
- (define (return kfun*)
- ;(pk 'return label kfuns kfun* nested)
- (append (filter (lambda (kfun)
- (not (intset-ref kfuns kfun)))
- kfun*)
- nested))
- (define (return1 kfun) (return (list kfun)))
- (define (return0) (return '()))
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- (($ $fun label) (return1 label))
- (($ $rec _ _ (($ $fun labels) ...)) (return labels))
- (($ $closure label nfree) (return1 label))
- (($ $callk label) (return1 label))
- (_ (return0))))
- (_ (return0))))
- (compute-function-body conts kfun)
- '())
- kfuns)))
- (intset kfun)
- empty-intset))
-
(define (check-label-partition conts kfun)
;; A continuation can only belong to one function.
- (intset-fold
- (lambda (kfun seen)
+ (intmap-fold
+ (lambda (kfun body seen)
(intset-fold
(lambda (label seen)
(intmap-add seen label kfun
(lambda (old new)
(error "label used by two functions" label old new))))
- (compute-function-body conts kfun)
+ body
seen))
- (reachable-functions conts kfun)
+ (compute-reachable-functions conts kfun)
empty-intmap))
(define (compute-reachable-labels conts kfun)
- (intset-fold
- (lambda (kfun seen)
- (intset-union seen (compute-function-body conts kfun)))
- (reachable-functions conts kfun)
- empty-intset))
+ (intmap-fold (lambda (kfun body seen) (intset-union seen body))
+ (compute-reachable-functions conts kfun)
+ empty-intset))
(define (check-arities conts kfun)
(define (check-arity exp cont)
- [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, 2015/07/16
- [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 <=
- [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