Fixing failing unit tests in compiler.tree.propagation due to constraints
Daniel Ehrenberg
parent
699695ba14
commit
6e936bdb05
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <class-info> 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 <class-info> 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ? )
|
||||
|
|
|
|||
|
|
@ -694,17 +694,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
|
||||
|
|
|
|||
Loading…
Reference in New Issue