From c677c35de41344f5dfc5333979daf07e85f2c0f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 5 Sep 2010 21:39:45 -0700
Subject: [PATCH] compiler.cfg: fix major facepalm with write barrier
 elimination

---
 .../cfg/finalization/finalization.factor      |  7 +-
 basis/compiler/cfg/optimizer/optimizer.factor |  6 +-
 .../write-barrier/write-barrier-tests.factor  | 93 +++++++++++++++++++
 .../cfg/write-barrier/write-barrier.factor    | 10 +-
 basis/compiler/tests/alien.factor             | 22 +++++
 5 files changed, 130 insertions(+), 8 deletions(-)
 create mode 100644 basis/compiler/cfg/write-barrier/write-barrier-tests.factor

diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor
index 2b731bdd90..a0bb29cdf0 100644
--- a/basis/compiler/cfg/finalization/finalization.factor
+++ b/basis/compiler/cfg/finalization/finalization.factor
@@ -2,15 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel compiler.cfg.representations
 compiler.cfg.scheduling compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
-compiler.cfg.stacks.uninitialized ;
+compiler.cfg.write-barrier compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- cfg' )
     select-representations
     schedule-instructions
     insert-gc-checks
+    eliminate-write-barriers
     dup compute-uninitialized-sets
     insert-save-contexts
     destruct-ssa
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 5881cd78ea..6a62b6f7e7 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -9,8 +9,7 @@ compiler.cfg.ssa.construction
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
 compiler.cfg.copy-prop
-compiler.cfg.dce
-compiler.cfg.write-barrier ;
+compiler.cfg.dce ;
 IN: compiler.cfg.optimizer
 
 : optimize-cfg ( cfg -- cfg' )
@@ -23,5 +22,4 @@ IN: compiler.cfg.optimizer
     alias-analysis
     value-numbering
     copy-propagation
-    eliminate-dead-code
-    eliminate-write-barriers ;
+    eliminate-dead-code ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
new file mode 100644
index 0000000000..136324ba47
--- /dev/null
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -0,0 +1,93 @@
+USING: compiler.cfg.instructions compiler.cfg.write-barrier
+tools.test ;
+IN: compiler.cfg.write-barrier.tests
+
+! Do need a write barrier on a random store.
+[
+    V{
+        T{ ##peek f 1 }
+        T{ ##set-slot f 2 1 3 }
+        T{ ##write-barrier f 1 3 }
+    }
+] [
+    V{
+        T{ ##peek f 1 }
+        T{ ##set-slot f 2 1 3 }
+        T{ ##write-barrier f 1 3 }
+    } write-barriers-step
+] unit-test
+
+[
+    V{
+        T{ ##peek f 1 }
+        T{ ##set-slot-imm f 2 1 }
+        T{ ##write-barrier-imm f 1 }
+    }
+] [
+    V{
+        T{ ##peek f 1 }
+        T{ ##set-slot-imm f 2 1 }
+        T{ ##write-barrier-imm f 1 }
+    } write-barriers-step
+] unit-test
+
+! Don't need a write barrier on freshly allocated objects.
+[
+    V{
+        T{ ##allot f 1 }
+        T{ ##set-slot f 2 1 3 }
+    }
+] [
+    V{
+        T{ ##allot f 1 }
+        T{ ##set-slot f 2 1 3 }
+        T{ ##write-barrier f 1 3 }
+    } write-barriers-step
+] unit-test
+
+[
+    V{
+        T{ ##allot f 1 }
+        T{ ##set-slot-imm f 2 1 }
+    }
+] [
+    V{
+        T{ ##allot f 1 }
+        T{ ##set-slot-imm f 2 1 }
+        T{ ##write-barrier-imm f 1 }
+    } write-barriers-step
+] unit-test
+
+! Do need a write barrier if there's a subroutine call between
+! the allocation and the store.
+[
+    V{
+        T{ ##allot f 1 }
+        T{ ##box }
+        T{ ##set-slot f 2 1 3 }
+        T{ ##write-barrier f 1 3 }
+    }
+] [
+    V{
+        T{ ##allot f 1 }
+        T{ ##box }
+        T{ ##set-slot f 2 1 3 }
+        T{ ##write-barrier f 1 3 }
+    } write-barriers-step
+] unit-test
+
+[
+    V{
+        T{ ##allot f 1 }
+        T{ ##box }
+        T{ ##set-slot-imm f 2 1 }
+        T{ ##write-barrier-imm f 1 }
+    }
+] [
+    V{
+        T{ ##allot f 1 }
+        T{ ##box }
+        T{ ##set-slot-imm f 2 1 }
+        T{ ##write-barrier-imm f 1 }
+    } write-barriers-step
+] unit-test
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index a34bf6c07f..5c75eba21c 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -6,6 +6,8 @@ sequences sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.write-barrier
 
+! This pass must run after GC check insertion and scheduling.
+
 SYMBOL: fresh-allocations
 
 SYMBOL: mutated-objects
@@ -22,7 +24,10 @@ M: ##set-slot-imm eliminate-write-barrier
     obj>> mutated-objects get conjoin t ;
 
 : needs-write-barrier? ( insn -- ? )
-    { [ fresh-allocations get key? not ] [ mutated-objects get key? ] } 1&& ;
+    {
+        [ fresh-allocations get key? not ]
+        [ mutated-objects get key? ]
+    } 1&& ;
 
 M: ##write-barrier eliminate-write-barrier
     src>> needs-write-barrier? ;
@@ -30,6 +35,9 @@ M: ##write-barrier eliminate-write-barrier
 M: ##write-barrier-imm eliminate-write-barrier
     src>> needs-write-barrier? ;
 
+M: gc-map-insn eliminate-write-barrier
+    fresh-allocations get clear-assoc ;
+
 M: ##copy eliminate-write-barrier
     "Run copy propagation first" throw ;
 
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 60e132bb76..65e67e66d2 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -823,3 +823,25 @@ TUPLE: some-tuple x ;
         aa-indirect-1 >>x
     ] compile-call
 ] unit-test
+
+! Write barrier elimination was being done before scheduling and
+! GC check insertion, and didn't take subroutine calls into
+! account. Oops...
+: write-barrier-elim-in-wrong-place ( -- obj )
+    ! A callback used below
+    void { } cdecl [ compact-gc ] alien-callback
+    ! Allocate an object A in the nursery
+    1 f <array>
+    ! Subroutine call promotes the object to tenured
+    swap void { } cdecl alien-indirect
+    ! Allocate another object B in the nursery, store it into
+    ! the first
+    1 f <array> over set-first
+    ! Now object A's card should be marked and minor GC should
+    ! promote B to aging
+    minor-gc
+    ! Do stuff
+    [ 100 [ ] times ] infer.
+    ;
+
+[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test