compiler.cfg: fix major facepalm with write barrier elimination

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

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 ;

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

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 ;
 

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