From 1a7ab59f56a1ee1ac9051fcd629584c6c4b0173d Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 11 Aug 2009 21:21:21 -0500
Subject: [PATCH] Making write barrier elimination global

---
 basis/compiler/cfg/write-barrier/authors.txt  |  2 +
 .../write-barrier/write-barrier-tests.factor  | 72 ++++++++++++++++++-
 .../cfg/write-barrier/write-barrier.factor    | 33 ++++++++-
 basis/ui/tools/error-list/error-list.factor   |  4 +-
 4 files changed, 105 insertions(+), 6 deletions(-)
 create mode 100644 basis/compiler/cfg/write-barrier/authors.txt

diff --git a/basis/compiler/cfg/write-barrier/authors.txt b/basis/compiler/cfg/write-barrier/authors.txt
new file mode 100644
index 0000000000..a44f8d7f8d
--- /dev/null
+++ b/basis/compiler/cfg/write-barrier/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index c09f404d4c..dd010f0dbc 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -1,7 +1,9 @@
+! 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 ;
+compiler.cfg.utilities namespaces sequences ;
 IN: compiler.cfg.write-barrier.tests
 
 : test-write-barrier ( insns -- insns )
@@ -70,3 +72,71 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##write-barrier f 19 30 3 }
     } test-write-barrier
 ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 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{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 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 }
+} 1 test-bb
+V{
+    T{ ##allot }
+    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{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##allot }
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##allot }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 3 test-bb
+2 get 3 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 3 get instructions>> ] unit-test
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 2f32a4ca81..bb08c4f173 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! 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 compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.dataflow-analysis fry combinators.short-circuit ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -30,10 +31,36 @@ M: ##set-slot-imm eliminate-write-barrier
 
 M: insn eliminate-write-barrier drop t ;
 
+FORWARD-ANALYSIS: safe
+
+: has-allocation? ( bb -- ? )
+    instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
+
+: (safe-in) ( maybe-safe-in bb -- safe-in )
+    has-allocation? not swap and [ H{ } clone ] unless* ;
+
+M: safe-analysis transfer-set
+    drop [ (safe-in) ] keep
+    instructions>> over '[
+        dup ##write-barrier? [
+            src>> _ conjoin
+        ] [ drop ] if
+    ] each ;
+
+M: safe-analysis join-sets
+    ! maybe this would be better if we had access to the basic block
+    ! then in this definition, it would check for has-allocation?
+    ! (once rather than twice)
+    drop assoc-refine ;
+
+: safe-start ( bb -- set )
+    [ safe-in ] keep (safe-in) ;
+
 : write-barriers-step ( bb -- )
-    H{ } clone safe set
+    dup safe-start safe set
     H{ } clone mutated set
     instructions>> [ eliminate-write-barrier ] filter-here ;
 
 : eliminate-write-barriers ( cfg -- cfg' )
+    dup compute-safe-sets
     dup [ write-barriers-step ] each-basic-block ;
diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor
index 1193ca237c..a1da59fe39 100644
--- a/basis/ui/tools/error-list/error-list.factor
+++ b/basis/ui/tools/error-list/error-list.factor
@@ -165,8 +165,8 @@ error-display "toolbar" f {
         { 5 5 } >>gap
         error-list <error-list-toolbar> f track-add
         error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
-        error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
-        error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+        error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/4 track-add
+        error-list error-display>> "Details" <labeled-gadget> 1/2 track-add
     { 5 5 } <filled-border> 1 track-add ;
 
 M: error-list-gadget focusable-child*