compiler.cfg.ssa.destruction: new implementation: simpler and more correct
Slava Pestov
parent
c1c8424605
commit
82c1106945
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel locals
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.ssa.cssa
|
||||
|
||||
! Convert SSA to conventional SSA.
|
||||
|
||||
:: insert-copy ( bb src -- bb dst )
|
||||
i :> dst
|
||||
bb [ dst src ##copy ] add-instructions
|
||||
bb dst ;
|
||||
|
||||
: convert-phi ( ##phi -- )
|
||||
[ [ insert-copy ] assoc-map ] change-inputs drop ;
|
||||
|
||||
: construct-cssa ( cfg -- )
|
||||
[ [ convert-phi ] each-phi ] each-basic-block ;
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs hashtables fry kernel make namespaces
|
||||
sets sequences compiler.cfg.ssa.destruction.state
|
||||
compiler.cfg.parallel-copy compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.ssa.destruction.copies
|
||||
|
||||
ERROR: bad-copy ;
|
||||
|
||||
: compute-copies ( assoc -- assoc' )
|
||||
dup assoc-size <hashtable> [
|
||||
'[
|
||||
prune [
|
||||
2dup eq? [ 2drop ] [
|
||||
_ 2dup key?
|
||||
[ bad-copy ] [ set-at ] if
|
||||
] if
|
||||
] with each
|
||||
] assoc-each
|
||||
] keep ;
|
||||
|
||||
: insert-copies ( -- )
|
||||
waiting get [
|
||||
'[ _ compute-copies parallel-copy ] add-instructions
|
||||
] assoc-each ;
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
USING: compiler.cfg.instructions compiler.cfg.registers cpu.architecture
|
||||
compiler.cfg.debugger arrays accessors kernel namespaces sequences assocs
|
||||
compiler.cfg.predecessors compiler.cfg.ssa.destruction tools.test
|
||||
compiler.cfg vectors ;
|
||||
IN: compiler.cfg.ssa.destruction.tests
|
||||
|
||||
! This needs way more tests
|
||||
|
||||
! Untested code path
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 2 H{ { 2 V int-regs 1 } { 3 V int-regs 0 } } }
|
||||
} 4 test-bb
|
||||
|
||||
0 { 1 3 } edges
|
||||
1 2 edge
|
||||
2 4 edge
|
||||
3 4 edge
|
||||
|
||||
: test-destruction ( -- )
|
||||
cfg new 0 get >>entry compute-predecessors destruct-ssa drop ;
|
||||
|
||||
[ ] [ test-destruction ] unit-test
|
||||
|
||||
! "Virtual swap" problem
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 2 H{ { 1 V int-regs 0 } { 2 V int-regs 1 } } }
|
||||
T{ ##phi f V int-regs 3 H{ { 1 V int-regs 1 } { 2 V int-regs 0 } } }
|
||||
} 3 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
1 3 edge
|
||||
2 3 edge
|
||||
|
||||
[ ] [ test-destruction ] unit-test
|
||||
|
||||
! How to test?
|
||||
|
||||
! Reduction of suffix-arrays regression
|
||||
V{
|
||||
T{ ##peek f V int-regs 48 D 0 }
|
||||
T{ ##peek f V int-regs 47 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 94 H{ { 1 V int-regs 48 } { 2 V int-regs 47 } } }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 6 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 7 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 56 H{ { 3 V int-regs 48 } { 6 V int-regs 94 } { 7 V int-regs 94 } { 5 V int-regs 47 } } }
|
||||
T{ ##branch }
|
||||
} 8 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
1 { 3 4 } edges
|
||||
2 { 4 5 } edges
|
||||
4 { 6 7 } edges
|
||||
3 8 edge
|
||||
6 8 edge
|
||||
7 8 edge
|
||||
5 8 edge
|
||||
|
||||
[ ] [ test-destruction ] unit-test
|
||||
|
||||
[ f ] [ 0 get instructions>> first2 [ dst>> ] bi@ = ] unit-test
|
||||
|
|
@ -1,63 +1,109 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel locals math math.order
|
||||
sequences namespaces sets
|
||||
USING: accessors arrays assocs fry kernel namespaces
|
||||
sequences sequences.deep
|
||||
sets vectors
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.liveness.ssa
|
||||
compiler.cfg.critical-edges
|
||||
compiler.cfg.ssa.destruction.state
|
||||
compiler.cfg.ssa.destruction.forest
|
||||
compiler.cfg.ssa.destruction.copies
|
||||
compiler.cfg.ssa.destruction.renaming
|
||||
compiler.cfg.ssa.cssa
|
||||
compiler.cfg.ssa.interference
|
||||
compiler.cfg.ssa.interference.live-ranges
|
||||
compiler.cfg.ssa.destruction.process-blocks ;
|
||||
compiler.utilities ;
|
||||
IN: compiler.cfg.ssa.destruction
|
||||
|
||||
! Based on "Fast Copy Coalescing and Live-Range Identification"
|
||||
! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
|
||||
! Maps vregs to leaders.
|
||||
SYMBOL: leader-map
|
||||
|
||||
! Dominance, liveness and def-use need to be computed
|
||||
: leader ( vreg -- vreg' ) leader-map get compress-path ;
|
||||
|
||||
: process-blocks ( cfg -- )
|
||||
[ [ process-block ] if-has-phis ] each-basic-block ;
|
||||
! Maps leaders to equivalence class elements.
|
||||
SYMBOL: class-element-map
|
||||
|
||||
SYMBOL: seen
|
||||
: class-elements ( vreg -- elts ) class-element-map get at ;
|
||||
|
||||
:: visit-renaming ( dst assoc src bb -- )
|
||||
src seen get key? [
|
||||
src dst bb add-waiting
|
||||
src assoc delete-at
|
||||
] [ src seen get conjoin ] if ;
|
||||
! Sequence of vreg pairs
|
||||
SYMBOL: copies
|
||||
|
||||
:: break-interferences ( -- )
|
||||
H{ } clone seen set
|
||||
renaming-sets get [| dst assoc |
|
||||
assoc [| src bb |
|
||||
dst assoc src bb visit-renaming
|
||||
] assoc-each
|
||||
: init-coalescing ( -- )
|
||||
H{ } clone leader-map set
|
||||
H{ } clone class-element-map set
|
||||
V{ } clone copies set ;
|
||||
|
||||
: classes-interfere? ( vreg1 vreg2 -- ? )
|
||||
[ leader ] bi@ 2dup eq? [ 2drop f ] [
|
||||
[ class-elements flatten ] bi@
|
||||
'[
|
||||
_ [
|
||||
interferes?
|
||||
] with any?
|
||||
] any?
|
||||
] if ;
|
||||
|
||||
: update-leaders ( vreg1 vreg2 -- )
|
||||
swap leader-map get set-at ;
|
||||
|
||||
: merge-classes ( vreg1 vreg2 -- )
|
||||
[ [ class-elements ] bi@ push ]
|
||||
[ drop class-element-map get delete-at ] 2bi ;
|
||||
|
||||
: eliminate-copy ( vreg1 vreg2 -- )
|
||||
[ leader ] bi@
|
||||
2dup eq? [ 2drop ] [
|
||||
[ update-leaders ] [ merge-classes ] 2bi
|
||||
] if ;
|
||||
|
||||
: introduce-vreg ( vreg -- )
|
||||
[ leader-map get conjoin ]
|
||||
[ [ 1vector ] keep class-element-map get set-at ] bi ;
|
||||
|
||||
GENERIC: prepare-insn ( insn -- )
|
||||
|
||||
M: ##copy prepare-insn
|
||||
[ dst>> ] [ src>> ] bi 2array copies get push ;
|
||||
|
||||
M: ##phi prepare-insn
|
||||
[ dst>> ] [ inputs>> values ] bi
|
||||
[ eliminate-copy ] with each ;
|
||||
|
||||
M: insn prepare-insn drop ;
|
||||
|
||||
: prepare-block ( bb -- )
|
||||
instructions>> [ prepare-insn ] each ;
|
||||
|
||||
: prepare-coalescing ( cfg -- )
|
||||
init-coalescing
|
||||
defs get keys [ introduce-vreg ] each
|
||||
[ prepare-block ] each-basic-block ;
|
||||
|
||||
: process-copies ( -- )
|
||||
copies get [
|
||||
2dup classes-interfere?
|
||||
[ 2drop ] [ eliminate-copy ] if
|
||||
] assoc-each ;
|
||||
|
||||
: remove-phis-from-block ( bb -- )
|
||||
instructions>> [ ##phi? not ] filter-here ;
|
||||
: useless-copy? ( ##copy -- ? )
|
||||
dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
|
||||
|
||||
: remove-phis ( cfg -- )
|
||||
[ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
|
||||
: perform-renaming ( cfg -- )
|
||||
leader-map get keys [ dup leader ] H{ } map>assoc renamings set
|
||||
[
|
||||
instructions>> [
|
||||
[ rename-insn-defs ]
|
||||
[ rename-insn-uses ]
|
||||
[ [ useless-copy? ] [ ##phi? ] bi or not ] tri
|
||||
] filter-here
|
||||
] each-basic-block ;
|
||||
|
||||
: destruct-ssa ( cfg -- cfg' )
|
||||
dup cfg-has-phis? [
|
||||
dup split-critical-edges
|
||||
compute-ssa-live-sets
|
||||
init-coalescing
|
||||
dup compute-def-use
|
||||
dup compute-dominance
|
||||
dup compute-live-ranges
|
||||
dup process-blocks
|
||||
break-interferences
|
||||
dup perform-renaming
|
||||
insert-copies
|
||||
dup remove-phis
|
||||
] when ;
|
||||
dup construct-cssa
|
||||
compute-ssa-live-sets
|
||||
dup compute-defs
|
||||
dup compute-dominance
|
||||
dup compute-live-ranges
|
||||
dup prepare-coalescing
|
||||
process-copies
|
||||
dup perform-renaming ;
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
|
||||
compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
|
||||
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
|
||||
cpu.architecture kernel namespaces sequences tools.test vectors sorting
|
||||
math.order ;
|
||||
IN: compiler.cfg.ssa.destruction.forest.tests
|
||||
|
||||
V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
|
||||
V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
|
||||
V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
|
||||
V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
|
||||
V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
|
||||
V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
|
||||
V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
2 { 3 4 } edges
|
||||
3 5 edge
|
||||
4 5 edge
|
||||
1 6 edge
|
||||
5 6 edge
|
||||
|
||||
: clean-up-forest ( forest -- forest' )
|
||||
[ [ vreg>> n>> ] compare ] sort
|
||||
[
|
||||
[ clean-up-forest ] change-children
|
||||
[ number>> ] change-bb
|
||||
] V{ } map-as ;
|
||||
|
||||
: test-dom-forest ( vregs -- forest )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
dup compute-dominance
|
||||
compute-def-use
|
||||
compute-dom-forest
|
||||
clean-up-forest ;
|
||||
|
||||
[ V{ } ] [ { } test-dom-forest ] unit-test
|
||||
|
||||
[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
|
||||
[ { V int-regs 0 } test-dom-forest ]
|
||||
unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ dom-forest-node
|
||||
f
|
||||
V int-regs 0
|
||||
0
|
||||
V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
|
||||
}
|
||||
}
|
||||
]
|
||||
[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
|
||||
unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ dom-forest-node
|
||||
f
|
||||
V int-regs 1
|
||||
1
|
||||
V{ }
|
||||
}
|
||||
T{ dom-forest-node
|
||||
f
|
||||
V int-regs 2
|
||||
2
|
||||
V{
|
||||
T{ dom-forest-node f V int-regs 3 3 V{ } }
|
||||
T{ dom-forest-node f V int-regs 4 4 V{ } }
|
||||
T{ dom-forest-node f V int-regs 5 5 V{ } }
|
||||
}
|
||||
}
|
||||
T{ dom-forest-node
|
||||
f
|
||||
V int-regs 6
|
||||
6
|
||||
V{ }
|
||||
}
|
||||
}
|
||||
]
|
||||
[
|
||||
{ V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
|
||||
test-dom-forest
|
||||
] unit-test
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel math math.order
|
||||
namespaces sequences sorting vectors compiler.cfg.def-use
|
||||
compiler.cfg.dominance compiler.cfg.registers ;
|
||||
IN: compiler.cfg.ssa.destruction.forest
|
||||
|
||||
TUPLE: dom-forest-node vreg bb children ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: sort-vregs-by-bb ( vregs -- alist )
|
||||
defs get
|
||||
'[ dup _ at ] { } map>assoc
|
||||
[ [ second pre-of ] compare ] sort ;
|
||||
|
||||
: <dom-forest-node> ( vreg bb parent -- node )
|
||||
[ V{ } clone dom-forest-node boa dup ] dip children>> push ;
|
||||
|
||||
: <virtual-root> ( -- node )
|
||||
f f V{ } clone dom-forest-node boa ;
|
||||
|
||||
: find-parent ( pre stack -- parent )
|
||||
2dup last vreg>> def-of maxpre-of > [
|
||||
dup pop* find-parent
|
||||
] [ nip last ] if ;
|
||||
|
||||
: (compute-dom-forest) ( vreg bb stack -- )
|
||||
[ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-dom-forest ( vregs -- forest )
|
||||
<virtual-root> [
|
||||
1vector
|
||||
[ sort-vregs-by-bb ] dip
|
||||
'[ _ (compute-dom-forest) ] assoc-each
|
||||
] keep children>> ;
|
||||
|
|
@ -1,138 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel locals math math.order arrays
|
||||
namespaces sequences sorting sets combinators combinators.short-circuit make
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.liveness.ssa
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.ssa.interference
|
||||
compiler.cfg.ssa.destruction.state
|
||||
compiler.cfg.ssa.destruction.forest ;
|
||||
IN: compiler.cfg.ssa.destruction.process-blocks
|
||||
|
||||
! phi-union maps a vreg to the predecessor block
|
||||
! that carries it to the phi node's block
|
||||
|
||||
! unioned-blocks is a set of bb's which defined
|
||||
! the source vregs above
|
||||
SYMBOLS: phi-union unioned-blocks ;
|
||||
|
||||
: operand-live-into-phi-node's-block? ( src dst -- ? )
|
||||
def-of live-in? ;
|
||||
|
||||
: phi-node-is-live-out-of-operand's-block? ( src dst -- ? )
|
||||
swap def-of live-out? ;
|
||||
|
||||
: operand-is-phi-node-and-live-into-operand's-block? ( src dst -- ? )
|
||||
drop { [ insn-of ##phi? ] [ dup def-of live-in? ] } 1&& ;
|
||||
|
||||
: operand-being-renamed? ( src dst -- ? )
|
||||
drop processed-names get key? ;
|
||||
|
||||
: two-operands-in-same-block? ( src dst -- ? )
|
||||
drop def-of unioned-blocks get key? ;
|
||||
|
||||
: trivial-interference? ( src dst -- ? )
|
||||
{
|
||||
[ operand-live-into-phi-node's-block? ]
|
||||
[ phi-node-is-live-out-of-operand's-block? ]
|
||||
[ operand-is-phi-node-and-live-into-operand's-block? ]
|
||||
[ operand-being-renamed? ]
|
||||
[ two-operands-in-same-block? ]
|
||||
} 2|| ;
|
||||
|
||||
: don't-coalesce ( bb src dst -- )
|
||||
2nip processed-name ;
|
||||
|
||||
:: trivial-interference ( bb src dst -- )
|
||||
dst src bb add-waiting
|
||||
src used-by-another get push ;
|
||||
|
||||
:: add-to-renaming-set ( bb src dst -- )
|
||||
bb src phi-union get set-at
|
||||
src def-of unioned-blocks get conjoin ;
|
||||
|
||||
: process-phi-operand ( bb src dst -- )
|
||||
{
|
||||
{ [ 2dup eq? ] [ don't-coalesce ] }
|
||||
{ [ 2dup trivial-interference? ] [ trivial-interference ] }
|
||||
[ add-to-renaming-set ]
|
||||
} cond ;
|
||||
|
||||
: node-is-live-in-of-child? ( node child -- ? )
|
||||
[ vreg>> ] [ bb>> ] bi* live-in? ;
|
||||
|
||||
: node-is-live-out-of-child? ( node child -- ? )
|
||||
[ vreg>> ] [ bb>> ] bi* live-out? ;
|
||||
|
||||
:: insert-copy ( bb src dst -- )
|
||||
bb src dst trivial-interference
|
||||
src phi-union get delete-at ;
|
||||
|
||||
:: insert-copy-for-parent ( bb src dst node -- )
|
||||
src node vreg>> eq? [ bb src dst insert-copy ] when ;
|
||||
|
||||
: insert-copies-for-parent ( ##phi node child -- )
|
||||
drop
|
||||
[ [ inputs>> ] [ dst>> ] bi ] dip
|
||||
'[ _ _ insert-copy-for-parent ] assoc-each ;
|
||||
|
||||
: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
|
||||
|
||||
: add-interference ( ##phi node child -- )
|
||||
[ vreg>> ] bi@ 2array , drop ;
|
||||
|
||||
: process-df-child ( ##phi node child -- )
|
||||
{
|
||||
{ [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
|
||||
{ [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
|
||||
{ [ 2dup defined-in-same-block? ] [ add-interference ] }
|
||||
[ 3drop ]
|
||||
} cond ;
|
||||
|
||||
: process-df-node ( ##phi node -- )
|
||||
dup children>>
|
||||
[ [ process-df-child ] with with each ]
|
||||
[ nip [ process-df-node ] with each ]
|
||||
3bi ;
|
||||
|
||||
: process-phi-union ( ##phi dom-forest -- )
|
||||
[ process-df-node ] with each ;
|
||||
|
||||
: add-local-interferences ( ##phi -- )
|
||||
[ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
|
||||
|
||||
: compute-local-interferences ( ##phi -- pairs )
|
||||
[
|
||||
[ phi-union get keys compute-dom-forest process-phi-union ]
|
||||
[ add-local-interferences ]
|
||||
bi
|
||||
] { } make ;
|
||||
|
||||
:: insert-copies-for-interference ( ##phi src -- )
|
||||
##phi inputs>> [| bb src' |
|
||||
src src' eq? [ bb src ##phi dst>> insert-copy ] when
|
||||
] assoc-each ;
|
||||
|
||||
: process-local-interferences ( ##phi pairs -- )
|
||||
[
|
||||
first2 2dup interferes?
|
||||
[ drop insert-copies-for-interference ] [ 3drop ] if
|
||||
] with each ;
|
||||
|
||||
: add-renaming-set ( ##phi -- )
|
||||
[ phi-union get ] dip dst>> renaming-sets get set-at
|
||||
phi-union get [ drop processed-name ] assoc-each ;
|
||||
|
||||
: process-phi ( ##phi -- )
|
||||
H{ } clone phi-union set
|
||||
H{ } clone unioned-blocks set
|
||||
[ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
|
||||
[ dup compute-local-interferences process-local-interferences ]
|
||||
[ add-renaming-set ]
|
||||
tri ;
|
||||
|
||||
: process-block ( bb -- )
|
||||
instructions>>
|
||||
[ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel namespaces sequences
|
||||
compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
|
||||
disjoint-sets ;
|
||||
IN: compiler.cfg.ssa.destruction.renaming
|
||||
|
||||
: build-disjoint-set ( assoc -- disjoint-set )
|
||||
<disjoint-set> dup [
|
||||
'[
|
||||
[ _ add-atom ]
|
||||
[ [ drop _ add-atom ] assoc-each ]
|
||||
bi*
|
||||
] assoc-each
|
||||
] keep ;
|
||||
|
||||
: update-congruence-class ( dst assoc disjoint-set -- )
|
||||
[ keys swap ] dip equate-all-with ;
|
||||
|
||||
: build-congruence-classes ( -- disjoint-set )
|
||||
renaming-sets get
|
||||
dup build-disjoint-set
|
||||
[ '[ _ update-congruence-class ] assoc-each ] keep ;
|
||||
|
||||
: compute-renaming ( disjoint-set -- assoc )
|
||||
[ parents>> ] keep
|
||||
'[ drop dup _ representative ] assoc-map ;
|
||||
|
||||
: rename-blocks ( cfg -- )
|
||||
[
|
||||
instructions>> [
|
||||
[ rename-insn-defs ]
|
||||
[ rename-insn-uses ] bi
|
||||
] each
|
||||
] each-basic-block ;
|
||||
|
||||
: rename-copies ( -- )
|
||||
waiting renamings get '[
|
||||
[
|
||||
[ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
|
||||
] assoc-map
|
||||
] change ;
|
||||
|
||||
: perform-renaming ( cfg -- )
|
||||
build-congruence-classes compute-renaming renamings set
|
||||
rename-blocks
|
||||
rename-copies ;
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sets kernel assocs ;
|
||||
IN: compiler.cfg.ssa.destruction.state
|
||||
|
||||
SYMBOLS: processed-names waiting used-by-another renaming-sets ;
|
||||
|
||||
: init-coalescing ( -- )
|
||||
H{ } clone renaming-sets set
|
||||
H{ } clone processed-names set
|
||||
H{ } clone waiting set
|
||||
V{ } clone used-by-another set ;
|
||||
|
||||
: processed-name ( vreg -- ) processed-names get conjoin ;
|
||||
|
||||
: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
|
||||
|
||||
: add-waiting ( dst src bb -- ) waiting-for push-at ;
|
||||
|
|
@ -11,7 +11,7 @@ IN: compiler.cfg.ssa.interference.tests
|
|||
cfg new 0 get >>entry
|
||||
compute-ssa-live-sets
|
||||
compute-predecessors
|
||||
dup compute-def-use
|
||||
dup compute-defs
|
||||
dup compute-dominance
|
||||
compute-live-ranges ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators combinators.short-circuit
|
||||
kernel math namespaces sequences locals compiler.cfg.def-use
|
||||
compiler.cfg.dominance compiler.cfg.ssa.interference.live-ranges ;
|
||||
USING: accessors assocs combinators combinators.short-circuit fry
|
||||
kernel math math.order sorting namespaces sequences locals
|
||||
compiler.cfg.def-use compiler.cfg.dominance
|
||||
compiler.cfg.ssa.interference.live-ranges ;
|
||||
IN: compiler.cfg.ssa.interference
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -45,3 +46,33 @@ PRIVATE>
|
|||
{ [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
|
||||
[ 2drop 2drop f ]
|
||||
} cond ;
|
||||
|
||||
! Debug this stuff later
|
||||
|
||||
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
|
||||
|
||||
: quadratic-test ( seq1 seq2 -- ? )
|
||||
'[ _ [ interferes? ] with any? ] any? ;
|
||||
|
||||
: sort-vregs-by-bb ( vregs -- alist )
|
||||
defs get
|
||||
'[ dup _ at ] { } map>assoc
|
||||
[ [ second pre-of ] compare ] sort ;
|
||||
|
||||
: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
|
||||
|
||||
: find-parent ( dom current -- parent )
|
||||
over empty? [ 2drop f ] [
|
||||
over last over dominates? [ drop last ] [
|
||||
[ pop* ] dip find-parent
|
||||
] if
|
||||
] if ;
|
||||
|
||||
:: linear-test ( seq1 seq2 -- ? )
|
||||
V{ } clone :> dom
|
||||
seq1 seq2 append sort-vregs-by-bb [| pair |
|
||||
pair first :> current
|
||||
dom current find-parent
|
||||
dup [ current interferes? ] when
|
||||
[ t ] [ current dom push f ] if
|
||||
] any? ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ combinators sets locals columns grouping
|
|||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
compiler.tree.combinators
|
||||
compiler.utilities ;
|
||||
IN: compiler.tree.propagation.copy
|
||||
|
||||
! Two values are copy-equivalent if they are always identical
|
||||
|
|
@ -15,18 +16,6 @@ IN: compiler.tree.propagation.copy
|
|||
! Mapping from values to their canonical leader
|
||||
SYMBOL: copies
|
||||
|
||||
:: compress-path ( source assoc -- destination )
|
||||
[let | destination [ source assoc at ] |
|
||||
source destination = [ source ] [
|
||||
[let | destination' [ destination assoc compress-path ] |
|
||||
destination' destination = [
|
||||
destination' source assoc set-at
|
||||
] unless
|
||||
destination'
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get compress-path ;
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get set-at ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private arrays vectors fry
|
||||
math math.order namespaces assocs ;
|
||||
math math.order namespaces assocs locals ;
|
||||
IN: compiler.utilities
|
||||
|
||||
: flattener ( seq quot -- seq vector quot' )
|
||||
|
|
@ -30,3 +30,15 @@ yield-hook [ [ ] ] initialize
|
|||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
:: compress-path ( source assoc -- destination )
|
||||
[let | destination [ source assoc at ] |
|
||||
source destination = [ source ] [
|
||||
[let | destination' [ destination assoc compress-path ] |
|
||||
destination' destination = [
|
||||
destination' source assoc set-at
|
||||
] unless
|
||||
destination'
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue