compiler.tree.propagation: fix bug in constraints that caused retain stack overflow
parent
8dd8d70500
commit
720c412431
|
@ -97,7 +97,7 @@ M: #phi propagate-before ( #phi -- )
|
||||||
constraints get last update-constraints ;
|
constraints get last update-constraints ;
|
||||||
|
|
||||||
: branch-phi-constraints ( output values booleans -- )
|
: branch-phi-constraints ( output values booleans -- )
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
{ { t } { f } }
|
{ { t } { f } }
|
||||||
[
|
[
|
||||||
|
|
|
@ -39,8 +39,8 @@ M: true-constraint assume*
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: true-constraint satisfied?
|
M: true-constraint satisfied?
|
||||||
value>> value-info class>>
|
value>> value-info*
|
||||||
{ [ true-class? ] [ null-class? not ] } 1&& ;
|
[ class>> true-class? ] [ drop f ] if ;
|
||||||
|
|
||||||
TUPLE: false-constraint value ;
|
TUPLE: false-constraint value ;
|
||||||
|
|
||||||
|
@ -52,8 +52,8 @@ M: false-constraint assume*
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: false-constraint satisfied?
|
M: false-constraint satisfied?
|
||||||
value>> value-info class>>
|
value>> value-info*
|
||||||
{ [ false-class? ] [ null-class? not ] } 1&& ;
|
[ class>> false-class? ] [ drop f ] if ;
|
||||||
|
|
||||||
! Class constraints
|
! Class constraints
|
||||||
TUPLE: class-constraint value class ;
|
TUPLE: class-constraint value class ;
|
||||||
|
|
|
@ -294,8 +294,11 @@ DEFER: (value-info-union)
|
||||||
! Assoc stack of current value --> info mapping
|
! Assoc stack of current value --> info mapping
|
||||||
SYMBOL: value-infos
|
SYMBOL: value-infos
|
||||||
|
|
||||||
|
: value-info* ( value -- info ? )
|
||||||
|
resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
|
||||||
|
|
||||||
: value-info ( value -- info )
|
: value-info ( value -- info )
|
||||||
resolve-copy value-infos get assoc-stack null-info or ;
|
value-info* drop ;
|
||||||
|
|
||||||
: set-value-info ( info value -- )
|
: set-value-info ( info value -- )
|
||||||
resolve-copy value-infos get last set-at ;
|
resolve-copy value-infos get last set-at ;
|
||||||
|
|
|
@ -239,6 +239,14 @@ IN: compiler.tree.propagation.tests
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] 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 } ] [
|
[ V{ fixnum } ] [
|
||||||
[ { fixnum } declare (clone) ] final-classes
|
[ { fixnum } declare (clone) ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
Loading…
Reference in New Issue