From 6e936bdb05e1f506a504d4fa525c5cd156f28fb5 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Tue, 22 Sep 2009 16:01:14 -0500
Subject: [PATCH] Fixing failing unit tests in compiler.tree.propagation due to
constraints
---
.../tree/propagation/branches/branches.factor | 44 ++++++++++++-------
.../constraints/constraints.factor | 19 +++++---
.../tree/propagation/info/info.factor | 2 +-
.../tree/propagation/propagation-tests.factor | 14 +++---
4 files changed, 47 insertions(+), 32 deletions(-)
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 <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 ;
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 1b24bc0c8f..e7cb1b270a 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -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