From 5a3e3504909ca5b1d6d199fc2012ccf835e47c74 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Thu, 13 Aug 2009 15:18:47 -0500
Subject: [PATCH] Global write barrier elimination tracks newly allocated
 objects

---
 .../write-barrier/write-barrier-tests.factor   | 18 ++++++++++++++++++
 .../cfg/write-barrier/write-barrier.factor     | 11 +++++++----
 2 files changed, 25 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index dd010f0dbc..d1f58c8bfa 100644
--- 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 2375075df5..ef878e029a 100644
--- 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 ;