Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:
	basis/calendar/calendar.factor

basis/calendar/calendar.factor

@@ -34,14 +34,14 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
 
 <PRIVATE
 
 : check-month ( n -- n )
-    dup zero? [ not-a-month ] when ;
+    [ not-a-month ] when-zero ;
 
 PRIVATE>
 
@@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
     { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero ( n quot -- )
-    [ dup zero? [ drop ] ] dip if ; inline
-
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 
@@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 
 : months/years ( n -- months years )
-    12 /rem dup zero? [ drop 1 - 12 ] when swap ; inline
+    12 /rem [ 1 - 12 ] when-zero swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
     [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities
 compiler.cfg.predecessors compiler.cfg ;
 IN: compiler.cfg.dataflow-analysis
 
-GENERIC: join-sets ( sets dfa -- set )
+GENERIC: join-sets ( sets bb dfa -- set )
 GENERIC: transfer-set ( in-set bb dfa -- out-set )
 GENERIC: block-order ( cfg dfa -- bbs )
 GENERIC: successors ( bb dfa -- seq )
@@ -23,7 +23,7 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
 M: kill-block compute-in-set 3drop f ;
 
 M:: basic-block compute-in-set ( bb out-sets dfa -- set )
-    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+    bb dfa predecessors [ out-sets at ] map bb dfa join-sets ;
 
 :: update-in-set ( bb in-sets out-sets dfa -- ? )
     bb out-sets dfa compute-in-set
@@ -56,7 +56,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
     in-sets
     out-sets ; inline
 
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
 
 FUNCTOR: define-analysis ( name -- )
 

basis/compiler/cfg/liveness/liveness.factor

@@ -28,4 +28,4 @@ M: live-analysis transfer-set
     drop instructions>> transfer-liveness ;
 
 M: live-analysis join-sets
-    drop assoc-combine ;
+    2drop assoc-combine ;

basis/compiler/cfg/stacks/global/global.factor

@@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live
 
 M: live-analysis transfer-set drop transfer-peeked-locs ;
 
-M: live-analysis join-sets drop assoc-combine ;
+M: live-analysis join-sets 2drop assoc-combine ;
 
 ! A stack location is available at a location if all paths from
 ! the entry block to the location load the location into a
@@ -56,4 +56,4 @@ M: dead-analysis transfer-set
         [ compute-dead-sets ]
         [ compute-avail-sets ]
         [ ]
-    } cleave ;
+    } cleave ;

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
     drop [ prepare ] dip visit-block finish ;
 
 M: uninitialized-analysis join-sets ( sets analysis -- pair )
-    drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+    2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
 
 : uninitialized-locs ( bb -- locs )
     uninitialized-in dup [
@@ -73,4 +73,4 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair )
         [ [ <ds-loc> ] (uninitialized-locs) ]
         [ [ <rs-loc> ] (uninitialized-locs) ]
         bi* append
-    ] when ;
+    ] when ;

basis/compiler/cfg/write-barrier/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg

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

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,27 @@ 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? ;
+
+M: safe-analysis transfer-set
+    drop [ H{ } assoc-clone-like ] dip
+    instructions>> over '[
+        dup ##write-barrier? [
+            src>> _ conjoin
+        ] [ drop ] if
+    ] each ;
+
+M: safe-analysis join-sets
+    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
+
 : write-barriers-step ( bb -- )
-    H{ } clone safe set
+    dup safe-in H{ } assoc-clone-like 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 ;

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-table>> <scroller> "Errors" <labeled-gadget> 1/4 track-add
-        error-list error-display>> "Details" <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*