Global write barrier elimination tracks newly allocated objects

diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index dd010f0dbc1f140c7c09edfdce5f67be1f0fd201..d1f58c8bfae138e7668c89bcaa5d67362263c63c 100644 (file)
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -93,6 +93,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 }

diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 2375075df5cb85ea0fb2f76168ed169dfd2cf75c..ef878e029aafa1f4107ccf1240685e007c33c3b8 100644 (file)
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -36,12 +36,15 @@ 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 '[
-        dup ##write-barrier? [
-            src>> _ conjoin
-        ] [ drop ] if
+        safe-slot [ _ conjoin ] [ drop ] if
     ] each ;
 
 M: safe-analysis join-sets
@@ -53,5 +56,5 @@ M: safe-analysis join-sets
     instructions>> [ eliminate-write-barrier ] filter-here ;
 
 : eliminate-write-barriers ( cfg -- cfg' )
-     dup compute-safe-sets
+    dup compute-safe-sets
     dup [ write-barriers-step ] each-basic-block ;