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

diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
index 0db7e74483606cd3b2f571ea6c0fb817b9acd804..a610498478d1cd39b0d7f769084fff84c5902b66 100644 (file)
--- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
+++ b/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
-compiler.cfg.rpo deques dlists functors kernel lexer locals
-namespaces sequences ;
+USING: accessors assocs combinators.short-circuit compiler.cfg.predecessors
+compiler.cfg.rpo compiler.cfg.utilities deques dlists functors kernel lexer
+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 -- )
-    bb in-sets out-sets dfa update-in-set [
-        bb in-sets out-sets dfa update-out-set [
-            bb dfa successors work-list push-all-front
-        ] when
-    ] when ; inline
+: update-in/out-set ( bb in-sets out-sets dfa -- ? )
+    { [ update-in-set ] [ update-out-set ] } 4 n&& ;
+
+:: dfa-step ( bb in-sets out-sets dfa -- bbs )
+    bb in-sets out-sets dfa update-in/out-set bb dfa successors { } ? ;
 
 :: 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
-    work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+    cfg needs-predecessors
+    cfg dfa <dfa-worklist>
+    [ in-sets out-sets dfa dfa-step ] slurp/replenish-deque
     in-sets
     out-sets ; inline
 

diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor
index 6a5be04260c5ba7996aeb32fa204dc7a510d58a8..6fcef868e262d23f9abeb858fd28ece4e4a7d54b 100644 (file)
--- a/basis/compiler/cfg/linearization/linearization-tests.factor
+++ b/basis/compiler/cfg/linearization/linearization-tests.factor
@@ -1,7 +1,9 @@
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
-compiler.cfg.utilities kernel accessors sequences sets tools.test namespaces ;
+USING: accessors compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+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

diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index c1b60a5017b8558d5c66a2c9b6bb1deb67628cd0..00fc5f6e6c70c17a9ee6a290a220331de4879e7d 100644 (file)
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/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 -- )
-    dup visited get ?adjoin [
-        [ , ]
-        [ sorted-successors [ process-successor ] each ]
-        bi
-    ] [ drop ] if ;
+: process-block ( bb -- bbs )
+    dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
+    [ predecessors-ready? ] filter
+    [ dup loop-entry? [ find-alternate-loop-head ] when ] map
+    [ visited? not ] filter ;
 
 : (linearization-order) ( cfg -- bbs )
-    init-linearization-order
-
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
+    HS{ } clone visited set
+    entry>> <dlist> [ push-back ] keep
+    [ [ process-block ] slurp/replenish-deque ] { } make ;
 
 PRIVATE>
 

diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor
index b3ffd88ad07bcc1cd4fcb337f9d7f25961e28f1b..acdc780ddb875afb535abc1f67cb3c9474a9fa34 100644 (file)
--- a/basis/compiler/cfg/liveness/liveness-tests.factor
+++ b/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

diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 16e22ecaff7ead58a0d6b9b30c62ab2f9660c0e9..8b57ff1834c2db5a9407422dc3a2b36c76a23e8b 100644 (file)
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/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
-compiler.cfg.instructions compiler.cfg.predecessors
+USING: accessors assocs combinators combinators.short-circuit
+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
-    [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
-    members ;
+    keys V{ } clone HS{ } clone
+    [ '[ _ _ visit-gc-root ] each ] 2keep members ;
 
 : fill-gc-map ( live-set gc-map -- )
-    [ representations get [ gc-roots ] [ drop f f ] if ] dip
-    [ gc-roots<< ] [ derived-roots<< ] bi ;
+    [ gc-roots ] dip [ 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 -- )
-    dup update-live-out [
-        dup update-live-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
+: update-live-out/in ( basic-block -- changed? )
+    { [ update-live-out ] [ update-live-in ] } 1&& ;
 
-: compute-live-sets ( cfg -- )
-    <hashed-dlist> work-list set
+: liveness-step ( basic-block -- basic-blocks )
+    [ 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-insns ]
-    [ post-order add-to-work-list ] tri
-    work-list get [ liveness-step ] slurp-deque ;
+: compute-live-sets ( cfg -- )
+    init-liveness
+    dup needs-predecessors dup compute-insns
+    post-order <hashed-dlist> [ push-all-front ] keep
+    [ liveness-step ] slurp/replenish-deque ;
 
 : live-in? ( vreg bb -- ? ) live-in key? ;
 

diff --git a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor
index 337a51c164f18c0bce2bcd98e0d2e46e1d4dc1b5..82b8a46975b8b078ba65e203f096b9c33a42cf9f 100644 (file)
--- a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor
+++ b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor
@@ -1,7 +1,22 @@
-USING: compiler.cfg compiler.cfg.loop-detection compiler.cfg.debugger
-compiler.cfg.predecessors compiler.cfg.utilities tools.test kernel namespaces
-accessors ;
+USING: accessors compiler.cfg compiler.cfg.loop-detection
+compiler.cfg.loop-detection.private compiler.cfg.debugger
+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

diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor
index 31b3f5f42b18363b25c7b29e4bedc47a56bd946a..a8a90377ef5ccb90bf83821a86102f7cc0daf1dc 100644 (file)
--- a/basis/compiler/cfg/loop-detection/loop-detection.factor
+++ b/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
-deques dlists fry kernel namespaces sequences sets ;
+USING: accessors assocs combinators.short-circuit compiler.cfg
+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 -- )
-    2dup blocks>> ?adjoin [
-        2dup header>> eq? [ 2drop ] [
-            drop predecessors>> work-list get push-all-front
-        ] if
-    ] [ 2drop ] if ;
+: process-loop-block ( bb loop -- bbs )
+    dupd { [ blocks>> ?adjoin ] [ header>> eq? not ] } 2&&
+    swap predecessors>> { } ? ;
 
 : process-loop-ends ( loop -- )
-    [ ends>> members <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
-    '[ _ process-loop-block ] slurp-deque ;
+    dup ends>> members <dlist> [ push-all-front ] keep
+    swap '[ _ process-loop-block ] slurp/replenish-deque ;
 
 : process-loop-headers ( -- )
     loops get values [ process-loop-ends ] each ;

diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index ef6c17d6f291255eab376adf642e56af63d789f5..e85da321c4dd76acdcc84b115ce79faf89013c2b 100644 (file)
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/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