diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 41da9e6014..64d32ce458 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -61,3 +61,5 @@ IN: compiler.tree.propagation.info.tests 3 null value-info-union >literal< ] unit-test + +[ ] [ { } value-infos-union drop ] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index dc24b58bce..6f78ba645e 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -113,6 +113,8 @@ slots ; DEFER: value-info-intersect +DEFER: (value-info-intersect) + : intersect-lengths ( info1 info2 -- length ) [ length>> ] bi@ { { [ dup not ] [ drop ] } @@ -120,10 +122,17 @@ DEFER: value-info-intersect [ value-info-intersect ] } cond ; +: intersect-slot ( info1 info2 -- info ) + { + { [ dup not ] [ nip ] } + { [ over not ] [ drop ] } + [ (value-info-intersect) ] + } cond ; + : intersect-slots ( info1 info2 -- slots ) [ slots>> ] bi@ 2dup [ length ] bi@ = - [ [ value-info-intersect ] 2map ] [ 2drop f ] if ; + [ [ intersect-slot ] 2map ] [ 2drop f ] if ; : (value-info-intersect) ( info1 info2 -- info ) [ ] 2dip @@ -150,6 +159,8 @@ DEFER: value-info-intersect DEFER: value-info-union +DEFER: (value-info-union) + : union-lengths ( info1 info2 -- length ) [ length>> ] bi@ { { [ dup not ] [ nip ] } @@ -157,10 +168,17 @@ DEFER: value-info-union [ value-info-union ] } cond ; +: union-slot ( info1 info2 -- info ) + { + { [ dup not ] [ nip ] } + { [ over not ] [ drop ] } + [ (value-info-union) ] + } cond ; + : union-slots ( info1 info2 -- slots ) [ slots>> ] bi@ 2dup [ length ] bi@ = - [ [ value-info-union ] 2map ] [ 2drop f ] if ; + [ [ union-slot ] 2map ] [ 2drop f ] if ; : (value-info-union) ( info1 info2 -- info ) [ ] 2dip @@ -181,7 +199,9 @@ DEFER: value-info-union } cond ; : value-infos-union ( infos -- info ) - dup first [ value-info-union ] reduce ; + dup empty? + [ drop null ] + [ dup first [ value-info-union ] reduce ] if ; ! Current value --> info mapping SYMBOL: value-infos diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index bfdcff51c5..eef34f6f8f 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals -classes.tuple alien.accessors classes.tuple.private +classes.tuple alien.accessors classes.tuple.private slots.private compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.constraints +compiler.tree.propagation.slots compiler.tree.comparisons ; IN: compiler.tree.propagation.known-words @@ -258,3 +259,8 @@ generic-comparison-ops [ ! the output of clone has the same type as the input { clone (clone) } [ [ ] +outputs+ set-word-prop ] each + +\ slot [ + dup literal?>> + [ literal>> swap value-info-slot ] [ 2drop object ] if +] +outputs+ set-word-prop diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 82f8ce1e4d..659f9d6e76 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -3,8 +3,8 @@ compiler.tree.propagation compiler.tree.copy-equiv compiler.tree.def-use tools.test math math.order accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private -byte-arrays classes.algebra math.functions math.private -strings ; +byte-arrays classes.algebra classes.tuple.private +math.functions math.private strings layouts ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -235,12 +235,39 @@ IN: compiler.tree.propagation.tests [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test +[ V{ object } ] [ + [ 0 * 10 < ] final-classes +] unit-test + [ V{ string string } ] [ [ 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop ] final-classes ] unit-test +[ V{ float } ] [ + [ { real float } declare + ] final-classes +] unit-test + +[ V{ float } ] [ + [ { float real } declare + ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ { fixnum } declare 1 swap 7 bitand shift ] final-classes +] unit-test + +cell-bits 32 = [ + [ V{ integer } ] [ + [ { fixnum } declare 1 swap 31 bitand shift ] + final-classes + ] unit-test +] when + ! Array length propagation [ V{ t } ] [ [ 10 f length 10 = ] final-literals ] unit-test @@ -323,6 +350,10 @@ TUPLE: mutable-tuple-test { x sequence } ; [ T{ mutable-tuple-test f "hey" } x>> ] final-classes ] unit-test +[ V{ tuple-layout } ] [ + [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes +] unit-test + ! Mixed mutable and immutable slots TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; @@ -332,3 +363,32 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ x>> ] [ y>> ] bi ] final-classes ] unit-test + +! Recursive propagation +: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive + +[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test + +: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive + +[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test + +: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive + +[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test + +[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test + +[ V{ float } ] [ + [ { float } declare 10 [ 2.3 * ] times ] final-classes +] unit-test + +: recursive-test-4 ( i n -- ) + 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive + +[ ] [ [ recursive-test-4 ] final-info drop ] unit-test + +: recursive-test-5 ( a -- b ) + dup 2 > [ dup 1 - recursive-test-5 * ] when ; inline recursive + +[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 731b0d06f7..1871717036 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors +USING: kernel sequences accessors arrays +stack-checker.inlining compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -14,23 +15,48 @@ IN: compiler.tree.propagation.recursive ! We need to compute scalar evolution so that sccp doesn't ! evaluate loops -: (merge-value-infos) ( inputs -- infos ) +! row polymorphism is causing problems + +! infer-branch cloning and subsequent loss of state causing problems + +: merge-value-infos ( inputs -- infos ) [ [ value-info ] map value-infos-union ] map ; +USE: io +: compute-fixed-point ( label infos outputs -- ) + 2dup [ length ] bi@ = [ "Wrong length" throw ] unless + "compute-fixed-point" print USE: prettyprint + 2dup [ value-info ] map 2dup . . [ = ] 2all? [ 3drop ] [ + [ set-value-info ] 2each + f >>fixed-point drop + ] if ; -: merge-value-infos ( inputs outputs -- fixed-point? ) - [ (merge-value-infos) ] dip - [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ; - -: propagate-recursive-phi ( #phi -- fixed-point? ) - [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] - [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ] - bi and ; +: propagate-recursive-phi ( label #phi -- ) + "propagate-recursive-phi" print + [ [ phi-in-d>> merge-value-infos ] [ out-d>> ] bi compute-fixed-point ] + [ [ phi-in-r>> merge-value-infos ] [ out-r>> ] bi compute-fixed-point ] 2bi ; +USING: namespaces math ; +SYMBOL: iter-counter +0 iter-counter set-global M: #recursive propagate-around ( #recursive -- ) - dup - node-child - [ first>> (propagate) ] [ propagate-recursive-phi ] bi - [ drop ] [ propagate-around ] if ; + "#recursive" print + iter-counter inc + iter-counter get 10 > [ "Oops" throw ] when + [ label>> ] keep + [ node-child first>> propagate-recursive-phi ] + [ [ t >>fixed-point drop ] [ node-child first>> (propagate) ] bi* ] + [ swap fixed-point>> [ drop ] [ propagate-around ] if ] + 2tri ; USE: assocs M: #call-recursive propagate-before ( #call-label -- ) - [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ; + [ label>> ] [ label>> return>> [ value-info ] map ] [ out-d>> ] tri + dup [ dup value-infos get at [ drop ] [ object swap set-value-info ] if ] each + 2dup min-length [ tail* ] curry bi@ + compute-fixed-point ; + +M: #return propagate-before ( #return -- ) + "#return" print + dup label>> [ + [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri + compute-fixed-point + ] [ drop ] if ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index df10626967..663b0e12b8 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ; : tuple-constructor? ( node -- ? ) word>> { } memq? ; +: read-only-slots ( values class -- slots ) + #! Delegation. + all-slots rest-slice + [ read-only>> [ drop f ] unless ] 2map + { f f } prepend ; + +: fold- ( values class -- info ) + [ , f , [ literal>> ] map % ] { } make >tuple + ; + : propagate- ( node -- info ) #! Delegation in-d>> [ value-info ] map unclip-last - literal>> class>> dup immutable-tuple-class? [ - over [ literal?>> ] all? - [ [ , f , [ literal>> ] map % ] { } make >tuple ] - [ ] - if - ] [ nip ] if ; + literal>> class>> [ read-only-slots ] keep + over 2 tail-slice [ dup [ literal?>> ] when ] all? [ + [ 2 tail-slice ] dip fold- + ] [ + + ] if ; : propagate- ( node -- info ) in-d>> [ value-info ] map complex ; @@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ; [ [ class>> ] [ object ] if* class-or ] reduce ; +: tuple>array* ( tuple -- array ) + prepare-tuple>array + >r copy-tuple-slots r> + prefix ; + +: literal-info-slot ( slot info -- info' ) + { + { [ dup tuple? ] [ + tuple>array* nth + ] } + { [ dup complex? ] [ + [ real-part ] [ imaginary-part ] bi + 2array nth + ] } + } cond ; + : value-info-slot ( slot info -- info' ) #! Delegation. - [ class>> complex class<= 1 3 ? - ] keep - dup literal?>> [ - literal>> { - { [ dup tuple? ] [ - tuple-slots 1 tail-slice nth - ] } - { [ dup complex? ] [ - [ real-part ] [ imaginary-part ] bi - 2array nth - ] } - } cond - ] [ slots>> ?nth ] if ; + { + { [ over 0 = ] [ 2drop fixnum ] } + { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] } + [ [ 1- ] [ slots>> ] bi* ?nth ] + } cond ; : reader-word-outputs ( node -- infos ) [ relevant-slots ] [ in-d>> first ] bi