101 lines
2.4 KiB
Factor
101 lines
2.4 KiB
Factor
! Copyright (C) 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors assocs combinators compiler.cfg.predecessors
|
|
compiler.cfg.rpo deques dlists fry kernel locals math math.order
|
|
namespaces sequences sorting vectors ;
|
|
IN: compiler.cfg.dominance
|
|
|
|
<PRIVATE
|
|
|
|
SYMBOL: dom-parents
|
|
|
|
PRIVATE>
|
|
|
|
: dom-parent ( bb -- bb' ) dom-parents get at ;
|
|
|
|
<PRIVATE
|
|
|
|
: set-idom ( idom bb -- changed? )
|
|
dom-parents get maybe-set-at ;
|
|
|
|
: intersect ( finger1 finger2 -- bb )
|
|
2dup [ number>> ] compare {
|
|
{ +gt+ [ [ dom-parent ] dip intersect ] }
|
|
{ +lt+ [ dom-parent intersect ] }
|
|
[ 2drop ]
|
|
} case ;
|
|
|
|
: compute-idom ( bb -- idom )
|
|
predecessors>> [ dom-parent ] filter
|
|
[ ] [ intersect ] map-reduce ;
|
|
|
|
: iterate ( rpo -- changed? )
|
|
f [ [ compute-idom ] keep set-idom or ] reduce ;
|
|
|
|
: compute-dom-parents ( cfg -- )
|
|
H{ } clone dom-parents set
|
|
reverse-post-order
|
|
unclip dup set-idom drop '[ _ iterate ] loop ;
|
|
|
|
SYMBOL: dom-childrens
|
|
|
|
PRIVATE>
|
|
|
|
: dom-children ( bb -- seq ) dom-childrens get at ;
|
|
|
|
<PRIVATE
|
|
|
|
: compute-dom-children ( dom-parents -- dom-childrens )
|
|
H{ } clone [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
|
|
[ [ number>> ] sort-with ] assoc-map ;
|
|
|
|
SYMBOLS: preorder maxpreorder ;
|
|
|
|
PRIVATE>
|
|
|
|
: pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ;
|
|
|
|
: maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ;
|
|
|
|
<PRIVATE
|
|
|
|
: (compute-dfs) ( n bb -- n )
|
|
[ 1 + ] dip
|
|
[ dupd preorder get set-at ]
|
|
[ dom-children [ (compute-dfs) ] each ]
|
|
[ dupd maxpreorder get set-at ]
|
|
tri ;
|
|
|
|
: compute-dfs ( cfg -- )
|
|
H{ } clone preorder set
|
|
H{ } clone maxpreorder set
|
|
[ 0 ] dip entry>> (compute-dfs) drop ;
|
|
|
|
: compute-dominance ( cfg -- )
|
|
[
|
|
compute-dom-parents
|
|
dom-parents get compute-dom-children dom-childrens set
|
|
] [ compute-dfs ] bi ;
|
|
|
|
PRIVATE>
|
|
|
|
: needs-dominance ( cfg -- )
|
|
[ needs-predecessors ]
|
|
[
|
|
dup dominance-valid?>> [ drop ]
|
|
[ t >>dominance-valid? compute-dominance ] if
|
|
] bi ;
|
|
|
|
: dominates? ( bb1 bb2 -- ? )
|
|
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
|
|
|
|
:: breadth-first-order ( cfg -- bfo )
|
|
<dlist> :> work-list
|
|
cfg post-order length <vector> :> accum
|
|
cfg entry>> work-list push-front
|
|
work-list [
|
|
[ accum push ]
|
|
[ dom-children work-list push-all-front ] bi
|
|
] slurp-deque
|
|
accum ;
|