mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

DFG refactor to allow dominator tree construction

Browse source 
* module/language/cps/dfg.scm: Refactor so that we can think about
  building a dominator tree.  Split continuations out of use maps and
  put them in a separate table, which will have more flow information.
  (visit-fun): Mark clauses as using their bodies.
  (lookup-predecessors, lookup-successors): New exports.
  (find-defining-expression): Add an exception for clauses, now that
  clauses are in the flow graph.
  (continuation-bound-in?): Rename from variable-bound-in?, as it can
  currently only be used for continuations.

* module/language/cps/contification.scm (contify): Adapt to use
  lookup-predecessors and continuation-bound-in?.
This commit is contained in:
Andy Wingo 2013-10-10 12:42:50 +02:00
parent 6b71a76713
commit f22979db66
2 changed files with 143 additions and 116 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/cps/contification.scm
View file

@ -90,7 +90,7 @@
(define (bound-symbol k)
(match (lookup-cont k cont-table)
(($ $kargs (_) (sym))
(match (lookup-uses k dfg)
(match (lookup-predecessors k dfg)
((_)
;; K has one predecessor, the one that defined SYM.
sym)
@ -148,7 +148,7 @@
;; We have a common continuation. High fives!
;;
;; (1) Find the scope at which to contify.
(let ((scope (if (variable-bound-in? k term-k dfg)
(let ((scope (if (continuation-bound-in? k term-k dfg)
term-k
(lookup-def k dfg))))
;; (2) Mark all SYMs for replacement in calls, and

221
module/language/cps/dfg.scm
View file

@ -21,7 +21,7 @@
;;; Many passes rely on a local or global static analysis of a function.
;;; This module implements a simple data-flow graph (DFG) analysis,
;;; tracking the definitions and uses of variables and continuations.
;;; It also builds a table of continuations and parent links, to be able
;;; It also builds a table of continuations and scope links, to be able
;;; to easily determine if one continuation is in the scope of another,
;;; and to get to the expression inside a continuation.
;;;
@ -48,13 +48,15 @@
dfg-cont-table
lookup-def
lookup-uses
lookup-predecessors
lookup-successors
find-call
call-expression
find-expression
find-defining-expression
find-constant-value
lift-definition!
variable-bound-in?
continuation-bound-in?
variable-free-in?
constant-needs-allocation?
dead-after-def?
@ -86,14 +88,14 @@
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
(make-dfg conts use-maps uplinks)
(make-dfg conts blocks use-maps)
dfg?
;; hash table of sym -> $kargs, $kif, etc
;; hash table of sym -> $kif, $kargs, etc
(conts dfg-cont-table)
;; hash table of sym -> $block
(blocks dfg-blocks)
;; hash table of sym -> $use-map
(use-maps dfg-use-maps)
;; hash table of sym -> $parent-link
(uplinks dfg-uplinks))
(use-maps dfg-use-maps))
(define-record-type $use-map
(make-use-map sym def uses)
@ -102,13 +104,21 @@
(def use-map-def)
(uses use-map-uses set-use-map-uses!))
(define-record-type $uplink
(make-uplink parent level)
uplink?
(parent uplink-parent)
(level uplink-level))
(define-record-type $block
(%make-block scope scope-level preds succs idom dom-level loop-header)
block?
(scope block-scope set-block-scope!)
(scope-level block-scope-level set-block-scope-level!)
(preds block-preds set-block-preds!)
(succs block-succs set-block-succs!)
(idom block-idom set-block-idom!)
(dom-level block-dom-level set-block-dom-level!)
(loop-header block-loop-header set-block-loop-header!))
(define (visit-fun fun conts use-maps uplinks global?)
(define (make-block scope scope-level)
(%make-block scope scope-level '() '() #f #f #f))
(define (visit-fun fun conts blocks use-maps global?)
(define (add-def! sym def-k)
(unless def-k
(error "Term outside labelled continuation?"))
@ -120,25 +130,34 @@
((and use-map ($ $use-map sym def uses))
(set-use-map-uses! use-map (cons use-k uses)))))
(define (link-parent! k parent)
(match (hashq-ref uplinks parent)
(($ $uplink _ level)
(hashq-set! uplinks k (make-uplink parent (1+ level))))))
(define* (declare-block! label cont parent
#:optional (level
(1+ (lookup-scope-level parent blocks))))
(hashq-set! conts label cont)
(hashq-set! blocks label (make-block parent level)))
(define (link-blocks! pred succ)
(let ((pred-block (hashq-ref blocks pred))
(succ-block (hashq-ref blocks succ)))
(unless (and pred-block succ-block)
(error "internal error"))
(set-block-succs! pred-block (cons succ (block-succs pred-block)))
(set-block-preds! succ-block (cons pred (block-preds succ-block)))))
(define (visit exp exp-k)
(define (def! sym)
(add-def! sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! sym)
(link-blocks! exp-k sym))
(define (recur exp)
(visit exp exp-k))
(match exp
(($ $letk (($ $cont k src cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k)
(def! k)
(hashq-set! conts k cont)
(link-parent! k exp-k))
(declare-block! k cont exp-k))
cont k)
(for-each visit cont k)
(recur body))
@ -148,21 +167,21 @@
(recur body))
(($ $kif kt kf)
(use! kt)
(use! kf))
(use-k! kt)
(use-k! kf))
(($ $ktrunc arity k)
(use! k))
(use-k! k))
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
(for-each def! syms)
(for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
(($ $continue k exp)
(use! k)
(use-k! k)
(match exp
(($ $var sym)
(use! sym))
@ -179,11 +198,11 @@
(($ $prompt escape? tag handler)
(use! tag)
(use! handler))
(use-k! handler))
(($ $fun)
(when global?
(visit-fun exp conts use-maps uplinks global?)))
(visit-fun exp conts blocks use-maps global?)))
(_ #f)))))
@ -192,44 +211,45 @@
($ $cont kentry src
(and entry
($ $kentry self ($ $cont ktail _ tail) clauses))))
;; Treat the fun continuation as its own parent.
(add-def! kentry kentry)
(declare-block! kentry entry #f 0)
(add-def! self kentry)
(hashq-set! uplinks kentry (make-uplink #f 0))
(hashq-set! conts kentry entry)
(add-def! ktail kentry)
(hashq-set! conts ktail tail)
(link-parent! ktail kentry)
(declare-block! ktail tail kentry)
(for-each
(match-lambda
(($ $cont kclause _
(and clause ($ $kclause arity ($ $cont kbody _ body))))
(add-def! kclause kentry)
(hashq-set! conts kclause clause)
(link-parent! kclause kentry)
(declare-block! kclause clause kentry)
(link-blocks! kentry kclause)
(add-def! kbody kclause)
(hashq-set! conts kbody body)
(link-parent! kbody kclause)
(declare-block! kbody body kclause)
(link-blocks! kclause kbody)
(visit body kbody)))
#;
(compute-dominator-tree kentry use-maps dnodes)
clauses))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
(use-maps (make-hash-table))
(uplinks (make-hash-table)))
(visit-fun fun conts use-maps uplinks global?)
(make-dfg conts use-maps uplinks)))
(blocks (make-hash-table))
(use-maps (make-hash-table)))
(visit-fun fun conts blocks use-maps global?)
(make-dfg conts blocks use-maps)))
(define (lookup-uplink k uplinks)
(let ((res (hashq-ref uplinks k)))
(define (lookup-block k blocks)
(let ((res (hashq-ref blocks k)))
(unless res
(error "Unknown continuation!" k (hash-fold acons '() uplinks)))
(error "Unknown continuation!" k (hash-fold acons '() blocks)))
res))
(define (lookup-scope-level k blocks)
(match (lookup-block k blocks)
(($ $block _ scope-level) scope-level)))
(define (lookup-use-map sym use-maps)
(let ((res (hashq-ref use-maps sym)))
(unless res
@ -238,20 +258,28 @@
(define (lookup-def sym dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
def)))))
(define (lookup-uses sym dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
uses)))))
(define (lookup-predecessors k dfg)
(match (lookup-block k (dfg-blocks dfg))
(($ $block _ _ preds succs) preds)))
(define (lookup-successors k dfg)
(match (lookup-block k (dfg-blocks dfg))
(($ $block _ _ preds succs) succs)))
(define (find-defining-term sym dfg)
(match (lookup-uses (lookup-def sym dfg) dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k)
(lookup-cont def-exp-k (dfg-cont-table dfg)))
(else #f)))
@ -274,6 +302,7 @@
(match (find-defining-term sym dfg)
(#f #f)
(($ $ktrunc) #f)
(($ $kclause) #f)
(term (find-expression term))))
(define (find-constant-value sym dfg)
@ -292,7 +321,7 @@
(($ $letk conts body) (find-exp body))
(else term)))
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map _ def uses)
(or-map
@ -315,45 +344,50 @@
(_ #t)))
uses))))))
(define (continuation-scope-contains? parent-k k uplinks)
(match (lookup-uplink parent-k uplinks)
(($ $uplink _ parent-level)
(define (continuation-scope-contains? scope-k k blocks)
(let ((scope-level (lookup-scope-level scope-k blocks)))
(let lp ((k k))
(or (eq? parent-k k)
(match (lookup-uplink k uplinks)
(($ $uplink parent level)
(and (< parent-level level)
(lp parent)))))))))
(or (eq? scope-k k)
(match (lookup-block k blocks)
(($ $block scope level)
(and (< scope-level level)
(lp scope))))))))
(define (lift-definition! k parent-k dfg)
;; FIXME: Splice preds, succs, dom tree.
(define (lift-definition! k scope-k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(match (lookup-uplink parent-k uplinks)
(($ $uplink parent level)
(hashq-set! uplinks k
(make-uplink parent-k (1+ level)))
;; Lift definitions of all conts in K.
(($ $dfg conts blocks use-maps)
(let ((scope-level (1+ (lookup-scope-level scope-k blocks))))
;; Fix parent scope link of K.
(match (lookup-block k blocks)
((and block ($ $block))
(set-block-scope! block scope-k)))
;; Fix up scope levels of K and all contained scopes.
(let update-levels! ((k k) (level scope-level))
(match (lookup-block k blocks)
((and block ($ $block))
(set-block-scope-level! block scope-level)))
(let lp ((cont (lookup-cont k conts)))
(match cont
(($ $letk (($ $cont kid) ...) body)
(for-each (cut lift-definition! <> k dfg) kid)
(for-each (cut update-levels! <> (1+ scope-level)) kid)
(lp body))
(($ $letrec names syms funs body)
(lp body))
(_ #t))))))))
(define (variable-bound-in? var k dfg)
(define (continuation-bound-in? k use-k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(match (lookup-use-map var use-maps)
(($ $use-map sym def uses)
(continuation-scope-contains? def k uplinks))))))
(($ $dfg conts blocks use-maps)
(match (lookup-block k blocks)
(($ $block def-k)
(continuation-scope-contains? def-k use-k blocks))))))
(define (variable-free-in? var k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(or-map (lambda (use)
(continuation-scope-contains? k use uplinks))
(continuation-scope-contains? k use blocks))
(match (lookup-use-map var use-maps)
(($ $use-map sym def uses)
uses))))))
@ -366,59 +400,52 @@
;; relationship. See
;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
;; deeper discussion.
(define (conservatively-dominates? k1 k2 uplinks)
(continuation-scope-contains? k1 k2 uplinks))
(define (conservatively-dominates? k1 k2 blocks)
(continuation-scope-contains? k1 k2 blocks))
(define (dead-after-def? sym dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
(null? uses))))))
(define (dead-after-use? sym use-k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
;; If all other uses dominate this use, it is now dead. There
;; are other ways for it to be dead, but this is an
;; approximation. A better check would be if the successor
;; post-dominates all uses.
(and-map (cut conservatively-dominates? <> use-k uplinks)
(and-map (cut conservatively-dominates? <> use-k blocks)
uses))))))
;; A continuation is a "branch" if all of its predecessors are $kif
;; continuations.
(define (branch? k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(match (lookup-use-map k use-maps)
(($ $use-map sym def uses)
(and (not (null? uses))
(let ((preds (lookup-predecessors k dfg)))
(and (not (null? preds))
(and-map (lambda (k)
(match (lookup-cont k conts)
(match (lookup-cont k (dfg-cont-table dfg))
(($ $kif) #t)
(_ #f)))
uses)))))))
preds))))
(define (find-other-branches k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(match (lookup-use-map k use-maps)
(($ $use-map sym def (uses ..1))
(map (lambda (kif)
(match (lookup-cont kif conts)
(match (lookup-cont kif (dfg-cont-table dfg))
(($ $kif (? (cut eq? <> k)) kf)
kf)
(($ $kif kt (? (cut eq? <> k)))
kt)
(_ (error "Not all predecessors are branches"))))
uses))))))
(lookup-predecessors k dfg)))
(define (dead-after-branch? sym branch other-branches dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
(($ $use-map sym def uses)
(and-map
@ -426,15 +453,15 @@
;; A symbol is dead after a branch if at least one of the
;; other branches dominates a use of the symbol, and all
;; other uses of the symbol dominate the test.
(if (or-map (cut conservatively-dominates? <> use-k uplinks)
(if (or-map (cut conservatively-dominates? <> use-k blocks)
other-branches)
(not (conservatively-dominates? branch use-k uplinks))
(conservatively-dominates? use-k branch uplinks)))
(not (conservatively-dominates? branch use-k blocks))
(conservatively-dominates? use-k branch blocks)))
uses))))))
(define (lookup-bound-syms k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
(($ $dfg conts blocks use-maps)
(match (lookup-cont k conts)
(($ $kargs names syms body)
syms)))))