Fix infinite fixed point iteration bug found by littledan; generalize-counter-interval wasn't called in all the right places
parent
d08dd2ba20
commit
4fdb5d0557
|
@ -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 -- ? )
|
||||
{
|
||||
|
|
|
@ -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
|
|
@ -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 )
|
||||
|
|
Loading…
Reference in New Issue