compiler.cfg.stacks.*: simplify the code a little by making replace-sets, peek-sets and kill-sets contain hash-sets instead of hash-tables

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -4,21 +4,21 @@ USING: accessors assocs compiler.cfg.checker compiler.cfg
 compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.rpo
 compiler.cfg.stacks.global compiler.cfg.stacks.height
 compiler.cfg.stacks.local compiler.cfg.utilities fry kernel
-locals make math sequences ;
+locals make math sequences sets ;
 IN: compiler.cfg.stacks.finalize
 
-:: inserting-peeks ( from to -- assoc )
+:: inserting-peeks ( from to -- set )
     to anticip-in
-    from anticip-out from avail-out assoc-union
+    from anticip-out from avail-out union
-    assoc-diff ;
+    diff ;
 
-:: inserting-replaces ( from to -- assoc )
+:: inserting-replaces ( from to -- set )
-    from pending-out to pending-in assoc-diff
+    from pending-out to pending-in diff
-    to dead-in to live-in to anticip-in assoc-diff assoc-diff
+    to dead-in to live-in to anticip-in diff diff
-    assoc-diff ;
+    diff ;
 
-: each-insertion ( ... assoc bb quot: ( ... vreg loc -- ... ) -- ... )
+: each-insertion ( ... set bb quot: ( ... vreg loc -- ... ) -- ... )
-    '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
+    [ members ] 2dip '[ [ loc>vreg ] [ _ untranslate-loc ] bi @ ] each ; inline
 
 ERROR: bad-peek dst loc ;
 
@@ -35,7 +35,7 @@ ERROR: bad-peek dst loc ;
     ! computing anything.
     2dup [ kill-block?>> ] both? [ 2drop ] [
         2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch, ] V{ } make
-        [ 2drop ] [ insert-basic-block ] if-empty
+        insert-basic-block
     ] if ;
 
 : visit-block ( bb -- )

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

@@ -1,15 +1,19 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs combinators compiler.cfg.dataflow-analysis
-compiler.cfg.stacks.local kernel namespaces ;
+compiler.cfg.stacks.local kernel namespaces sequences sets ;
 IN: compiler.cfg.stacks.global
 
 : peek-set ( bb -- assoc ) peek-sets get at ;
 : replace-set ( bb -- assoc ) replace-sets get at ;
 : kill-set ( bb -- assoc ) kill-sets get at ;
 
-: transfer-peeked-locs ( assoc bb -- assoc' )
+! Should exists somewhere else
-    [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ;
+: refine ( sets -- set )
+    [ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
+
+: transfer-peeked-locs ( set bb -- set' )
+    [ replace-set diff ] [ peek-set union ] bi ;
 
 ! A stack location is anticipated at a location if every path from
 ! the location to an exit block will read the stack location
@@ -17,6 +21,7 @@ IN: compiler.cfg.stacks.global
 BACKWARD-ANALYSIS: anticip
 
 M: anticip-analysis transfer-set drop transfer-peeked-locs ;
+M: anticip-analysis join-sets 2drop refine ;
 
 ! A stack location is live at a location if some path from
 ! the location to an exit block will read the stack location
@@ -24,8 +29,7 @@ M: anticip-analysis transfer-set drop transfer-peeked-locs ;
 BACKWARD-ANALYSIS: live
 
 M: live-analysis transfer-set drop transfer-peeked-locs ;
-
+M: live-analysis join-sets 2drop 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
@@ -33,20 +37,21 @@ M: live-analysis join-sets 2drop assoc-combine ;
 FORWARD-ANALYSIS: avail
 
 M: avail-analysis transfer-set
-    drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ;
+    drop [ peek-set ] [ replace-set ] bi union union ;
+M: avail-analysis join-sets 2drop refine ;
 
 ! A stack location is pending at a location if all paths from
 ! the entry block to the location write the location.
 FORWARD-ANALYSIS: pending
 
 M: pending-analysis transfer-set
-    drop replace-set assoc-union ;
+    drop replace-set union ;
+M: pending-analysis join-sets 2drop refine ;
 
 ! A stack location is dead at a location if no paths from the
 ! location to the exit block read the location before writing it.
 BACKWARD-ANALYSIS: dead
 
 M: dead-analysis transfer-set
-    drop
+    drop [ kill-set ] [ replace-set ] bi union union ;
-    [ kill-set assoc-union ]
+M: dead-analysis join-sets 2drop refine ;
-    [ replace-set assoc-union ] bi ;

basis/compiler/cfg/stacks/local/local-tests.factor

@@ -2,6 +2,7 @@ USING: accessors assocs biassocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
 compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
 compiler.test cpu.architecture make namespaces kernel tools.test ;
+QUALIFIED: sets
 IN: compiler.cfg.stacks.local.tests
 
 ! loc>vreg
@@ -27,14 +28,40 @@ IN: compiler.cfg.stacks.local.tests
 
 ! end-local-analysis
 {
-    H{ }
+    HS{ }
-    H{ }
+    { }
-    H{ }
+    HS{ }
 } [
     "foo" [ "eh" , end-local-analysis ] V{ } make drop
     "foo" [ peek-sets ] [ replace-sets ] [ kill-sets ] tri [ get at ] 2tri@
 ] cfg-unit-test
 
+{
+    { D 3 }
+} [
+    "foo" [ 3 D 3 replace-loc "eh" , end-local-analysis ] V{ } make drop
+    replace-sets get "foo" of
+] unit-test
+
+! remove-redundant-replaces
+{
+    H{ { T{ ds-loc { n 3 } } 7 } }
+} [
+    D 0 loc>vreg D 2 loc>vreg 2drop
+    2 D 2 replace-loc 7 D 3 replace-loc
+    replace-mapping get remove-redundant-replaces
+] cfg-unit-test
+
+! emit-changes
+{
+    V{ T{ ##copy { dst 1 } { src 3 } { rep any-rep } } "eh" }
+} [
+    3 D 0 replace-loc [
+        "eh",
+        replace-mapping get height-state get emit-changes
+    ] V{ } make
+] cfg-unit-test
+
 ! height-state
 {
     { { 3 3 } { 0 0 } }
@@ -55,8 +82,6 @@ IN: compiler.cfg.stacks.local.tests
     { { 0 4  } { 0 -2 } } height-state>insns
 ] unit-test
 
-
-
 { H{ { D -1 40 } } } [
     D 1 inc-stack 40 D 0 replace-loc replace-mapping get
 ] cfg-unit-test
@@ -64,10 +89,10 @@ IN: compiler.cfg.stacks.local.tests
 { 0 } [
     V{ } 0 insns>block basic-block set
     init-cfg-test
-    compute-local-kill-set assoc-size
+    compute-local-kill-set sets:cardinality
 ] unit-test
 
-{ H{ { R -4 R -4 } } } [
+{ HS{ R -4 } } [
     H{ { 77 4 } } [ ds-heights set ] [ rs-heights set ] bi
     { { 8 0 } { 3 0 } } height-state set
     77 basic-block set

basis/compiler/cfg/stacks/local/local.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.parallel-copy
 compiler.cfg.registers compiler.cfg.stacks.height
-kernel make math math.order namespaces sequences sets ;
+hash-sets kernel make math math.order namespaces sequences sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.stacks.local
 
@@ -35,10 +35,10 @@ IN: compiler.cfg.stacks.local
 : kill-locations ( saved-height height -- seq )
     dupd [-] iota [ swap - ] with map ;
 
-: local-kill-set ( ds-height rs-height state -- assoc )
+: local-kill-set ( ds-height rs-height state -- set )
     first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
     [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
-    append unique ;
+    append >hash-set ;
 
 SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
 
@@ -48,45 +48,43 @@ SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
 
-SYMBOLS: local-peek-set local-replace-set replace-mapping ;
+SYMBOLS: local-peek-set replace-mapping ;
 
 : stack-changes ( replace-mapping -- insns )
     [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
 
-: emit-changes ( -- )
+: emit-changes ( replace-mapping height-state -- )
-    building get pop
+    building get pop -rot [ stack-changes % ] [ height-state>insns % ] bi* , ;
-    replace-mapping get stack-changes %
-    height-state get height-state>insns %
-    , ;
 
 : peek-loc ( loc -- vreg )
     height-state get swap translate-local-loc
     dup replace-mapping get at
-    [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
+    [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
 
 : replace-loc ( vreg loc -- )
     height-state get swap translate-local-loc
     replace-mapping get set-at ;
 
-: compute-local-kill-set ( -- assoc )
+: compute-local-kill-set ( -- set )
     basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
     height-state get local-kill-set ;
 
 : begin-local-analysis ( -- )
-    H{ } clone local-peek-set set
+    HS{ } clone local-peek-set set
     H{ } clone replace-mapping set
     height-state get
     [ reset-emits ] [
         first2 [ first ] bi@ basic-block get record-stack-heights
     ] bi ;
 
-: remove-redundant-replaces ( -- )
+: remove-redundant-replaces ( replace-mapping -- replace-mapping' )
-    replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
+    [ [ loc>vreg ] dip = not ] assoc-filter ;
-    [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
 
 : end-local-analysis ( basic-block -- )
-    remove-redundant-replaces
+    [
-    emit-changes
+        replace-mapping get remove-redundant-replaces
+        dup height-state get emit-changes keys
+        swap replace-sets get set-at
+    ]
     [ [ local-peek-set get ] dip peek-sets get set-at ]
-    [ [ local-replace-set get ] dip replace-sets get set-at ]
     [ [ compute-local-kill-set ] dip kill-sets get set-at ] tri ;