Merge branch 'bags' of git://github.com/littledan/Factor

[factor.git] / basis / compiler / cfg / ssa / construction / tdmsc / tdmsc.factor

diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
index 837b41e47f2a7820cc1443be210f92604f193265..51eb3c8a98e09006cc41b95eb4eb920dc963c0db 100644 (file)
--- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
+++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
@@ -3,6 +3,7 @@
 USING: accessors arrays assocs bit-arrays bit-sets fry
 hashtables hints kernel locals math namespaces sequences sets
 compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+FROM: namespaces => set ;
 IN: compiler.cfg.ssa.construction.tdmsc
 
 ! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
@@ -15,7 +16,7 @@ IN: compiler.cfg.ssa.construction.tdmsc
 SYMBOLS: visited merge-sets levels again? ;
 
 : init-merge-sets ( cfg -- )
-    post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+    post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
 
 : compute-levels ( cfg -- )
     0 over entry>> associate [
@@ -29,15 +30,12 @@ SYMBOLS: visited merge-sets levels again? ;
 
 : level ( bb -- n ) levels get at ; inline
 
-: set-bit ( bit-array n -- )
-    [ t ] 2dip swap set-nth ;
-
 : update-merge-set ( tmp to -- )
     [ merge-sets get ] dip
     '[
         _
-        [ merge-sets get at bit-set-union ]
-        [ dupd number>> set-bit ]
+        [ merge-sets get at union ]
+        [ number>> over adjoin ]
         bi
     ] change-at ;
 
@@ -51,10 +49,10 @@ SYMBOLS: visited merge-sets levels again? ;
     [ [ predecessors>> ] keep ] dip
     '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
 
-: visited? ( pair -- ? ) visited get key? ;
+: visited? ( pair -- ? ) visited get in? ;
 
 : consistent? ( snode lnode -- ? )
-    [ merge-sets get at ] bi@ swap bit-set-subset? ;
+    [ merge-sets get at ] bi@ subset? ;
 
 : (process-edge) ( from to -- )
     f walk [
@@ -65,7 +63,7 @@ SYMBOLS: visited merge-sets levels again? ;
 
 : process-edge ( from to -- )
     2dup 2array dup visited? [ 3drop ] [
-        visited get conjoin
+        visited get adjoin
         (process-edge)
     ] if ;
 
@@ -73,7 +71,7 @@ SYMBOLS: visited merge-sets levels again? ;
     [ process-edge ] each-incoming-j-edge ;
 
 : compute-merge-set-step ( bfo -- )
-    visited get clear-assoc
+    HS{ } clone visited set
     [ process-block ] each ;
 
 : compute-merge-set-loop ( cfg -- )
@@ -82,29 +80,22 @@ SYMBOLS: visited merge-sets levels again? ;
     loop ;
 
 : (merge-set) ( bbs -- flags rpo )
-    merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+    merge-sets get '[ _ at ] [ union ] map-reduce
     cfg get reverse-post-order ; inline
 
-: filter-by ( flags seq -- seq' )
-    [ drop ] selector [ 2each ] dip ;
-
-HINTS: filter-by { bit-array object } ;
-
 PRIVATE>
 
 : compute-merge-sets ( cfg -- )
     needs-dominance
 
-    H{ } clone visited set
+    HS{ } clone visited set
     [ compute-levels ]
     [ init-merge-sets ]
     [ compute-merge-set-loop ]
     tri ;
 
-: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
-    [ (merge-set) ] dip '[
-        swap _ [ drop ] if
-    ] 2each ; inline
-
 : merge-set ( bbs -- bbs' )
-     (merge-set) filter-by ;
+     (merge-set) [ members ] dip nths ;
+
+: merge-set-each ( bbs quot: ( bb -- ) -- )
+    [ merge-set ] dip each ; inline