diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b45e2c9597..15dff23448 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/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 ;
 
diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor
index dc70656c08..73b99ee132 100644
--- a/basis/compiler/cfg/loop-detection/loop-detection.factor
+++ b/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 ;
\ No newline at end of file
+    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor
index ca81c69bc0..f1f7880c90 100644
--- a/basis/compiler/cfg/stacks/finalize/finalize.factor
+++ b/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 -- )
@@ -56,4 +56,4 @@ ERROR: bad-peek dst loc ;
 
     dup [ visit-block ] each-basic-block
 
-    cfg-changed ;
\ No newline at end of file
+    cfg-changed ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 6d68bca4b9..bb61a63939 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/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,16 +37,16 @@ SYMBOL: visited
 : 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
 
@@ -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? ;
 
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index dd010f0dbc..a73451042d 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/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 )
@@ -93,6 +100,24 @@ cfg new 1 get >>entry 0 set
     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 }
@@ -140,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
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 2375075df5..97b0c27af1 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/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 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.
@@ -20,38 +28,112 @@ 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? ;
 
 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 ;