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
2015-04-21 22:45:38 +02:00 · 2015-04-21 22:45:38 +02:00 · 992314d2de
parent c3ca8bd859
commit 992314d2de
8 changed files with 98 additions and 84 deletions
--- 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

--- 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
--- 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>

--- 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
--- 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? ;

--- 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
--- 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 ;
--- 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