From: Daniel Ehrenberg Date: Tue, 22 Sep 2009 21:09:33 +0000 (-0500) Subject: Merge branch 'master' of git://factorcode.org/git/factor into constraints X-Git-Tag: 0.97~5495^2~1 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=45ba559ce49c5ba11403d758b8abef740a83675b;hp=b0f87fd6a0eea7782137a76b77ad3b515de7eaab Merge branch 'master' of git://factorcode.org/git/factor into constraints --- diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index f2613022fc..5756f78bfd 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns -stack-checker.branches +stack-checker.branches locals compiler.utilities compiler.tree compiler.tree.combinators @@ -82,6 +82,13 @@ M: #phi propagate-before ( #phi -- ) [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; +:: update-constraints ( new old -- ) + new [| key value | key old [ value append ] change-at ] assoc-each ; + +: include-child-constraints ( i -- ) + infer-children-data get nth constraints swap at last + constraints get last update-constraints ; + : branch-phi-constraints ( output values booleans -- ) { { @@ -116,22 +123,24 @@ M: #phi propagate-before ( #phi -- ) swap t--> ] } - ! { - ! { { t f } { } } - ! [ B - ! first - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } - ! { - ! { { } { t f } } - ! [ - ! second - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } + { + { { t f } { } } + [ + first + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 0 include-child-constraints + ] + } + { + { { } { t f } } + [ + second + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 1 include-child-constraints + ] + } [ 3drop f ] } case assume ; @@ -147,6 +156,7 @@ M: #phi propagate-after ( #phi -- ) ] [ drop ] if ; M: #phi propagate-around ( #phi -- ) + ! Is this necessary? [ propagate-before ] [ propagate-after ] bi ; M: #branch propagate-around diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 31f6cea148..59c9912e47 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs math math.intervals kernel accessors sequences namespaces classes classes.algebra -combinators words +combinators words combinators.short-circuit compiler.tree compiler.tree.propagation.info compiler.tree.propagation.copy ; @@ -28,15 +28,19 @@ M: object satisfied? drop f ; ! Boolean constraints TUPLE: true-constraint value ; -: =t ( value -- constriant ) resolve-copy true-constraint boa ; +: =t ( value -- constraint ) resolve-copy true-constraint boa ; + +: follow-implications ( constraint -- ) + constraints get assoc-stack [ assume ] when* ; M: true-constraint assume* [ \ f class-not swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: true-constraint satisfied? - value>> value-info class>> true-class? ; + value>> value-info class>> + { [ true-class? ] [ null-class? not ] } 1&& ; TUPLE: false-constraint value ; @@ -44,11 +48,12 @@ TUPLE: false-constraint value ; M: false-constraint assume* [ \ f swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: false-constraint satisfied? - value>> value-info class>> false-class? ; + value>> value-info class>> + { [ false-class? ] [ null-class? not ] } 1&& ; ! Class constraints TUPLE: class-constraint value class ; @@ -82,7 +87,7 @@ TUPLE: implication p q ; C: --> implication -: assume-implication ( p q -- ) +: assume-implication ( q p -- ) [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0a04b48160..53b2109bbb 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -302,7 +302,7 @@ SYMBOL: value-infos : refine-value-info ( info value -- ) resolve-copy value-infos get - [ assoc-stack value-info-intersect ] 2keep + [ assoc-stack [ value-info-intersect ] when* ] 2keep last set-at ; : value-literal ( value -- obj ? ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0da234791b..b436b21329 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -764,17 +764,17 @@ MIXIN: empty-mixin [ { word object } declare equal? ] final-classes ] unit-test -! [ V{ string } ] [ -! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes -! ] unit-test +[ V{ string } ] [ + [ dup string? t xor [ "A" throw ] [ ] if ] final-classes +] unit-test -! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test -! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test ! generalize-counter-interval wasn't being called in all the right places. ! bug found by littledan