More debugging
parent
65df4739ce
commit
e61f2321d0
|
@ -195,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- )
|
|||
|
||||
M: fixnum annotate-entry-test-1 drop ;
|
||||
|
||||
: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
|
||||
2over >= [
|
||||
3drop
|
||||
: (annotate-entry-test-2) ( from to -- )
|
||||
2dup >= [
|
||||
2drop
|
||||
] [
|
||||
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
|
||||
>r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
|
||||
] if ; inline recursive
|
||||
|
||||
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare [ ] annotate-entry-test-2 ]
|
||||
[ { bignum } declare annotate-entry-test-2 ]
|
||||
\ annotate-entry-test-1 inlined?
|
||||
] unit-test
|
||||
|
||||
|
@ -375,7 +375,7 @@ cell-bits 32 = [
|
|||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 0 [ + ] reduce ]
|
||||
{ < <-integer-fixnum } inlined?
|
||||
{ < <-integer-fixnum nth-unsafe } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
|
|
|
@ -22,7 +22,8 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
[ cleanup* ] map flatten ;
|
||||
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos [ literal?>> ] all? ;
|
||||
node-output-infos dup empty?
|
||||
[ drop f ] [ [ literal?>> ] all? ] if ;
|
||||
|
||||
: cleanup-folding ( #call -- nodes )
|
||||
#! Replace a #call having a known result with a #drop of its
|
||||
|
|
|
@ -520,3 +520,11 @@ M: array iterate first t ;
|
|||
[ V{ POSTPONE: f } ] [
|
||||
[ 3 string? ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare [ ] curry obj>> ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
|
||||
] unit-test
|
||||
|
|
|
@ -0,0 +1,19 @@
|
|||
IN: compiler.tree.propagation.recursive.tests
|
||||
USING: tools.test compiler.tree.propagation.recursive
|
||||
math.intervals kernel ;
|
||||
|
||||
[ T{ interval f { 0 t } { 1/0. t } } ] [
|
||||
T{ interval f { 1 t } { 1 t } }
|
||||
T{ interval f { 0 t } { 0 t } } generalize-counter-interval
|
||||
] unit-test
|
||||
|
||||
[ T{ interval f { -1/0. t } { 10 t } } ] [
|
||||
T{ interval f { -1 t } { -1 t } }
|
||||
T{ interval f { 10 t } { 10 t } } generalize-counter-interval
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ interval f { 1 t } { 268435455 t } }
|
||||
T{ interval f { -268435456 t } { 268435455 t } } tuck
|
||||
generalize-counter-interval =
|
||||
] unit-test
|
|
@ -21,12 +21,12 @@ IN: compiler.tree.propagation.recursive
|
|||
|
||||
: generalize-counter-interval ( interval initial-interval -- interval' )
|
||||
{
|
||||
{ [ 2dup = ] [ empty-interval ] }
|
||||
{ [ 2dup interval-subset? ] [ empty-interval ] }
|
||||
{ [ over empty-interval eq? ] [ empty-interval ] }
|
||||
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
|
||||
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
|
||||
[ [-inf,inf] ]
|
||||
} cond nip interval-union ;
|
||||
} cond interval-union nip ;
|
||||
|
||||
: generalize-counter ( info' initial -- info )
|
||||
2dup [ class>> null-class? ] either? [ drop ] [
|
||||
|
|
|
@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
bi* value-info-intersect 1array ;
|
||||
|
||||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
{ <tuple-boa> curry compose <complex> } memq? ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
|
@ -41,22 +41,33 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
#! Delegation
|
||||
in-d>> [ value-info ] map unclip-last
|
||||
literal>> class>> [ read-only-slots ] keep
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
||||
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ 2 tail-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
#! Delegation
|
||||
in-d>> unclip-last
|
||||
value-info literal>> class>> (propagate-tuple-constructor) ;
|
||||
|
||||
: propagate-curry ( #call -- info )
|
||||
in-d>> \ curry (propagate-tuple-constructor) ;
|
||||
|
||||
: propagate-compose ( #call -- info )
|
||||
in-d>> \ compose (propagate-tuple-constructor) ;
|
||||
|
||||
: propagate-<complex> ( #call -- info )
|
||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||
|
||||
: propagate-tuple-constructor ( #call word -- infos )
|
||||
{
|
||||
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
|
||||
{ \ curry [ propagate-curry ] }
|
||||
{ \ compose [ propagate-compose ] }
|
||||
{ \ <complex> [ propagate-<complex> ] }
|
||||
} case 1array ;
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
|
|||
sorting assocs definitions prettyprint io inspector
|
||||
classes.tuple classes.union classes.predicate debugger
|
||||
threads.private io.streams.string io.timeouts io.thread
|
||||
sequences.private destructors combinators ;
|
||||
sequences.private destructors combinators eval ;
|
||||
IN: stack-checker.tests
|
||||
|
||||
: short-effect ( effect -- pair )
|
||||
|
|
Loading…
Reference in New Issue