compiler.cfg.ssa: Cytron's SSA construction algorithm

db4
Slava Pestov 2009-07-21 17:49:30 -05:00
parent 7d792ab999
commit e7e5bee9a2
5 changed files with 240 additions and 9 deletions

View File

@ -34,11 +34,10 @@ V{ } 5 test-bb
[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
[ t ] [ 4 get 1 get dom-frontier key? ] unit-test
[ f ] [ 3 get 1 get dom-frontier key? ] unit-test
[ t ] [ 4 get 2 get dom-frontier key? ] unit-test
[ t ] [ 0 get dom-frontier assoc-empty? ] unit-test
[ t ] [ 4 get dom-frontier assoc-empty? ] unit-test
[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
[ f ] [ 0 get dom-frontier ] unit-test
[ f ] [ 4 get dom-frontier ] unit-test
! Example from the paper
V{ } 0 test-bb

View File

@ -1,8 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math compiler.cfg.rpo
compiler.cfg.stack-analysis fry kernel math.order namespaces
sequences ;
USING: accessors assocs combinators sets math fry kernel math.order
namespaces sequences sorting compiler.cfg.rpo ;
IN: compiler.cfg.dominance
! Reference:
@ -66,7 +65,7 @@ SYMBOL: dom-frontiers
PRIVATE>
: dom-frontier ( bb -- set ) dom-frontiers get at ;
: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
<PRIVATE

View File

@ -14,6 +14,14 @@ M: ##flushable rename-insn-defs
[ rename-value ] change-dst
drop ;
M: ##fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: _fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: insn rename-insn-defs drop ;
GENERIC: rename-insn-uses ( insn -- )

View File

@ -0,0 +1,79 @@
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.dominance compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.ssa assocs
compiler.cfg.registers cpu.architecture kernel namespaces sequences
tools.test vectors ;
IN: compiler.cfg.ssa.tests
! Reset counters so that results are deterministic w.r.t. hash order
0 vreg-counter set-global
0 basic-block set-global
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
T{ ##branch }
} 0 test-bb
V{
T{ ##load-immediate f V int-regs 3 3 }
T{ ##branch }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 3 4 }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 3 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
: test-ssa ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-dominance
construct-ssa
drop ;
[ ] [ test-ssa ] unit-test
[
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
T{ ##branch }
}
] [ 0 get instructions>> ] unit-test
[
V{
T{ ##load-immediate f V int-regs 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
T{ ##load-immediate f V int-regs 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
[
V{
T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
T{ ##replace f V int-regs 6 D 0 }
T{ ##return }
}
] [
3 get instructions>>
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
] unit-test

View File

@ -0,0 +1,146 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel accessors sequences fry dlists
deques assocs sets math combinators sorting
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.renaming
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions ;
IN: compiler.cfg.ssa
! SSA construction. Predecessors and dominance must be computed first.
! This is the classical algorithm based on dominance frontiers:
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
! Eventually might be worth trying something fancier:
! http://portal.acm.org/citation.cfm?id=1065887.1065890
<PRIVATE
! Maps vreg to sequence of basic blocks
SYMBOL: defs
! Maps basic blocks to sequences of vregs
SYMBOL: inserting-phi-nodes
: compute-defs ( cfg -- )
H{ } clone dup defs set
'[
dup instructions>> [
defs-vregs [
_ push-at
] with each
] with each
] each-basic-block ;
SYMBOLS: has-already ever-on-work-list work-list ;
: init-insert-phi-nodes ( bbs -- )
H{ } clone has-already set
[ unique ever-on-work-list set ]
[ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
: add-to-work-list ( bb -- )
dup ever-on-work-list get key? [ drop ] [
[ ever-on-work-list get conjoin ]
[ work-list get push-front ]
bi
] if ;
: insert-phi-node-later ( vreg bb -- )
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
inserting-phi-nodes get push-at ;
: compute-phi-node-in ( vreg bb -- )
dup has-already get key? [ 2drop ] [
[ insert-phi-node-later ]
[ has-already get conjoin ]
[ add-to-work-list ]
tri
] if ;
: compute-phi-nodes-for ( vreg bbs -- )
dup length 2 >= [
init-insert-phi-nodes
work-list get [
dom-frontier [
compute-phi-node-in
] with each
] with slurp-deque
] [ 2drop ] if ;
: compute-phi-nodes ( -- )
H{ } clone inserting-phi-nodes set
defs get [ compute-phi-nodes-for ] assoc-each ;
: insert-phi-nodes-in ( phis bb -- )
[ append ] change-instructions drop ;
: insert-phi-nodes ( -- )
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
SYMBOLS: stacks originals ;
: init-renaming ( -- )
H{ } clone stacks set
H{ } clone originals set ;
: gen-name ( vreg -- vreg' )
[ reg-class>> next-vreg ] keep
[ stacks get push-at ]
[ swap originals get set-at ]
[ drop ]
2tri ;
: top-name ( vreg -- vreg' )
stacks get at last ;
GENERIC: rename-insn ( insn -- )
M: insn rename-insn
[ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ]
[ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ]
bi ;
M: ##phi rename-insn
dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
: rename-insns ( bb -- )
instructions>> [ rename-insn ] each ;
: rename-successor-phi ( phi bb -- )
swap inputs>> [ top-name ] change-at ;
: rename-successor-phis ( succ bb -- )
[ inserting-phi-nodes get at ] dip
'[ _ rename-successor-phi ] each ;
: rename-successors-phis ( bb -- )
[ successors>> ] keep '[ _ rename-successor-phis ] each ;
: pop-stacks ( bb -- )
instructions>> [
defs-vregs originals get stacks get
'[ _ at _ at pop* ] each
] each ;
: rename-in-block ( bb -- )
{
[ rename-insns ]
[ rename-successors-phis ]
[ dom-children [ rename-in-block ] each ]
[ pop-stacks ]
} cleave ;
: rename ( cfg -- )
init-renaming
entry>> rename-in-block ;
PRIVATE>
: construct-ssa ( cfg -- cfg' )
dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;