diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor index 22f53e2488..c483b8bdc6 100644 --- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor +++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor @@ -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 ] [ diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor index 40a8da1562..08fd12f177 100644 --- a/unfinished/compiler/tree/cleanup/cleanup.factor +++ b/unfinished/compiler/tree/cleanup/cleanup.factor @@ -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 diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index de6d6c72cb..c6e7865c48 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor new file mode 100644 index 0000000000..cf72a2a135 --- /dev/null +++ b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor @@ -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 diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 425d5fb26f..c5fb04e322 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -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 ] [ diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 713ac1703f..2924eb4369 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ; bi* value-info-intersect 1array ; : tuple-constructor? ( word -- ? ) - { } memq? ; + { curry compose } 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 ; -: propagate- ( #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- ] [ ] if ; +: propagate- ( #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- ( #call -- info ) in-d>> [ value-info ] map complex ; : propagate-tuple-constructor ( #call word -- infos ) { { \ [ propagate- ] } + { \ curry [ propagate-curry ] } + { \ compose [ propagate-compose ] } { \ [ propagate- ] } } case 1array ; diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor index 3fcbc2d023..3c7ae101e3 100755 --- a/unfinished/stack-checker/stack-checker-tests.factor +++ b/unfinished/stack-checker/stack-checker-tests.factor @@ -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 )