diff --git a/basis/compiler/cfg/dependence/dependence-tests.factor b/basis/compiler/cfg/dependence/dependence-tests.factor index 1aa27c4c9a..aaa6820d45 100644 --- a/basis/compiler/cfg/dependence/dependence-tests.factor +++ b/basis/compiler/cfg/dependence/dependence-tests.factor @@ -42,23 +42,18 @@ ERROR: node-missing-children trees nodes ; : flatten-tree ( node -- nodes ) [ children>> [ flatten-tree ] map concat ] keep suffix ; -: verify-parents ( nodes trees -- ) - 2dup '[ [ parent>> ] [ _ member? ] bi or ] all? - [ 2drop ] [ node-missing-parent ] if ; - : verify-children ( nodes trees -- ) 2dup [ flatten-tree ] map concat { [ [ length ] same? ] [ set= ] } 2&& [ 2drop ] [ node-missing-children ] if ; -: verify-trees ( nodes trees -- ) - [ verify-parents ] [ verify-children ] 2bi ; - -{ } [ 2node-tree 1array dup verify-parents ] unit-test +{ } [ + 2node-tree [ flatten-tree ] keep 1array verify-children +] unit-test [ - 2node-tree 1array { } verify-parents -] [ node-missing-parent? ] must-fail-with + 2node-tree 1array { } verify-children +] [ node-missing-children? ] must-fail-with { 1 } [ 3node-tree children>> length ] unit-test @@ -69,7 +64,7 @@ ERROR: node-missing-children trees nodes ; ] [ node-missing-children? ] must-fail-with [ - { } 3node-tree 1array verify-trees + { } 3node-tree 1array verify-children ] [ node-missing-children? ] must-fail-with ! select-parent tests @@ -109,12 +104,6 @@ ERROR: node-missing-children trees nodes ; ##replace } [ [ new ] [ 2 * ] bi* >>insn# ] map-index ; -{ 7 } [ - test-not-in-order [ ] map dup - build-dependence-graph - make-trees length -] unit-test - ! Another { t } [ 100 [ @@ -132,6 +121,7 @@ ERROR: node-missing-children trees nodes ; ] unit-test : test-some-kind-of-dep ( -- insns ) + 0 node-number set-global V{ T{ ##peek { dst 275 } { loc D 2 } } T{ ##load-tagged { dst 277 } { val 0 } } @@ -179,4 +169,18 @@ ERROR: node-missing-children trees nodes ; { slot 2 } { tag 7 } } - } [ 2 * >>insn# ] map-index ; + } [ 2 * >>insn# ] map-index [ ] map ; + +{ 7 } [ + test-not-in-order [ ] map + dup build-dependence-graph + dup build-fan-in-trees + [ parent-index>> -1/0. = ] count +] unit-test + +{ V{ 1 4 7 8 } } [ + test-some-kind-of-dep + dup build-dependence-graph + dup build-fan-in-trees + [ parent-index>> -1/0. = ] filter [ number>> ] map +] unit-test diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index 97c381dff4..4171bb2e41 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers fry kernel locals -namespaces sequences sorting make math math.vectors vectors ; +namespaces sequences sorting make math math.vectors sets vectors ; FROM: namespaces => set ; IN: compiler.cfg.dependence @@ -11,10 +11,7 @@ SYMBOL: node-number SYMBOL: +data+ SYMBOL: +control+ -TUPLE: node - number insn precedes - children parent - registers parent-index ; +TUPLE: node number insn precedes children registers parent-index ; M: node equal? over node? [ [ number>> ] same? ] [ 2drop f ] if ; @@ -85,8 +82,8 @@ M: object add-control-edge 2drop ; : keys-for ( assoc value -- keys ) '[ nip _ = ] assoc-filter keys ; -: attach-parent ( node parent -- ) - [ >>parent drop ] [ [ ?push ] change-children drop ] 2bi ; +: attach-parent ( child parent -- ) + [ ?push ] change-children drop ; ! Arbitrary tie-breaker to make the ordering deterministic. : tiebreak-parents ( nodes -- node/f ) @@ -100,11 +97,9 @@ M: object add-control-edge 2drop ; : maybe-set-parent ( node -- ) dup precedes>> select-parent [ attach-parent ] [ drop ] if* ; -: make-trees ( nodes -- trees ) - [ [ maybe-set-parent ] each ] [ [ parent>> not ] filter ] bi ; - : initialize-scores ( trees -- ) [ -1/0. >>parent-index calculate-registers drop ] each ; : build-fan-in-trees ( nodes -- ) - make-trees initialize-scores ; + dup [ maybe-set-parent ] each + dup [ children>> ] map concat diff initialize-scores ;