compiler.cfg.ssa.interference: implement linear-time interference test
Slava Pestov
parent
6b7260a4a7
commit
41d929a201
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry kernel namespaces
|
||||
USING: accessors arrays assocs fry locals kernel namespaces
|
||||
sequences sequences.deep
|
||||
sets vectors
|
||||
cpu.architecture
|
||||
|
|
@ -46,35 +46,39 @@ SYMBOL: class-element-map
|
|||
! Sequence of vreg pairs
|
||||
SYMBOL: copies
|
||||
|
||||
: value-of ( vreg -- value )
|
||||
insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ;
|
||||
|
||||
: init-coalescing ( -- )
|
||||
defs get keys
|
||||
[ [ dup ] H{ } map>assoc leader-map set ]
|
||||
[ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
|
||||
defs get
|
||||
[ [ drop dup ] assoc-map leader-map set ]
|
||||
[ [ [ dup dup value-of ] dip <vreg-info> 1array ] assoc-map class-element-map set ] bi
|
||||
V{ } clone copies set ;
|
||||
|
||||
: classes-interfere? ( vreg1 vreg2 -- ? )
|
||||
[ leader ] bi@ 2dup eq? [ 2drop f ] [
|
||||
[ class-elements flatten ] bi@ sets-interfere?
|
||||
] if ;
|
||||
|
||||
: update-leaders ( vreg1 vreg2 -- )
|
||||
: coalesce-leaders ( vreg1 vreg2 -- )
|
||||
! leader2 becomes the leader.
|
||||
swap leader-map get set-at ;
|
||||
|
||||
: merge-classes ( vreg1 vreg2 -- )
|
||||
[ [ class-elements ] bi@ push ]
|
||||
[ drop class-element-map get delete-at ] 2bi ;
|
||||
: coalesce-elements ( merged vreg1 vreg2 -- )
|
||||
! delete leader1's class, and set leader2's class to merged.
|
||||
class-element-map get [ delete-at ] [ set-at ] bi-curry bi* ;
|
||||
|
||||
: eliminate-copy ( vreg1 vreg2 -- )
|
||||
[ leader ] bi@
|
||||
2dup eq? [ 2drop ] [
|
||||
[ update-leaders ]
|
||||
[ merge-classes ]
|
||||
2bi
|
||||
] if ;
|
||||
: coalesce-vregs ( merged leader1 leader2 -- )
|
||||
[ coalesce-leaders ] [ coalesce-elements ] 2bi ;
|
||||
|
||||
:: maybe-eliminate-copy ( vreg1 vreg2 -- )
|
||||
! Eliminate a copy of possible.
|
||||
vreg1 leader :> vreg1
|
||||
vreg2 leader :> vreg2
|
||||
vreg1 vreg2 eq? [
|
||||
vreg1 class-elements vreg2 class-elements sets-interfere?
|
||||
[ drop ] [ vreg1 vreg2 coalesce-vregs ] if
|
||||
] unless ;
|
||||
|
||||
GENERIC: prepare-insn ( insn -- )
|
||||
|
||||
: try-to-coalesce ( dst src -- ) 2array copies get push ;
|
||||
: maybe-eliminate-copy-later ( dst src -- )
|
||||
2array copies get push ;
|
||||
|
||||
M: insn prepare-insn drop ;
|
||||
|
||||
|
|
@ -85,19 +89,19 @@ M: vreg-insn prepare-insn
|
|||
2dup empty? not and [
|
||||
first
|
||||
2dup [ rep-of reg-class-of ] bi@ eq?
|
||||
[ try-to-coalesce ] [ 2drop ] if
|
||||
[ maybe-eliminate-copy-later ] [ 2drop ] if
|
||||
] [ 2drop ] if
|
||||
] bi ;
|
||||
|
||||
M: ##copy prepare-insn
|
||||
[ dst>> ] [ src>> ] bi try-to-coalesce ;
|
||||
[ dst>> ] [ src>> ] bi maybe-eliminate-copy-later ;
|
||||
|
||||
M: ##tagged>integer prepare-insn
|
||||
[ dst>> ] [ src>> ] bi eliminate-copy ;
|
||||
[ dst>> ] [ src>> ] bi maybe-eliminate-copy ;
|
||||
|
||||
M: ##phi prepare-insn
|
||||
[ dst>> ] [ inputs>> values ] bi
|
||||
[ eliminate-copy ] with each ;
|
||||
[ maybe-eliminate-copy ] with each ;
|
||||
|
||||
: prepare-block ( bb -- )
|
||||
instructions>> [ prepare-insn ] each ;
|
||||
|
|
@ -107,10 +111,7 @@ M: ##phi prepare-insn
|
|||
[ prepare-block ] each-basic-block ;
|
||||
|
||||
: process-copies ( -- )
|
||||
copies get [
|
||||
2dup classes-interfere?
|
||||
[ 2drop ] [ eliminate-copy ] if
|
||||
] assoc-each ;
|
||||
copies get [ maybe-eliminate-copy ] assoc-each ;
|
||||
|
||||
GENERIC: useful-insn? ( insn -- ? )
|
||||
|
||||
|
|
@ -135,6 +136,7 @@ PRIVATE>
|
|||
|
||||
dup construct-cssa
|
||||
dup compute-defs
|
||||
dup compute-insns
|
||||
dup compute-ssa-live-sets
|
||||
dup compute-live-ranges
|
||||
dup prepare-coalescing
|
||||
|
|
|
|||
|
|
@ -2,17 +2,35 @@ USING: accessors compiler.cfg compiler.cfg.debugger
|
|||
compiler.cfg.def-use compiler.cfg.dominance
|
||||
compiler.cfg.instructions compiler.cfg.liveness.ssa
|
||||
compiler.cfg.registers compiler.cfg.predecessors
|
||||
compiler.cfg.ssa.interference
|
||||
compiler.cfg.ssa.interference.live-ranges cpu.architecture
|
||||
kernel namespaces tools.test ;
|
||||
compiler.cfg.comparisons compiler.cfg.ssa.interference
|
||||
compiler.cfg.ssa.interference.private
|
||||
compiler.cfg.ssa.interference.live-ranges
|
||||
cpu.architecture kernel namespaces tools.test alien.c-types
|
||||
arrays sequences slots ;
|
||||
IN: compiler.cfg.ssa.interference.tests
|
||||
|
||||
: test-interference ( -- )
|
||||
cfg new 0 get >>entry
|
||||
dup compute-ssa-live-sets
|
||||
dup compute-defs
|
||||
dup compute-insns
|
||||
compute-live-ranges ;
|
||||
|
||||
: <test-vreg-info> ( vreg -- info )
|
||||
[ ] [ insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ] [ def-of ] tri
|
||||
<vreg-info> ;
|
||||
|
||||
: test-vregs-intersect? ( vreg1 vreg2 -- ? )
|
||||
[ <test-vreg-info> ] bi@ vregs-intersect? ;
|
||||
|
||||
: test-vregs-interfere? ( vreg1 vreg2 -- ? )
|
||||
[ <test-vreg-info> ] bi@
|
||||
[ blue >>color ] [ red >>color ] bi*
|
||||
vregs-interfere? ;
|
||||
|
||||
: test-sets-interfere? ( seq1 seq2 -- merged ? )
|
||||
[ [ <test-vreg-info> ] map ] bi@ sets-interfere? ;
|
||||
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 2 D 0 }
|
||||
|
|
@ -34,17 +52,310 @@ V{
|
|||
|
||||
[ ] [ test-interference ] unit-test
|
||||
|
||||
[ f ] [ 0 1 vregs-interfere? ] unit-test
|
||||
[ f ] [ 1 0 vregs-interfere? ] unit-test
|
||||
[ f ] [ 2 3 vregs-interfere? ] unit-test
|
||||
[ f ] [ 3 2 vregs-interfere? ] unit-test
|
||||
[ t ] [ 0 2 vregs-interfere? ] unit-test
|
||||
[ t ] [ 2 0 vregs-interfere? ] unit-test
|
||||
[ f ] [ 1 3 vregs-interfere? ] unit-test
|
||||
[ f ] [ 3 1 vregs-interfere? ] unit-test
|
||||
[ t ] [ 3 4 vregs-interfere? ] unit-test
|
||||
[ t ] [ 4 3 vregs-interfere? ] unit-test
|
||||
[ t ] [ 3 5 vregs-interfere? ] unit-test
|
||||
[ t ] [ 5 3 vregs-interfere? ] unit-test
|
||||
[ f ] [ 3 6 vregs-interfere? ] unit-test
|
||||
[ f ] [ 6 3 vregs-interfere? ] unit-test
|
||||
[ f ] [ 0 1 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 1 0 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 2 3 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 3 2 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 0 2 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 2 0 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 1 3 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 3 1 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 3 4 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 4 3 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 3 5 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 5 3 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 3 6 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 6 3 test-vregs-intersect? ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -3 }
|
||||
T{ ##peek f 12 D -2 }
|
||||
T{ ##peek f 23 D -1 }
|
||||
T{ ##sar-imm f 13 23 4 }
|
||||
T{ ##peek f 24 D -3 }
|
||||
T{ ##sar-imm f 14 24 4 }
|
||||
T{ ##mul f 15 13 13 }
|
||||
T{ ##mul f 16 15 15 }
|
||||
T{ ##tagged>integer f 17 12 }
|
||||
T{ ##store-memory f 16 17 14 0 7 int-rep uchar }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 1 edge
|
||||
1 2 edge
|
||||
|
||||
[ ] [ test-interference ] unit-test
|
||||
|
||||
[ t ] [ { 15 } { 23 13 } test-sets-interfere? nip ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue f }
|
||||
T{ ##branch f }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 2 }
|
||||
T{ ##peek f 32 D 2 }
|
||||
T{ ##load-reference f 33 ##check-nursery-branch }
|
||||
T{ ##load-integer f 34 11 }
|
||||
T{ ##tagged>integer f 35 32 }
|
||||
T{ ##and-imm f 36 35 15 }
|
||||
T{ ##compare-integer-imm-branch f 36 7 cc= }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##slot-imm f 48 32 1 7 }
|
||||
T{ ##slot-imm f 50 48 1 2 }
|
||||
T{ ##sar-imm f 65 50 4 }
|
||||
T{ ##compare-integer-branch f 34 65 cc<= }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -2 }
|
||||
T{ ##slot-imm f 57 48 11 2 }
|
||||
T{ ##compare f 58 33 57 cc= 20 }
|
||||
T{ ##replace f 58 D 0 }
|
||||
T{ ##branch f }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue f }
|
||||
T{ ##return f }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -2 }
|
||||
T{ ##replace-imm f f D 0 }
|
||||
T{ ##branch f }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue f }
|
||||
T{ ##return f }
|
||||
} 6 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -2 }
|
||||
T{ ##replace-imm f f D 0 }
|
||||
T{ ##branch f }
|
||||
} 7 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue f }
|
||||
T{ ##return f }
|
||||
} 8 test-bb
|
||||
|
||||
0 1 edge
|
||||
1 { 2 7 } edges
|
||||
2 { 3 5 } edges
|
||||
3 4 edge
|
||||
5 6 edge
|
||||
7 8 edge
|
||||
|
||||
[ ] [ test-interference ] unit-test
|
||||
|
||||
[ f ] [ { 48 } { 32 35 } test-sets-interfere? nip ] unit-test
|
||||
|
||||
TUPLE: bab ;
|
||||
TUPLE: gfg { x bab } ;
|
||||
: bah ( -- x ) f ;
|
||||
|
||||
V{
|
||||
T{ ##prologue }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##check-nursery-branch f 16 cc<= 75 76 }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##save-context f 77 78 }
|
||||
T{ ##call-gc f { } }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##load-reference f 37 T{ bab } }
|
||||
T{ ##load-reference f 38 { gfg 1 1 tuple 57438726 gfg 7785907 } }
|
||||
T{ ##allot f 40 12 tuple 4 }
|
||||
T{ ##set-slot-imm f 38 40 1 7 }
|
||||
T{ ##set-slot-imm f 37 40 2 7 }
|
||||
T{ ##replace f 40 D 0 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f bah }
|
||||
T{ ##branch }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-r f 1 }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##peek f 43 D 1 }
|
||||
T{ ##peek f 44 D 2 }
|
||||
T{ ##tagged>integer f 45 43 }
|
||||
T{ ##and-imm f 46 45 15 }
|
||||
T{ ##compare-integer-imm-branch f 46 7 cc= }
|
||||
} 5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##slot-imm f 58 43 1 7 }
|
||||
T{ ##slot-imm f 60 58 7 2 }
|
||||
T{ ##compare-imm-branch f 60 bab cc= }
|
||||
} 6 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 7 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-r f -1 }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##set-slot-imm f 43 44 2 7 }
|
||||
T{ ##write-barrier-imm f 44 2 7 34 35 }
|
||||
T{ ##branch }
|
||||
} 8 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue }
|
||||
T{ ##return }
|
||||
} 9 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace f 44 R 0 }
|
||||
T{ ##replace-imm f bab D 0 }
|
||||
T{ ##branch }
|
||||
} 10 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f bad-slot-value }
|
||||
T{ ##branch }
|
||||
} 11 test-bb
|
||||
|
||||
V{
|
||||
T{ ##no-tco }
|
||||
} 12 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##branch }
|
||||
} 13 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace f 44 R 0 }
|
||||
T{ ##replace-imm f bab D 0 }
|
||||
T{ ##branch }
|
||||
} 14 test-bb
|
||||
|
||||
V{
|
||||
T{ ##call f bad-slot-value }
|
||||
T{ ##branch }
|
||||
} 15 test-bb
|
||||
|
||||
V{
|
||||
T{ ##no-tco }
|
||||
} 16 test-bb
|
||||
|
||||
0 1 edge
|
||||
1 { 3 2 } edges
|
||||
2 3 edge
|
||||
3 4 edge
|
||||
4 5 edge
|
||||
5 { 6 13 } edges
|
||||
6 { 7 10 } edges
|
||||
7 8 edge
|
||||
8 9 edge
|
||||
10 11 edge
|
||||
11 12 edge
|
||||
13 14 edge
|
||||
14 15 edge
|
||||
15 16 edge
|
||||
|
||||
[ ] [ test-interference ] unit-test
|
||||
|
||||
[ t ] [ 43 45 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 43 45 test-vregs-interfere? ] unit-test
|
||||
|
||||
[ t ] [ 43 46 test-vregs-intersect? ] unit-test
|
||||
[ t ] [ 43 46 test-vregs-interfere? ] unit-test
|
||||
|
||||
[ f ] [ 45 46 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 45 46 test-vregs-interfere? ] unit-test
|
||||
|
||||
[ f ] [ { 43 } { 45 } test-sets-interfere? nip ] unit-test
|
||||
|
||||
[ t f ] [
|
||||
{ 46 } { 43 } { 45 }
|
||||
[ [ <test-vreg-info> ] map ] tri@
|
||||
sets-interfere? [ sets-interfere? nip ] dip
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##prologue f }
|
||||
T{ ##branch f }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##peek f 31 D 1 }
|
||||
T{ ##sar-imm f 16 31 4 }
|
||||
T{ ##load-integer f 17 0 }
|
||||
T{ ##copy f 33 17 int-rep }
|
||||
T{ ##branch f }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f 21 H{ { 1 33 } { 3 32 } } }
|
||||
T{ ##compare-integer-branch f 21 16 cc< }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##add-imm f 27 21 1 }
|
||||
T{ ##copy f 32 27 int-rep }
|
||||
T{ ##branch f }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d f -2 }
|
||||
T{ ##branch f }
|
||||
} 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##epilogue f }
|
||||
T{ ##return f }
|
||||
} 5 test-bb
|
||||
|
||||
0 1 edge
|
||||
1 2 edge
|
||||
2 { 3 4 } edges
|
||||
3 2 edge
|
||||
4 5 edge
|
||||
|
||||
[ ] [ test-interference ] unit-test
|
||||
|
||||
[ f f ] [
|
||||
{ 33 } { 21 } { 32 }
|
||||
[ [ <test-vreg-info> ] map ] tri@
|
||||
sets-interfere? [ sets-interfere? nip ] dip
|
||||
] unit-test
|
||||
|
||||
[ f ] [ 33 21 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 32 21 test-vregs-intersect? ] unit-test
|
||||
[ f ] [ 32 33 test-vregs-intersect? ] unit-test
|
||||
|
|
@ -1,92 +1,175 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
USING: accessors arrays assocs combinators
|
||||
combinators.short-circuit fry kernel math math.order sorting
|
||||
sorting.slots namespaces sequences locals compiler.cfg.def-use
|
||||
compiler.cfg.dominance compiler.cfg.ssa.interference.live-ranges ;
|
||||
IN: compiler.cfg.ssa.interference
|
||||
|
||||
! Interference testing using SSA properties. Actually the only SSA property
|
||||
! used here is that definitions dominate uses; because of this, the input
|
||||
! is allowed to have multiple definitions of each vreg as long as they're
|
||||
! all in the same basic block. This is needed because two-operand conversion
|
||||
! runs before coalescing, which uses SSA interference testing.
|
||||
! Interference testing using SSA properties.
|
||||
!
|
||||
! Based on:
|
||||
!
|
||||
! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
|
||||
! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf
|
||||
|
||||
TUPLE: vreg-info vreg value def-index bb pre-of color equal-anc-in equal-anc-out ;
|
||||
|
||||
:: <vreg-info> ( vreg value bb -- info )
|
||||
vreg-info new
|
||||
vreg >>vreg
|
||||
bb >>bb
|
||||
value >>value
|
||||
bb pre-of >>pre-of
|
||||
vreg bb def-index >>def-index ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: kill-after-def? ( vreg1 vreg2 bb -- ? )
|
||||
! Our dominance pass computes dominance information on a
|
||||
! per-basic block level. Rig up a more fine-grained dominance
|
||||
! test here.
|
||||
: locally-dominates? ( vreg1 vreg2 -- ? )
|
||||
[ def-index>> ] bi@ < ;
|
||||
|
||||
:: vreg-dominates? ( vreg1 vreg2 -- ? )
|
||||
vreg1 bb>> :> bb1
|
||||
vreg2 bb>> :> bb2
|
||||
bb1 bb2 eq?
|
||||
[ vreg1 vreg2 locally-dominates? ] [ bb1 bb2 dominates? ] if ;
|
||||
|
||||
! Testing individual vregs for live range intersection.
|
||||
: kill-after-def? ( vreg1 vreg2 bb -- ? )
|
||||
! If first register is used after second one is defined, they interfere.
|
||||
! If they are used in the same instruction, no interference. If the
|
||||
! instruction is a def-is-use-insn, then there will be a use at +1
|
||||
! (instructions are 2 apart) and so outputs will interfere with
|
||||
! inputs.
|
||||
vreg1 bb kill-index
|
||||
vreg2 bb def-index > ;
|
||||
[ kill-index ] [ def-index ] bi-curry bi* > ;
|
||||
|
||||
:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
|
||||
! If both are defined in the same basic block, they interfere if their
|
||||
! local live ranges intersect.
|
||||
vreg1 bb1 def-index
|
||||
vreg2 bb1 def-index <
|
||||
[ vreg1 vreg2 ] [ vreg2 vreg1 ] if
|
||||
bb1 kill-after-def? ;
|
||||
|
||||
: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
|
||||
: interferes-first-dominates? ( vreg1 vreg2 -- ? )
|
||||
! If vreg1 dominates vreg2, then they interfere if vreg2's definition
|
||||
! occurs before vreg1 is killed.
|
||||
nip
|
||||
kill-after-def? ;
|
||||
[ [ vreg>> ] bi@ ] [ nip bb>> ] 2bi kill-after-def? ;
|
||||
|
||||
: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
|
||||
: interferes-second-dominates? ( vreg1 vreg2 -- ? )
|
||||
! If vreg2 dominates vreg1, then they interfere if vreg1's definition
|
||||
! occurs before vreg2 is killed.
|
||||
drop
|
||||
swapd kill-after-def? ;
|
||||
swap interferes-first-dominates? ;
|
||||
|
||||
PRIVATE>
|
||||
: interferes-same-block? ( vreg1 vreg2 -- ? )
|
||||
! If both are defined in the same basic block, they interfere if their
|
||||
! local live ranges intersect.
|
||||
2dup locally-dominates? [ swap ] unless
|
||||
interferes-first-dominates? ;
|
||||
|
||||
: vregs-interfere? ( vreg1 vreg2 -- ? )
|
||||
2dup [ def-of ] bi@ {
|
||||
{ [ 2dup eq? ] [ interferes-same-block? ] }
|
||||
{ [ 2dup dominates? ] [ interferes-first-dominates? ] }
|
||||
{ [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
|
||||
[ 2drop 2drop f ]
|
||||
:: vregs-intersect? ( vreg1 vreg2 -- ? )
|
||||
vreg1 bb>> :> bb1
|
||||
vreg2 bb>> :> bb2
|
||||
{
|
||||
{ [ bb1 bb2 eq? ] [ vreg1 vreg2 interferes-same-block? ] }
|
||||
{ [ bb1 bb2 dominates? ] [ vreg1 vreg2 interferes-first-dominates? ] }
|
||||
{ [ bb2 bb1 dominates? ] [ vreg1 vreg2 interferes-second-dominates? ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
|
||||
<PRIVATE
|
||||
! Value-based interference test.
|
||||
: chain-intersect ( vreg1 vreg2 -- vreg )
|
||||
[ 2dup { [ nip ] [ vregs-intersect? not ] } 2&& ]
|
||||
[ equal-anc-in>> ]
|
||||
while nip ;
|
||||
|
||||
! Debug this stuff later
|
||||
: update-equal-anc-out ( vreg1 vreg2 -- )
|
||||
dupd chain-intersect >>equal-anc-out drop ;
|
||||
|
||||
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
|
||||
: same-sets? ( vreg1 vreg2 -- ? )
|
||||
[ color>> ] bi@ eq? ;
|
||||
|
||||
: quadratic-test ( seq1 seq2 -- ? )
|
||||
'[ _ [ vregs-interfere? ] with any? ] any? ;
|
||||
: same-values? ( vreg1 vreg2 -- ? )
|
||||
[ value>> ] bi@ eq? ;
|
||||
|
||||
: sort-vregs-by-bb ( vregs -- alist )
|
||||
defs get
|
||||
'[ dup _ at ] { } map>assoc
|
||||
[ second pre-of ] sort-with ;
|
||||
: vregs-interfere? ( vreg1 vreg2 -- ? )
|
||||
[ f >>equal-anc-out ] dip
|
||||
|
||||
: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
|
||||
2dup same-sets? [ equal-anc-out>> ] when
|
||||
|
||||
: find-parent ( dom current -- parent )
|
||||
2dup same-values?
|
||||
[ update-equal-anc-out f ] [ chain-intersect >boolean ] if ;
|
||||
|
||||
! Merging lists of vregs sorted by dominance.
|
||||
M: vreg-info <=> ( vreg1 vreg2 -- <=> )
|
||||
{ { pre-of>> <=> } { def-index>> <=> } } compare-slots ;
|
||||
|
||||
SYMBOLS: blue red ;
|
||||
|
||||
TUPLE: iterator seq n ;
|
||||
: <iterator> ( seq -- iterator ) 0 iterator boa ; inline
|
||||
: done? ( iterator -- ? ) [ seq>> length ] [ n>> ] bi = ; inline
|
||||
: this ( iterator -- obj ) [ n>> ] [ seq>> ] bi nth ; inline
|
||||
: ++ ( iterator -- ) [ 1 + ] change-n drop ; inline
|
||||
: take ( iterator -- obj ) [ this ] [ ++ ] bi ; inline
|
||||
|
||||
: blue-smaller? ( blue red -- ? )
|
||||
[ this ] bi@ before? ; inline
|
||||
|
||||
: take-blue? ( blue red -- ? )
|
||||
{
|
||||
[ nip done? ]
|
||||
[
|
||||
{
|
||||
[ drop done? not ]
|
||||
[ blue-smaller? ]
|
||||
} 2&&
|
||||
]
|
||||
} 2|| ; inline
|
||||
|
||||
: merge-sets ( blue red -- seq )
|
||||
[ <iterator> ] bi@
|
||||
[ 2dup [ done? ] both? not ]
|
||||
[
|
||||
2dup take-blue?
|
||||
[ over take blue >>color ]
|
||||
[ dup take red >>color ]
|
||||
if
|
||||
] produce 2nip ;
|
||||
|
||||
: update-for-merge ( seq -- )
|
||||
[
|
||||
dup [ equal-anc-in>> ] [ equal-anc-out>> ] bi
|
||||
2dup and [ [ vreg-dominates? ] most ] [ or ] if
|
||||
>>equal-anc-in
|
||||
drop
|
||||
] each ;
|
||||
|
||||
! Linear-time live range intersection test in a merged set.
|
||||
: find-parent ( dom current -- vreg )
|
||||
over empty? [ 2drop f ] [
|
||||
over last over dominates? [ drop last ] [
|
||||
over pop* find-parent
|
||||
] if
|
||||
over last over vreg-dominates?
|
||||
[ drop last ] [ over pop* find-parent ] if
|
||||
] if ;
|
||||
|
||||
:: linear-test ( seq1 seq2 -- ? )
|
||||
! Instead of sorting, SSA destruction should keep equivalence
|
||||
! classes sorted by merging them on append
|
||||
:: linear-interference-test ( seq -- ? )
|
||||
V{ } clone :> dom
|
||||
seq1 seq2 append sort-vregs-by-bb [| pair |
|
||||
pair first :> current
|
||||
dom current find-parent
|
||||
dup [ current vregs-interfere? ] when
|
||||
[ t ] [ current dom push f ] if
|
||||
seq [| vreg |
|
||||
dom vreg find-parent
|
||||
{ [ ] [ vreg same-sets? not ] [ vreg swap vregs-interfere? ] } 1&&
|
||||
[ t ] [ vreg dom push f ] if
|
||||
] any? ;
|
||||
|
||||
: sets-interfere-1? ( seq1 seq2 -- merged/f ? )
|
||||
[ first ] bi@
|
||||
2dup before? [ swap ] unless
|
||||
2dup same-values? [
|
||||
2dup equal-anc-in<<
|
||||
2array f
|
||||
] [
|
||||
2dup vregs-intersect?
|
||||
[ 2drop f t ] [ 2array f ] if
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: sets-interfere? ( seq1 seq2 -- ? )
|
||||
quadratic-test ;
|
||||
: sets-interfere? ( seq1 seq2 -- merged/f ? )
|
||||
2dup [ length 1 = ] both? [ sets-interfere-1? ] [
|
||||
merge-sets dup linear-interference-test
|
||||
[ drop f t ] [ dup update-for-merge f ] if
|
||||
] if ;
|
||||
Loading…
Reference in New Issue