compiler.cfg.*: new word for consuming deques slurp/replenish-deque

most uses of slurp-deque processes one item and pushes a sequence of
items to continue working with. it can be formalized into a
slurp/replenish-deque combinator which also reduces the amount of
variables you need to use

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg.predecessors
+USING: accessors assocs combinators.short-circuit compiler.cfg.predecessors
-compiler.cfg.rpo deques dlists functors kernel lexer locals
+compiler.cfg.rpo compiler.cfg.utilities deques dlists functors kernel lexer
-namespaces sequences ;
+locals namespaces sequences ;
 IN: compiler.cfg.dataflow-analysis
 
 GENERIC: join-sets ( sets bb dfa -- set )
@@ -39,19 +39,18 @@ MIXIN: dataflow-analysis
     bb in-sets dfa compute-out-set
     bb out-sets maybe-set-at ; inline
 
-:: dfa-step ( bb in-sets out-sets dfa work-list -- )
+: update-in/out-set ( bb in-sets out-sets dfa -- ? )
-    bb in-sets out-sets dfa update-in-set [
+    { [ update-in-set ] [ update-out-set ] } 4 n&& ;
-        bb in-sets out-sets dfa update-out-set [
+
-            bb dfa successors work-list push-all-front
+:: dfa-step ( bb in-sets out-sets dfa -- bbs )
-        ] when
+    bb in-sets out-sets dfa update-in/out-set bb dfa successors { } ? ;
-    ] when ; inline
 
 :: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
-    cfg needs-predecessors
     H{ } clone :> in-sets
     H{ } clone :> out-sets
-    cfg dfa <dfa-worklist> :> work-list
+    cfg needs-predecessors
-    work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+    cfg dfa <dfa-worklist>
+    [ in-sets out-sets dfa dfa-step ] slurp/replenish-deque
     in-sets
     out-sets ; inline
 

basis/compiler/cfg/linearization/linearization-tests.factor

@@ -1,7 +1,9 @@
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+USING: accessors compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
-compiler.cfg.utilities kernel accessors sequences sets tools.test namespaces ;
+compiler.cfg.linearization.private compiler.cfg.utilities dlists kernel make
+namespaces sequences tools.test  ;
 IN: compiler.cfg.linearization.tests
 
+! linearization-order
 V{ } 0 test-bb
 
 V{ } 1 test-bb
@@ -14,3 +16,18 @@ V{ } 2 test-bb
 { { 0 1 2 } } [
     0 get block>cfg linearization-order [ number>> ] map
 ] unit-test
+
+! process-block
+{ { } V{ 10 } } [
+    HS{ } clone visited set
+    V{ } 10 insns>block [ process-block ] V{ } make
+    [ number>> ] map
+] unit-test
+
+! process-successor
+{ V{ 10 } } [
+    <dlist> work-list set
+    HS{ } clone visited set
+    V{ } 10 insns>block process-successor
+    work-list get dlist>sequence [ number>> ] map
+] unit-test

basis/compiler/cfg/linearization/linearization.factor

@@ -12,20 +12,10 @@ IN: compiler.cfg.linearization
 
 <PRIVATE
 
-SYMBOLS: work-list loop-heads visited ;
+SYMBOLS: loop-heads visited ;
 
 : visited? ( bb -- ? ) visited get in? ;
 
-: add-to-work-list ( bb -- )
-    dup visited? [ drop ] [
-        work-list get push-back
-    ] if ;
-
-: init-linearization-order ( cfg -- )
-    <dlist> work-list set
-    HS{ } clone visited set
-    entry>> add-to-work-list ;
-
 : (find-alternate-loop-head) ( bb -- bb' )
     dup {
         [ predecessor visited? not ]
@@ -48,26 +38,19 @@ SYMBOLS: work-list loop-heads visited ;
         [ 2drop t ] [ drop visited? ] if
     ] all? ;
 
-: process-successor ( bb -- )
-    dup predecessors-ready? [
-        dup loop-entry? [ find-alternate-loop-head ] when
-        add-to-work-list
-    ] [ drop ] if ;
-
 : sorted-successors ( bb -- seq )
     successors>> <reversed> [ loop-nesting-at ] sort-with ;
 
-: process-block ( bb -- )
+: process-block ( bb -- bbs )
-    dup visited get ?adjoin [
+    dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
-        [ , ]
+    [ predecessors-ready? ] filter
-        [ sorted-successors [ process-successor ] each ]
+    [ dup loop-entry? [ find-alternate-loop-head ] when ] map
-        bi
+    [ visited? not ] filter ;
-    ] [ drop ] if ;
 
 : (linearization-order) ( cfg -- bbs )
-    init-linearization-order
+    HS{ } clone visited set
-
+    entry>> <dlist> [ push-back ] keep
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
+    [ [ process-block ] slurp/replenish-deque ] { } make ;
 
 PRIVATE>
 

basis/compiler/cfg/liveness/liveness-tests.factor

@@ -2,7 +2,7 @@ USING: accessors compiler.cfg.liveness
 compiler.cfg compiler.cfg.debugger compiler.cfg.instructions
 compiler.cfg.predecessors compiler.cfg.registers
 compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities cpu.architecture
-namespaces sequences kernel tools.test vectors alien math
+dlists namespaces sequences kernel tools.test vectors alien math
 compiler.cfg.comparisons cpu.x86.assembler.operands assocs ;
 IN: compiler.cfg.liveness.tests
 QUALIFIED: sets
@@ -84,6 +84,13 @@ QUALIFIED: sets
     H{ { 37 37 } { 3 3 } } dup T{ ##peek f 2 D 0 0 } kill-defs
 ] unit-test
 
+! liveness-step
+{ 3 } [
+    init-liveness
+    3 iota [ <basic-block> swap >>number ] map <basic-block>
+    [ connect-Nto1-bbs ] keep liveness-step length
+] unit-test
+
 ! lookup-base-pointer
 { 84 } [
     H{ { 84 84 } } clone base-pointers set 84 lookup-base-pointer

basis/compiler/cfg/liveness/liveness.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg.def-use
+USING: accessors assocs combinators combinators.short-circuit
-compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.predecessors
 compiler.cfg.registers compiler.cfg.rpo
 compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities
 cpu.architecture deques dlists fry kernel locals namespaces
@@ -93,13 +93,11 @@ M: vreg-insn lookup-base-pointer* 2drop f ;
     } case ;
 
 : gc-roots ( live-set -- derived-roots gc-roots )
-    V{ } clone HS{ } clone
+    keys V{ } clone HS{ } clone
-    [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
+    [ '[ _ _ visit-gc-root ] each ] 2keep members ;
-    members ;
 
 : fill-gc-map ( live-set gc-map -- )
-    [ representations get [ gc-roots ] [ drop f f ] if ] dip
+    [ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ;
-    [ gc-roots<< ] [ derived-roots<< ] bi ;
 
 M: gc-map-insn visit-insn ( live-set insn -- )
     [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
@@ -111,11 +109,6 @@ M: insn visit-insn 2drop ;
 : transfer-liveness ( live-set insns -- )
     <reversed> [ visit-insn ] with each ;
 
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
-    work-list get push-all-front ;
-
 : compute-live-in ( basic-block -- live-in )
     [ live-out clone dup ] keep instructions>> transfer-liveness ;
 
@@ -138,23 +131,23 @@ SYMBOL: work-list
     [ compute-live-out ] keep
     live-outs get maybe-set-at ;
 
-: liveness-step ( basic-block -- )
+: update-live-out/in ( basic-block -- changed? )
-    dup update-live-out [
+    { [ update-live-out ] [ update-live-in ] } 1&& ;
-        dup update-live-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
 
-: compute-live-sets ( cfg -- )
+: liveness-step ( basic-block -- basic-blocks )
-    <hashed-dlist> work-list set
+    [ update-live-out/in ] keep predecessors>> { } ? ;
+
+: init-liveness ( -- )
     H{ } clone live-ins set
     H{ } clone edge-live-ins set
     H{ } clone live-outs set
-    H{ } clone base-pointers set
+    H{ } clone base-pointers set ;
 
-    [ needs-predecessors ]
+: compute-live-sets ( cfg -- )
-    [ compute-insns ]
+    init-liveness
-    [ post-order add-to-work-list ] tri
+    dup needs-predecessors dup compute-insns
-    work-list get [ liveness-step ] slurp-deque ;
+    post-order <hashed-dlist> [ push-all-front ] keep
+    [ liveness-step ] slurp/replenish-deque ;
 
 : live-in? ( vreg bb -- ? ) live-in key? ;
 

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -1,7 +1,22 @@
-USING: compiler.cfg compiler.cfg.loop-detection compiler.cfg.debugger
+USING: accessors compiler.cfg compiler.cfg.loop-detection
-compiler.cfg.predecessors compiler.cfg.utilities tools.test kernel namespaces
+compiler.cfg.loop-detection.private compiler.cfg.debugger
-accessors ;
+compiler.cfg.predecessors compiler.cfg.utilities tools.test dlists kernel
+namespaces sequences ;
 IN: compiler.cfg.loop-detection.tests
+QUALIFIED: sets
+
+{ V{ 0 } { 1 } } [
+    V{ } 0 insns>block V{ } 1 insns>block [ connect-bbs ] keep
+    f f <natural-loop> [ process-loop-block ] keep
+    blocks>> sets:members
+    [ [ number>> ] map ] bi@
+] unit-test
+
+! process-loop-ends
+{ } [
+    f f <natural-loop> process-loop-ends
+] unit-test
+
 
 V{ } 0 test-bb
 V{ } 1 test-bb

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg compiler.cfg.predecessors
+USING: accessors assocs combinators.short-circuit compiler.cfg
-deques dlists fry kernel namespaces sequences sets ;
+compiler.cfg.predecessors compiler.cfg.utilities deques dlists fry kernel
+namespaces sequences sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.loop-detection
 
@@ -39,18 +40,13 @@ DEFER: find-loop-headers
         2tri
     ] [ drop ] if ;
 
-SYMBOL: work-list
+: process-loop-block ( bb loop -- bbs )
-
+    dupd { [ blocks>> ?adjoin ] [ header>> eq? not ] } 2&&
-: process-loop-block ( bb loop -- )
+    swap predecessors>> { } ? ;
-    2dup blocks>> ?adjoin [
-        2dup header>> eq? [ 2drop ] [
-            drop predecessors>> work-list get push-all-front
-        ] if
-    ] [ 2drop ] if ;
 
 : process-loop-ends ( loop -- )
-    [ ends>> members <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
+    dup ends>> members <dlist> [ push-all-front ] keep
-    '[ _ process-loop-block ] slurp-deque ;
+    swap '[ _ process-loop-block ] slurp/replenish-deque ;
 
 : process-loop-headers ( -- )
     loops get values [ process-loop-ends ] each ;

basis/compiler/cfg/utilities/utilities.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators.short-circuit compiler.cfg
-compiler.cfg.instructions compiler.cfg.rpo cpu.architecture fry
+compiler.cfg.instructions compiler.cfg.rpo cpu.architecture deques fry
 kernel locals make math namespaces sequences sets ;
 IN: compiler.cfg.utilities
 
@@ -83,9 +83,6 @@ IN: compiler.cfg.utilities
 : <copy> ( dst src -- insn )
     any-rep ##copy new-insn ;
 
-: apply-passes ( obj passes -- )
-    [ execute( x -- ) ] with each ;
-
 : connect-bbs ( from to -- )
     [ [ successors>> ] dip suffix! drop ]
     [ predecessors>> swap suffix! drop ] 2bi ;
@@ -95,3 +92,10 @@ IN: compiler.cfg.utilities
 
 : make-edges ( block-map edgelist -- )
     [ [ of ] with map first2 connect-bbs ] with each ;
+
+! Abstract generic stuff
+: apply-passes ( obj passes -- )
+    [ execute( x -- ) ] with each ;
+
+: slurp/replenish-deque ( ... deque quot: ( ... obj -- ... seq ) -- ... )
+      over '[ @ _ push-all-front ] slurp-deque ; inline