USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo ;
+compiler.cfg.rpo arrays ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( from to bb -- )
- bb from 1vector >>predecessors drop
+:: insert-basic-block ( froms to bb -- )
+ bb froms V{ } like >>predecessors drop
bb to 1vector >>successors drop
- to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
- from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+ to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
+ froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
- @
+ [ @ ] dip
,
] with-variable ; inline
\ ##branch new-insn over push
>>instructions ;
+: insert-simple-basic-block ( from to insns -- )
+ [ 1vector ] 2dip <simple-block> insert-basic-block ;
+
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.write-barrier compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors
-compiler.cfg.utilities namespaces sequences ;
+USING: accessors arrays assocs compiler.cfg
+compiler.cfg.alias-analysis compiler.cfg.block-joining
+compiler.cfg.branch-splitting compiler.cfg.copy-prop
+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
: test-write-barrier ( insns -- insns )
T{ ##set-slot-imm f 2 1 3 4 }
} ] [ 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{
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
T{ ##set-slot-imm f 2 1 3 4 }
T{ ##write-barrier f 1 2 3 }
} ] [ 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
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.dataflow-analysis fry combinators.short-circuit ;
+fry combinators.short-circuit locals make arrays
+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
! Eliminate redundant write barrier hits.
dst>> safe get conjoin t ;
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 ;
-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 ;
+! 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
: has-allocation? ( bb -- ? )
instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
M: safe-analysis transfer-set
- drop [ H{ } assoc-clone-like ] dip
- instructions>> over '[
- dup ##write-barrier? [
- src>> _ conjoin
- ] [ drop ] if
- ] each ;
+ drop [ H{ } assoc-clone-like safe set ] dip
+ instructions>> [
+ eliminate-write-barrier drop
+ ] each safe get ;
M: safe-analysis join-sets
drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
: write-barriers-step ( bb -- )
dup safe-in H{ } assoc-clone-like safe set
- H{ } clone mutated set
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' )
- dup compute-safe-sets
- dup [ write-barriers-step ] each-basic-block ;
+ dup contains-write-barrier? [
+ 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 ;
projects / factor.git / commitdiff