109 lines
2.7 KiB
Factor
109 lines
2.7 KiB
Factor
! Copyright (C) 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs bit-arrays bit-sets fry
|
|
hashtables hints kernel locals math namespaces sequences sets
|
|
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
|
|
IN: compiler.cfg.ssa.construction.tdmsc
|
|
|
|
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
|
|
! Phi-Function Computation Using DJ Graphs"
|
|
|
|
! http://portal.acm.org/citation.cfm?id=1065887.1065890
|
|
|
|
<PRIVATE
|
|
|
|
SYMBOLS: visited merge-sets levels again? ;
|
|
|
|
: init-merge-sets ( cfg -- )
|
|
post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
|
|
|
|
: compute-levels ( cfg -- )
|
|
0 over entry>> associate [
|
|
'[
|
|
_ [ [ dom-parent ] dip at 1 + ] 2keep set-at
|
|
] each-basic-block
|
|
] keep levels set ;
|
|
|
|
: j-edge? ( from to -- ? )
|
|
2dup eq? [ 2drop f ] [ dominates? not ] if ;
|
|
|
|
: level ( bb -- n ) levels get at ; inline
|
|
|
|
: set-bit ( bit-array n -- )
|
|
[ t ] 2dip swap set-nth ;
|
|
|
|
: update-merge-set ( tmp to -- )
|
|
[ merge-sets get ] dip
|
|
'[
|
|
_
|
|
[ merge-sets get at bit-set-union ]
|
|
[ dupd number>> set-bit ]
|
|
bi
|
|
] change-at ;
|
|
|
|
:: walk ( tmp to lnode -- lnode )
|
|
tmp level to level >= [
|
|
tmp to update-merge-set
|
|
tmp dom-parent to tmp walk
|
|
] [ lnode ] if ;
|
|
|
|
: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
|
|
[ [ predecessors>> ] keep ] dip
|
|
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
|
|
|
|
: visited? ( pair -- ? ) visited get key? ;
|
|
|
|
: consistent? ( snode lnode -- ? )
|
|
[ merge-sets get at ] bi@ swap bit-set-subset? ;
|
|
|
|
: (process-edge) ( from to -- )
|
|
f walk [
|
|
2dup 2array visited? [
|
|
consistent? [ again? on ] unless
|
|
] [ 2drop ] if
|
|
] each-incoming-j-edge ;
|
|
|
|
: process-edge ( from to -- )
|
|
2dup 2array dup visited? [ 3drop ] [
|
|
visited get conjoin
|
|
(process-edge)
|
|
] if ;
|
|
|
|
: process-block ( bb -- )
|
|
[ process-edge ] each-incoming-j-edge ;
|
|
|
|
: compute-merge-set-step ( bfo -- )
|
|
visited get clear-assoc
|
|
[ process-block ] each ;
|
|
|
|
: compute-merge-set-loop ( cfg -- )
|
|
breadth-first-order
|
|
'[ again? off _ compute-merge-set-step again? get ]
|
|
loop ;
|
|
|
|
: (merge-set) ( bbs -- flags rpo )
|
|
merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
|
|
cfg get reverse-post-order ; inline
|
|
|
|
: filter-by ( flags seq -- seq' )
|
|
[ drop ] pusher [ 2each ] dip ;
|
|
|
|
HINTS: filter-by { bit-array object } ;
|
|
|
|
PRIVATE>
|
|
|
|
: compute-merge-sets ( cfg -- )
|
|
dup cfg set
|
|
H{ } clone visited set
|
|
[ compute-levels ]
|
|
[ init-merge-sets ]
|
|
[ compute-merge-set-loop ]
|
|
tri ;
|
|
|
|
: merge-set-each ( bbs quot: ( bb -- ) -- )
|
|
[ (merge-set) ] dip '[
|
|
swap _ [ drop ] if
|
|
] 2each ; inline
|
|
|
|
: merge-set ( bbs -- bbs' )
|
|
(merge-set) filter-by ; |