Fixing write-barrier elimination; adding bb as a parameter to join-sets in dataflow analysis

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/write-barrier.factor

@@ -36,11 +36,8 @@ 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
+    drop [ H{ } assoc-clone-like ] dip
     instructions>> over '[
         dup ##write-barrier? [
             src>> _ conjoin
@@ -48,19 +45,13 @@ M: safe-analysis transfer-set
     ] 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) ;
+    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
 
 : write-barriers-step ( bb -- )
-    dup safe-start 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 compute-safe-sets
     dup [ write-barriers-step ] each-basic-block ;