Write barriers are hoisted out of loops when their target is slot-available

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
 
 TUPLE: natural-loop header index ends blocks ;
 
-<PRIVATE
-
 SYMBOL: loops
 
+<PRIVATE
+
 : <natural-loop> ( header index -- loop )
     H{ } clone H{ } clone natural-loop boa ;
 
@@ -80,4 +80,4 @@ PRIVATE>
 
 : needs-loops ( cfg -- cfg' )
     needs-predecessors
-    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
+    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;

basis/compiler/cfg/utilities/utilities.factor

@@ -46,7 +46,7 @@ SYMBOL: visited
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
         building get pop
-        @
+        [ @ ] dip
         ,
     ] with-variable ; inline
 

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,9 +1,16 @@
 ! 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 )
@@ -158,3 +165,26 @@ cfg new 1 get >>entry 0 set
     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

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -1,8 +1,16 @@
 ! 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
+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.
@@ -20,41 +28,101 @@ M: ##allot eliminate-write-barrier
     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? ;
 
-GENERIC: safe-slot ( insn -- slot ? )
-M: object safe-slot drop f f ;
-M: ##write-barrier safe-slot src>> t ;
-M: ##allot safe-slot dst>> t ;
-
 M: safe-analysis transfer-set
-    drop [ H{ } assoc-clone-like ] dip
-    instructions>> over '[
-        safe-slot [ _ 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
+
+M: slot-analysis transfer-set
+    drop [ H{ } assoc-clone-like ] dip
+    instructions>> over '[
+        dup ##read? [
+            obj>> _ conjoin
+        ] [ drop ] if
+    ] each ;
+
+: slot-available? ( vreg bb -- ? )
+    slot-in key? ;
+
+: make-barriers ( vregs bb -- )
+    [ [ next-vreg next-vreg ##write-barrier ] each ] add-instructions ;
+
+: emit-barriers ( vregs bb -- )
+    predecessors>> [ make-barriers ] with each ;
+
+: 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 ;
+
+: insert-extra-barriers ( -- )
+    loops get values [| loop |
+        loop dominant-write-barriers
+        loop header>> '[ _ slot-available? ] filter
+        [ loop header>> emit-barriers ] 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 needs-dominance needs-predecessors
+        dup [ remove-dead-barriers ] each-basic-block
+        dup compute-slot-sets
+        insert-extra-barriers
+        dup compute-safe-sets
+        dup [ write-barriers-step ] each-basic-block
+    ] when ;