From 720c4124314a86153074155fce70dca33f24c141 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Nov 2009 03:22:57 -0600
Subject: [PATCH] compiler.tree.propagation: fix bug in constraints that caused
retain stack overflow
---
basis/compiler/tree/propagation/branches/branches.factor | 2 +-
.../tree/propagation/constraints/constraints.factor | 8 ++++----
basis/compiler/tree/propagation/info/info.factor | 5 ++++-
basis/compiler/tree/propagation/propagation-tests.factor | 8 ++++++++
4 files changed, 17 insertions(+), 6 deletions(-)
diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor
index 662059ec1b..8d349128be 100755
--- a/basis/compiler/tree/propagation/branches/branches.factor
+++ b/basis/compiler/tree/propagation/branches/branches.factor
@@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
constraints get last update-constraints ;
: branch-phi-constraints ( output values booleans -- )
- {
+ {
{
{ { t } { f } }
[
diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor
index 59c9912e47..617352d699 100644
--- a/basis/compiler/tree/propagation/constraints/constraints.factor
+++ b/basis/compiler/tree/propagation/constraints/constraints.factor
@@ -39,8 +39,8 @@ M: true-constraint assume*
bi ;
M: true-constraint satisfied?
- value>> value-info class>>
- { [ true-class? ] [ null-class? not ] } 1&& ;
+ value>> value-info*
+ [ class>> true-class? ] [ drop f ] if ;
TUPLE: false-constraint value ;
@@ -52,8 +52,8 @@ M: false-constraint assume*
bi ;
M: false-constraint satisfied?
- value>> value-info class>>
- { [ false-class? ] [ null-class? not ] } 1&& ;
+ value>> value-info*
+ [ class>> false-class? ] [ drop f ] if ;
! Class constraints
TUPLE: class-constraint value class ;
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 9030914e34..6dcf6f7317 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -294,8 +294,11 @@ DEFER: (value-info-union)
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
+: value-info* ( value -- info ? )
+ resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
+
: value-info ( value -- info )
- resolve-copy value-infos get assoc-stack null-info or ;
+ value-info* drop ;
: set-value-info ( info value -- )
resolve-copy value-infos get last set-at ;
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index e3f509914b..c7e02aef4c 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -239,6 +239,14 @@ IN: compiler.tree.propagation.tests
] final-classes
] unit-test
+[ ] [
+ [
+ dup dup dup [ 100 < ] [ drop f ] if dup
+ [ 2drop f ] [ 2drop f ] if
+ [ ] [ dup [ ] [ ] if ] if
+ ] final-info drop
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare (clone) ] final-classes
] unit-test