From 41d929a201ef07c8144acf351ce1c0c7938cfa72 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 17 May 2010 05:49:41 -0400
Subject: [PATCH] compiler.cfg.ssa.interference: implement linear-time
interference test
---
.../cfg/ssa/destruction/destruction.factor | 60 +--
.../interference/interference-tests.factor | 345 +++++++++++++++++-
.../cfg/ssa/interference/interference.factor | 199 +++++++---
3 files changed, 500 insertions(+), 104 deletions(-)
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index b4cca42ad6..1bb19bd8b0 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -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
diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor
index c48ae4ad58..4e3da1c6dc 100644
--- a/basis/compiler/cfg/ssa/interference/interference-tests.factor
+++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor
@@ -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
\ No newline at end of file
+[ 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
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/interference/interference.factor b/basis/compiler/cfg/ssa/interference/interference.factor
index a76b55cd83..0beb9ef010 100644
--- a/basis/compiler/cfg/ssa/interference/interference.factor
+++ b/basis/compiler/cfg/ssa/interference/interference.factor
@@ -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 ;
\ No newline at end of file
+: 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 ;
\ No newline at end of file