From 4fdb5d05576c326b13f3a189fdfc7348573505bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Mar 2009 17:30:24 -0500
Subject: [PATCH] Fix infinite fixed point iteration bug found by littledan;
 generalize-counter-interval wasn't called in all the right places

---
 .../tree/propagation/info/info.factor         |  2 +-
 .../tree/propagation/propagation-tests.factor | 33 +++++++++++++++++++
 .../propagation/recursive/recursive.factor    | 11 +++++--
 3 files changed, 42 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 7b1723620b..c56db570b2 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -238,7 +238,7 @@ DEFER: (value-info-union)
 
 : value-infos-union ( infos -- info )
     [ null-info ]
-    [ dup first [ value-info-union ] reduce ] if-empty ;
+    [ unclip-slice [ value-info-union ] reduce ] if-empty ;
 
 : literals<= ( info1 info2 -- ? )
     {
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 52ae83eb12..5dd647ae89 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -655,3 +655,36 @@ MIXIN: empty-mixin
 ! [ 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
+
+! generalize-counter-interval wasn't being called in all the right places.
+! bug found by littledan
+
+TUPLE: littledan-1 { a read-only } ;
+
+: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+
+: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
+
+[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
+
+TUPLE: littledan-2 { from read-only } { to read-only } ;
+
+: (littledan-2-test) ( x -- i elt )
+    [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
+
+: littledan-2-test ( x -- i elt )
+    [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
+
+[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
+
+: (littledan-3-test) ( x -- )
+    length 1+ f <array> (littledan-3-test) ; inline recursive
+
+: littledan-3-test ( x -- )
+    0 f <array> (littledan-3-test) ; inline
+
+[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
+
+[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
+
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index ff9f262d28..1bcd36f6b0 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive
     } cond interval-union nip ;
 
 : generalize-counter ( info' initial -- info )
-    2dup [ class>> null-class? ] either? [ drop ] [
-        [ drop clone ] [ [ interval>> ] bi@ ] 2bi
-        generalize-counter-interval >>interval
+    2dup [ not ] either? [ drop ] [
+        2dup [ class>> null-class? ] either? [ drop ] [
+            [ clone ] dip
+            [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+            [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
+            [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+            tri
+        ] if
     ] if ;
 
 : unify-recursive-stacks ( stacks initial -- infos )