Improving write barrier elimination; change to compiler.cfg.utilities to support this

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -65,7 +65,7 @@ SYMBOL: temp
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions <simple-block> insert-basic-block
+        mapping-instructions insert-simple-basic-block
         cfg get cfg-changed drop
     ] if ;
 

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
         2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
-        [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+        [ 2drop ] [ insert-simple-basic-block ] if-empty
     ] if ;
 
 : visit-block ( bb -- )

basis/compiler/cfg/utilities/utilities.factor

@@ -3,7 +3,7 @@
 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
@@ -37,11 +37,11 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     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
-    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 -- )
     [ instructions>> building ] dip '[
@@ -56,6 +56,9 @@ SYMBOL: visited
     \ ##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? ;
 

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces assocs sets sequences
-fry combinators.short-circuit locals
+fry combinators.short-circuit locals make arrays
 compiler.cfg
 compiler.cfg.dominance
 compiler.cfg.predecessors
@@ -75,10 +75,12 @@ M: insn remove-dead-barrier drop t ;
 ! 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 ##read? [
+        dup access? [
             obj>> _ conjoin
         ] [ drop ] if
     ] each ;
@@ -86,11 +88,15 @@ M: slot-analysis transfer-set
 : slot-available? ( vreg bb -- ? )
     slot-in key? ;
 
-: make-barriers ( vregs bb -- )
+: make-barriers ( vregs -- bb )
-    [ [ next-vreg next-vreg ##write-barrier ] each ] add-instructions ;
+    [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
 
-: emit-barriers ( vregs bb -- )
+: emit-barriers ( vregs loop -- )
-    predecessors>> [ make-barriers ] with each ;
+    swap [
+        [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
+        [ header>> ] bi
+    ] [ make-barriers ] bi*
+    insert-basic-block ;
 
 : write-barriers ( bbs -- bb=>barriers )
     [
@@ -107,11 +113,16 @@ M: slot-analysis transfer-set
 : dominant-write-barriers ( loop -- vregs )
     [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
 
-: insert-extra-barriers ( -- )
+: safe-loops ( -- loops )
-    loops get values [| loop |
+    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 header>> emit-barriers ] unless-empty
+        [ loop emit-barriers cfg cfg-changed drop ] unless-empty
     ] each ;
 
 : contains-write-barrier? ( cfg -- ? )
@@ -119,10 +130,10 @@ M: slot-analysis transfer-set
 
 : eliminate-write-barriers ( cfg -- cfg' )
     dup contains-write-barrier? [
-        needs-loops needs-dominance needs-predecessors
+        needs-loops
         dup [ remove-dead-barriers ] each-basic-block
         dup compute-slot-sets
-        insert-extra-barriers
+        dup insert-extra-barriers
         dup compute-safe-sets
         dup [ write-barriers-step ] each-basic-block
     ] when ;