summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-25 20:07:27 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-26 08:52:56 +0100
commit310da5e1efe70503e52f7a13f709775c319e6b7f (patch)
tree44315354db4913952e36689ca2874d5b703bc6fb /module
parent7338a49fa19311adc0eb00d6752235d6af8b3751 (diff)
downloadguile-310da5e1efe70503e52f7a13f709775c319e6b7f.tar.gz
Contification converges more quickly
* module/language/cps/contification.scm (compute-contification): Converge more quickly by using the information we compute within a compute-contification pass.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/contification.scm57
1 files changed, 47 insertions, 10 deletions
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index d78a4b40d..7d1f651f5 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -41,6 +41,7 @@
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
(cont-table (dfg-cont-table dfg))
+ (scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
(fun-elisions '())
@@ -52,9 +53,17 @@
(define (elide-function! k cont)
(set! fun-elisions (acons k cont fun-elisions)))
(define (splice-conts! scope conts)
+ (for-each (match-lambda
+ (($ $cont k) (hashq-set! scope-table k scope)))
+ conts)
(hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '()))))
+ (define (lookup-return-cont k)
+ (match (assq-ref cont-substs k)
+ (#f k)
+ (k (lookup-return-cont k))))
+
;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable.
(define (bound-symbol k)
@@ -101,7 +110,9 @@
(match (find-call (lookup-cont use cont-table))
(($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
- k))
+ ;; Converge more quickly by resolving already-contified
+ ;; call targets.
+ (lookup-return-cont k)))
(_ #f)))
;; If this set of functions is always called with one
@@ -132,23 +143,49 @@
;; defined, whose free variables are a superset of the free
;; variables of the functions.
;;
+ ;; There is some slight trickiness here. Call-target already uses
+ ;; the information we compute within this pass. Previous
+ ;; contifications may cause functions to be contified not at their
+ ;; point of definition but at their point of non-recursive use.
+ ;; That will cause the scope nesting to change. (It may
+ ;; effectively push a function deeper down the tree -- the second
+ ;; case above, a call within the letrec body.) What if we contify
+ ;; to the tail of a previously contified function? We have to
+ ;; track what the new scope tree will be when asking whether K
+ ;; will be bound in TERM-K's scope, not the scope tree that
+ ;; existed when we started the pass.
+ ;;
;; FIXME: Does this choose the right scope for contified let-bound
;; functions?
(define (find-contification-scope k)
- (if (continuation-bound-in? k term-k dfg)
- term-k
- (let ((scope (lookup-block-scope k dfg)))
- (match (lookup-cont scope cont-table)
- ;; The common continuation was the tail of some function
- ;; inside the letrec body. If that function has just
- ;; one clause, contify into that clause. Otherwise
- ;; bail.
+ (define (scope-contains? scope k)
+ (let ((k-scope (or (hashq-ref scope-table k)
+ (let ((k-scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k k-scope)
+ k-scope))))
+ (or (eq? scope k-scope)
+ (and k-scope (scope-contains? scope k-scope)))))
+
+ ;; Find the scope of K.
+ (define (continuation-scope k)
+ (or (hashq-ref scope-table k)
+ (let ((scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k scope)
+ scope)))
+
+ (let ((k-scope (continuation-scope k)))
+ (if (scope-contains? k-scope term-k)
+ term-k
+ (match (lookup-cont k-scope cont-table)
(($ $kentry self tail clauses)
+ ;; K is the tail of some function. If that function
+ ;; has just one clause, return that clause. Otherwise
+ ;; bail.
(match clauses
((($ $cont _ ($ $kclause arity ($ $cont kargs))))
kargs)
(_ #f)))
- (_ scope)))))
+ (_ k-scope)))))
;; We are going to contify. Mark all SYMs for replacement in
;; calls, and mark the tail continuations for replacement by K.