diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 28f34cb425..ef9e4e8f0b 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry kernel sequences assocs accessors namespaces +USING: fry kernel sequences assocs accessors math.intervals arrays classes.algebra combinators columns -stack-checker.branches locals math +stack-checker.branches locals math namespaces compiler.utilities compiler.tree compiler.tree.combinators @@ -10,6 +10,8 @@ compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.simple compiler.tree.propagation.constraints ; +FROM: sets => union ; +FROM: assocs => change-at ; IN: compiler.tree.propagation.branches ! For conditionals, an assoc of child node # --> constraint @@ -90,7 +92,7 @@ M: #phi propagate-before ( #phi -- ) bi ; :: update-constraints ( new old -- ) - new [| key value | key old [ value append ] change-at ] assoc-each ; + new [| key value | key old [ value union ] change-at ] assoc-each ; : include-child-constraints ( i -- ) infer-children-data get nth constraints swap at last diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 617352d699..f9988ba220 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs math math.intervals kernel accessors sequences namespaces classes classes.algebra @@ -87,8 +87,11 @@ TUPLE: implication p q ; C: --> implication +: maybe-add ( elt seq -- seq' ) + 2dup member? [ nip ] [ swap suffix ] if ; + : assume-implication ( q p -- ) - [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] + [ constraints get [ assoc-stack maybe-add ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; M: implication assume*