compiler.cfg.ssa: Cytron's SSA construction algorithm
Slava Pestov
parent
7d792ab999
commit
e7e5bee9a2
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue