diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 0db7e74483..a610498478 100644 --- 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 :> work-list - work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque + cfg needs-predecessors + cfg dfa + [ 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 6a5be04260..6fcef868e2 100644 --- 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 } } [ + 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 c1b60a5017..00fc5f6e6c 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -12,20 +12,10 @@ IN: compiler.cfg.linearization 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>> [ 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>> [ 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 b3ffd88ad0..acdc780ddb 100644 --- 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 [ swap >>number ] map + [ 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 16e22ecaff..8b57ff1834 100644 --- 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 -- ) [ 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 -- ) - 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 [ 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 337a51c164..82b8a46975 100644 --- 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 [ process-loop-block ] keep + blocks>> sets:members + [ [ number>> ] map ] bi@ +] unit-test + +! process-loop-ends +{ } [ + f f 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 31b3f5f42b..a8a90377ef 100644 --- 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 [ push-all-front ] [ work-list set ] [ ] tri ] keep - '[ _ process-loop-block ] slurp-deque ; + dup ends>> members [ 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 ef6c17d6f2..e85da321c4 100644 --- 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 : ( 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