diff --git a/basis/compiler/cfg/dependence/dependence-tests.factor b/basis/compiler/cfg/dependence/dependence-tests.factor index b9e9a67ae3..d8fdedfc61 100644 --- a/basis/compiler/cfg/dependence/dependence-tests.factor +++ b/basis/compiler/cfg/dependence/dependence-tests.factor @@ -1,6 +1,7 @@ -USING: accessors arrays compiler.cfg.dependence compiler.cfg.instructions -kernel namespaces sequences tools.test ; +USING: accessors arrays combinators.short-circuit compiler.cfg.dependence +compiler.cfg.instructions fry kernel namespaces sequences tools.test ; IN: compiler.cfg.dependence.tests +FROM: sets => set= ; { V{ @@ -35,13 +36,32 @@ IN: compiler.cfg.dependence.tests 3 iota [ node new swap >>number ] map first3 over attach-parent over attach-parent ; + +! Verification tests +ERROR: node-missing-parent trees nodes ; +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 1array { } verify-parents ] [ node-missing-parent? ] must-fail-with - { 1 } [ 3node-tree children>> length ] unit-test { 3 } [ 3node-tree flatten-tree length ] unit-test diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index 9e0aca0f46..eaddd89133 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2009, 2010 Daniel Ehrenberg. ! 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 sets sorting math.vectors -make math combinators.short-circuit vectors ; +compiler.cfg.instructions compiler.cfg.registers fry kernel locals +namespaces sequences sorting make math math.vectors vectors ; FROM: namespaces => set ; IN: compiler.cfg.dependence @@ -102,10 +101,8 @@ M: object add-control-edge 2drop ; dup node registers<< ; ! Constructing fan-in trees - : attach-parent ( node parent -- ) - [ >>parent drop ] - [ [ ?push ] change-children drop ] 2bi ; + [ >>parent drop ] [ [ ?push ] change-children drop ] 2bi ; : keys-for ( assoc value -- keys ) '[ nip _ = ] assoc-filter keys ; @@ -122,26 +119,8 @@ M: object add-control-edge 2drop ; : make-trees ( nodes -- trees ) [ [ choose-parent ] each ] [ [ parent>> not ] filter ] bi ; -ERROR: node-missing-parent trees nodes ; -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 ; - : build-fan-in-trees ( nodes -- ) - dup make-trees [ verify-trees ] keep [ + make-trees [ -1/0. >>parent-index calculate-registers drop ] each ;