Merge branch 'master' of git://factorcode.org/git/factor
commit
d4dca29eda
|
@ -65,7 +65,7 @@ SYMBOL: temp
|
||||||
|
|
||||||
: perform-mappings ( bb to mappings -- )
|
: perform-mappings ( bb to mappings -- )
|
||||||
dup empty? [ 3drop ] [
|
dup empty? [ 3drop ] [
|
||||||
mapping-instructions <simple-block> insert-basic-block
|
mapping-instructions insert-simple-basic-block
|
||||||
cfg get cfg-changed drop
|
cfg get cfg-changed drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
|
||||||
|
|
||||||
TUPLE: natural-loop header index ends blocks ;
|
TUPLE: natural-loop header index ends blocks ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
SYMBOL: loops
|
SYMBOL: loops
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: <natural-loop> ( header index -- loop )
|
: <natural-loop> ( header index -- loop )
|
||||||
H{ } clone H{ } clone natural-loop boa ;
|
H{ } clone H{ } clone natural-loop boa ;
|
||||||
|
|
||||||
|
@ -80,4 +80,4 @@ PRIVATE>
|
||||||
|
|
||||||
: needs-loops ( cfg -- cfg' )
|
: needs-loops ( cfg -- cfg' )
|
||||||
needs-predecessors
|
needs-predecessors
|
||||||
dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
|
dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
|
||||||
|
|
|
@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
|
||||||
! computing anything.
|
! computing anything.
|
||||||
2dup [ kill-block? ] both? [ 2drop ] [
|
2dup [ kill-block? ] both? [ 2drop ] [
|
||||||
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
|
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
|
||||||
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty
|
[ 2drop ] [ insert-simple-basic-block ] if-empty
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: visit-block ( bb -- )
|
: visit-block ( bb -- )
|
||||||
|
@ -56,4 +56,4 @@ ERROR: bad-peek dst loc ;
|
||||||
|
|
||||||
dup [ visit-block ] each-basic-block
|
dup [ visit-block ] each-basic-block
|
||||||
|
|
||||||
cfg-changed ;
|
cfg-changed ;
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors assocs combinators combinators.short-circuit
|
USING: accessors assocs combinators combinators.short-circuit
|
||||||
cpu.architecture kernel layouts locals make math namespaces sequences
|
cpu.architecture kernel layouts locals make math namespaces sequences
|
||||||
sets vectors fry compiler.cfg compiler.cfg.instructions
|
sets vectors fry compiler.cfg compiler.cfg.instructions
|
||||||
compiler.cfg.rpo ;
|
compiler.cfg.rpo arrays ;
|
||||||
IN: compiler.cfg.utilities
|
IN: compiler.cfg.utilities
|
||||||
|
|
||||||
PREDICATE: kill-block < basic-block
|
PREDICATE: kill-block < basic-block
|
||||||
|
@ -37,16 +37,16 @@ SYMBOL: visited
|
||||||
: skip-empty-blocks ( bb -- bb' )
|
: skip-empty-blocks ( bb -- bb' )
|
||||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||||
|
|
||||||
:: insert-basic-block ( from to bb -- )
|
:: insert-basic-block ( froms to bb -- )
|
||||||
bb from 1vector >>predecessors drop
|
bb froms V{ } like >>predecessors drop
|
||||||
bb to 1vector >>successors drop
|
bb to 1vector >>successors drop
|
||||||
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
|
to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
|
||||||
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
|
froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
|
||||||
|
|
||||||
: add-instructions ( bb quot -- )
|
: add-instructions ( bb quot -- )
|
||||||
[ instructions>> building ] dip '[
|
[ instructions>> building ] dip '[
|
||||||
building get pop
|
building get pop
|
||||||
@
|
[ @ ] dip
|
||||||
,
|
,
|
||||||
] with-variable ; inline
|
] with-variable ; inline
|
||||||
|
|
||||||
|
@ -56,6 +56,9 @@ SYMBOL: visited
|
||||||
\ ##branch new-insn over push
|
\ ##branch new-insn over push
|
||||||
>>instructions ;
|
>>instructions ;
|
||||||
|
|
||||||
|
: insert-simple-basic-block ( from to insns -- )
|
||||||
|
[ 1vector ] 2dip <simple-block> insert-basic-block ;
|
||||||
|
|
||||||
: has-phis? ( bb -- ? )
|
: has-phis? ( bb -- ? )
|
||||||
instructions>> first ##phi? ;
|
instructions>> first ##phi? ;
|
||||||
|
|
||||||
|
|
|
@ -1,9 +1,16 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: compiler.cfg.write-barrier compiler.cfg.instructions
|
USING: accessors arrays assocs compiler.cfg
|
||||||
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
|
compiler.cfg.alias-analysis compiler.cfg.block-joining
|
||||||
arrays tools.test vectors compiler.cfg kernel accessors
|
compiler.cfg.branch-splitting compiler.cfg.copy-prop
|
||||||
compiler.cfg.utilities namespaces sequences ;
|
compiler.cfg.dce compiler.cfg.debugger
|
||||||
|
compiler.cfg.instructions compiler.cfg.loop-detection
|
||||||
|
compiler.cfg.registers compiler.cfg.ssa.construction
|
||||||
|
compiler.cfg.tco compiler.cfg.useless-conditionals
|
||||||
|
compiler.cfg.utilities compiler.cfg.value-numbering
|
||||||
|
compiler.cfg.write-barrier cpu.architecture kernel
|
||||||
|
kernel.private math namespaces sequences sequences.private
|
||||||
|
tools.test vectors ;
|
||||||
IN: compiler.cfg.write-barrier.tests
|
IN: compiler.cfg.write-barrier.tests
|
||||||
|
|
||||||
: test-write-barrier ( insns -- insns )
|
: test-write-barrier ( insns -- insns )
|
||||||
|
@ -93,6 +100,24 @@ cfg new 1 get >>entry 0 set
|
||||||
T{ ##set-slot-imm f 2 1 3 4 }
|
T{ ##set-slot-imm f 2 1 3 4 }
|
||||||
} ] [ 2 get instructions>> ] unit-test
|
} ] [ 2 get instructions>> ] unit-test
|
||||||
|
|
||||||
|
V{
|
||||||
|
T{ ##allot f 1 }
|
||||||
|
} 1 test-bb
|
||||||
|
V{
|
||||||
|
T{ ##set-slot-imm f 2 1 3 4 }
|
||||||
|
T{ ##write-barrier f 1 2 3 }
|
||||||
|
} 2 test-bb
|
||||||
|
1 get 2 get 1vector >>successors drop
|
||||||
|
cfg new 1 get >>entry 0 set
|
||||||
|
|
||||||
|
[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
|
||||||
|
[ V{
|
||||||
|
T{ ##allot f 1 }
|
||||||
|
} ] [ 1 get instructions>> ] unit-test
|
||||||
|
[ V{
|
||||||
|
T{ ##set-slot-imm f 2 1 3 4 }
|
||||||
|
} ] [ 2 get instructions>> ] unit-test
|
||||||
|
|
||||||
V{
|
V{
|
||||||
T{ ##set-slot-imm f 2 1 3 4 }
|
T{ ##set-slot-imm f 2 1 3 4 }
|
||||||
T{ ##write-barrier f 1 2 3 }
|
T{ ##write-barrier f 1 2 3 }
|
||||||
|
@ -140,3 +165,26 @@ cfg new 1 get >>entry 0 set
|
||||||
T{ ##set-slot-imm f 2 1 3 4 }
|
T{ ##set-slot-imm f 2 1 3 4 }
|
||||||
T{ ##write-barrier f 1 2 3 }
|
T{ ##write-barrier f 1 2 3 }
|
||||||
} ] [ 3 get instructions>> ] unit-test
|
} ] [ 3 get instructions>> ] unit-test
|
||||||
|
|
||||||
|
: reverse-here' ( seq -- )
|
||||||
|
{ array } declare
|
||||||
|
[ length 2/ iota ] [ length ] [ ] tri
|
||||||
|
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
|
||||||
|
|
||||||
|
: write-barrier-stats ( word -- cfg )
|
||||||
|
test-cfg first [
|
||||||
|
optimize-tail-calls
|
||||||
|
delete-useless-conditionals
|
||||||
|
split-branches
|
||||||
|
join-blocks
|
||||||
|
construct-ssa
|
||||||
|
alias-analysis
|
||||||
|
value-numbering
|
||||||
|
copy-propagation
|
||||||
|
eliminate-dead-code
|
||||||
|
eliminate-write-barriers
|
||||||
|
] with-cfg
|
||||||
|
post-order>> write-barriers
|
||||||
|
[ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
|
||||||
|
|
||||||
|
[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test
|
||||||
|
|
|
@ -1,8 +1,16 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors namespaces assocs sets sequences
|
USING: kernel accessors namespaces assocs sets sequences
|
||||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
fry combinators.short-circuit locals make arrays
|
||||||
compiler.cfg.dataflow-analysis fry combinators.short-circuit ;
|
compiler.cfg
|
||||||
|
compiler.cfg.dominance
|
||||||
|
compiler.cfg.predecessors
|
||||||
|
compiler.cfg.loop-detection
|
||||||
|
compiler.cfg.rpo
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.registers
|
||||||
|
compiler.cfg.dataflow-analysis
|
||||||
|
compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.write-barrier
|
IN: compiler.cfg.write-barrier
|
||||||
|
|
||||||
! Eliminate redundant write barrier hits.
|
! Eliminate redundant write barrier hits.
|
||||||
|
@ -20,38 +28,112 @@ M: ##allot eliminate-write-barrier
|
||||||
dst>> safe get conjoin t ;
|
dst>> safe get conjoin t ;
|
||||||
|
|
||||||
M: ##write-barrier eliminate-write-barrier
|
M: ##write-barrier eliminate-write-barrier
|
||||||
src>> dup [ safe get key? not ] [ mutated get key? ] bi and
|
src>> dup safe get key? not
|
||||||
[ safe get conjoin t ] [ drop f ] if ;
|
[ safe get conjoin t ] [ drop f ] if ;
|
||||||
|
|
||||||
M: ##set-slot eliminate-write-barrier
|
|
||||||
obj>> mutated get conjoin t ;
|
|
||||||
|
|
||||||
M: ##set-slot-imm eliminate-write-barrier
|
|
||||||
obj>> mutated get conjoin t ;
|
|
||||||
|
|
||||||
M: insn eliminate-write-barrier drop t ;
|
M: insn eliminate-write-barrier drop t ;
|
||||||
|
|
||||||
|
! This doesn't actually benefit from being a dataflow analysis
|
||||||
|
! might as well be dominator-based
|
||||||
|
! Dealing with phi functions would help, though
|
||||||
FORWARD-ANALYSIS: safe
|
FORWARD-ANALYSIS: safe
|
||||||
|
|
||||||
: has-allocation? ( bb -- ? )
|
: has-allocation? ( bb -- ? )
|
||||||
instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
|
instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
|
||||||
|
|
||||||
M: safe-analysis transfer-set
|
M: safe-analysis transfer-set
|
||||||
drop [ H{ } assoc-clone-like ] dip
|
drop [ H{ } assoc-clone-like safe set ] dip
|
||||||
instructions>> over '[
|
instructions>> [
|
||||||
dup ##write-barrier? [
|
eliminate-write-barrier drop
|
||||||
src>> _ conjoin
|
] each safe get ;
|
||||||
] [ drop ] if
|
|
||||||
] each ;
|
|
||||||
|
|
||||||
M: safe-analysis join-sets
|
M: safe-analysis join-sets
|
||||||
drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
|
drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
|
||||||
|
|
||||||
: write-barriers-step ( bb -- )
|
: write-barriers-step ( bb -- )
|
||||||
dup safe-in H{ } assoc-clone-like safe set
|
dup safe-in H{ } assoc-clone-like safe set
|
||||||
H{ } clone mutated set
|
|
||||||
instructions>> [ eliminate-write-barrier ] filter-here ;
|
instructions>> [ eliminate-write-barrier ] filter-here ;
|
||||||
|
|
||||||
|
GENERIC: remove-dead-barrier ( insn -- ? )
|
||||||
|
|
||||||
|
M: ##write-barrier remove-dead-barrier
|
||||||
|
src>> mutated get key? ;
|
||||||
|
|
||||||
|
M: ##set-slot remove-dead-barrier
|
||||||
|
obj>> mutated get conjoin t ;
|
||||||
|
|
||||||
|
M: ##set-slot-imm remove-dead-barrier
|
||||||
|
obj>> mutated get conjoin t ;
|
||||||
|
|
||||||
|
M: insn remove-dead-barrier drop t ;
|
||||||
|
|
||||||
|
: remove-dead-barriers ( bb -- )
|
||||||
|
H{ } clone mutated set
|
||||||
|
instructions>> [ remove-dead-barrier ] filter-here ;
|
||||||
|
|
||||||
|
! Availability of slot
|
||||||
|
! Anticipation of this and set-slot would help too, maybe later
|
||||||
|
FORWARD-ANALYSIS: slot
|
||||||
|
|
||||||
|
UNION: access ##read ##write ;
|
||||||
|
|
||||||
|
M: slot-analysis transfer-set
|
||||||
|
drop [ H{ } assoc-clone-like ] dip
|
||||||
|
instructions>> over '[
|
||||||
|
dup access? [
|
||||||
|
obj>> _ conjoin
|
||||||
|
] [ drop ] if
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: slot-available? ( vreg bb -- ? )
|
||||||
|
slot-in key? ;
|
||||||
|
|
||||||
|
: make-barriers ( vregs -- bb )
|
||||||
|
[ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
|
||||||
|
|
||||||
|
: emit-barriers ( vregs loop -- )
|
||||||
|
swap [
|
||||||
|
[ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
|
||||||
|
[ header>> ] bi
|
||||||
|
] [ make-barriers ] bi*
|
||||||
|
insert-basic-block ;
|
||||||
|
|
||||||
|
: write-barriers ( bbs -- bb=>barriers )
|
||||||
|
[
|
||||||
|
dup instructions>>
|
||||||
|
[ ##write-barrier? ] filter
|
||||||
|
[ src>> ] map
|
||||||
|
] { } map>assoc
|
||||||
|
[ nip empty? not ] assoc-filter ;
|
||||||
|
|
||||||
|
: filter-dominant ( bb=>barriers bbs -- barriers )
|
||||||
|
'[ drop _ [ dominates? ] with all? ] assoc-filter
|
||||||
|
values concat prune ;
|
||||||
|
|
||||||
|
: dominant-write-barriers ( loop -- vregs )
|
||||||
|
[ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
|
||||||
|
|
||||||
|
: safe-loops ( -- loops )
|
||||||
|
loops get values
|
||||||
|
[ blocks>> keys [ has-allocation? not ] all? ] filter ;
|
||||||
|
|
||||||
|
:: insert-extra-barriers ( cfg -- )
|
||||||
|
safe-loops [| loop |
|
||||||
|
cfg needs-dominance needs-predecessors drop
|
||||||
|
loop dominant-write-barriers
|
||||||
|
loop header>> '[ _ slot-available? ] filter
|
||||||
|
[ loop emit-barriers cfg cfg-changed drop ] unless-empty
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: contains-write-barrier? ( cfg -- ? )
|
||||||
|
post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
|
||||||
|
|
||||||
: eliminate-write-barriers ( cfg -- cfg' )
|
: eliminate-write-barriers ( cfg -- cfg' )
|
||||||
dup compute-safe-sets
|
dup contains-write-barrier? [
|
||||||
dup [ write-barriers-step ] each-basic-block ;
|
needs-loops
|
||||||
|
dup [ remove-dead-barriers ] each-basic-block
|
||||||
|
dup compute-slot-sets
|
||||||
|
dup insert-extra-barriers
|
||||||
|
dup compute-safe-sets
|
||||||
|
dup [ write-barriers-step ] each-basic-block
|
||||||
|
] when ;
|
||||||
|
|
Loading…
Reference in New Issue