Debugging slot propagation, starting recursive propagation

db4
Slava Pestov 2008-07-26 19:01:43 -05:00
parent 99522d1090
commit e5b9c8287e
6 changed files with 172 additions and 39 deletions

View File

@ -61,3 +61,5 @@ IN: compiler.tree.propagation.info.tests
3 <literal-info> 3 <literal-info>
null <class-info> value-info-union >literal< null <class-info> value-info-union >literal<
] unit-test ] unit-test
[ ] [ { } value-infos-union drop ] unit-test

View File

@ -113,6 +113,8 @@ slots ;
DEFER: value-info-intersect DEFER: value-info-intersect
DEFER: (value-info-intersect)
: intersect-lengths ( info1 info2 -- length ) : intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ { [ length>> ] bi@ {
{ [ dup not ] [ drop ] } { [ dup not ] [ drop ] }
@ -120,10 +122,17 @@ DEFER: value-info-intersect
[ value-info-intersect ] [ value-info-intersect ]
} cond ; } cond ;
: intersect-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-intersect) ]
} cond ;
: intersect-slots ( info1 info2 -- slots ) : intersect-slots ( info1 info2 -- slots )
[ slots>> ] bi@ [ slots>> ] bi@
2dup [ length ] bi@ = 2dup [ length ] bi@ =
[ [ value-info-intersect ] 2map ] [ 2drop f ] if ; [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
: (value-info-intersect) ( info1 info2 -- info ) : (value-info-intersect) ( info1 info2 -- info )
[ <value-info> ] 2dip [ <value-info> ] 2dip
@ -150,6 +159,8 @@ DEFER: value-info-intersect
DEFER: value-info-union DEFER: value-info-union
DEFER: (value-info-union)
: union-lengths ( info1 info2 -- length ) : union-lengths ( info1 info2 -- length )
[ length>> ] bi@ { [ length>> ] bi@ {
{ [ dup not ] [ nip ] } { [ dup not ] [ nip ] }
@ -157,10 +168,17 @@ DEFER: value-info-union
[ value-info-union ] [ value-info-union ]
} cond ; } cond ;
: union-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-union) ]
} cond ;
: union-slots ( info1 info2 -- slots ) : union-slots ( info1 info2 -- slots )
[ slots>> ] bi@ [ slots>> ] bi@
2dup [ length ] bi@ = 2dup [ length ] bi@ =
[ [ value-info-union ] 2map ] [ 2drop f ] if ; [ [ union-slot ] 2map ] [ 2drop f ] if ;
: (value-info-union) ( info1 info2 -- info ) : (value-info-union) ( info1 info2 -- info )
[ <value-info> ] 2dip [ <value-info> ] 2dip
@ -181,7 +199,9 @@ DEFER: value-info-union
} cond ; } cond ;
: value-infos-union ( infos -- info ) : value-infos-union ( infos -- info )
dup first [ value-info-union ] reduce ; dup empty?
[ drop null <class-info> ]
[ dup first [ value-info-union ] reduce ] if ;
! Current value --> info mapping ! Current value --> info mapping
SYMBOL: value-infos SYMBOL: value-infos

View File

@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
math.partial-dispatch math.intervals math.parser math.order math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals 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.info compiler.tree.propagation.nodes
compiler.tree.propagation.constraints compiler.tree.propagation.constraints
compiler.tree.propagation.slots
compiler.tree.comparisons ; compiler.tree.comparisons ;
IN: compiler.tree.propagation.known-words IN: compiler.tree.propagation.known-words
@ -258,3 +259,8 @@ generic-comparison-ops [
! the output of clone has the same type as the input ! the output of clone has the same type as the input
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each { clone (clone) } [ [ ] +outputs+ set-word-prop ] each
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
] +outputs+ set-word-prop

View File

@ -3,8 +3,8 @@ compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra math.functions math.private byte-arrays classes.algebra classes.tuple.private
strings ; math.functions math.private strings layouts ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
\ propagate must-infer \ propagate must-infer
@ -235,12 +235,39 @@ IN: compiler.tree.propagation.tests
[ [ 1 ] [ 1 ] if 1 + ] final-literals [ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test ] unit-test
[ V{ object } ] [
[ 0 * 10 < ] final-classes
] unit-test
[ V{ string string } ] [ [ V{ string string } ] [
[ [
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] final-classes ] final-classes
] unit-test ] 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 ! Array length propagation
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test [ V{ t } ] [ [ 10 f <array> 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 [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test ] unit-test
[ V{ tuple-layout } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test
! Mixed mutable and immutable slots ! Mixed mutable and immutable slots
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; 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 [ x>> ] [ y>> ] bi
] final-classes ] final-classes
] unit-test ] 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

View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.propagation.nodes compiler.tree.propagation.nodes
@ -14,23 +15,48 @@ IN: compiler.tree.propagation.recursive
! We need to compute scalar evolution so that sccp doesn't ! We need to compute scalar evolution so that sccp doesn't
! evaluate loops ! 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 ; [ [ 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? ) : propagate-recursive-phi ( label #phi -- )
[ (merge-value-infos) ] dip "propagate-recursive-phi" print
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ; [ [ 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 ;
: 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 ;
USING: namespaces math ;
SYMBOL: iter-counter
0 iter-counter set-global
M: #recursive propagate-around ( #recursive -- ) M: #recursive propagate-around ( #recursive -- )
dup "#recursive" print
node-child iter-counter inc
[ first>> (propagate) ] [ propagate-recursive-phi ] bi iter-counter get 10 > [ "Oops" throw ] when
[ drop ] [ propagate-around ] if ; [ 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 -- ) 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 <class-info> 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 ;

View File

@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
: tuple-constructor? ( node -- ? ) : tuple-constructor? ( node -- ? )
word>> { <tuple-boa> <complex> } memq? ; word>> { <tuple-boa> <complex> } memq? ;
: read-only-slots ( values class -- slots )
#! Delegation.
all-slots rest-slice
[ read-only>> [ drop f ] unless ] 2map
{ f f } prepend ;
: fold-<tuple-boa> ( values class -- info )
[ , f , [ literal>> ] map % ] { } make >tuple
<literal-info> ;
: propagate-<tuple-boa> ( node -- info ) : propagate-<tuple-boa> ( node -- info )
#! Delegation #! Delegation
in-d>> [ value-info ] map unclip-last in-d>> [ value-info ] map unclip-last
literal>> class>> dup immutable-tuple-class? [ literal>> class>> [ read-only-slots ] keep
over [ literal?>> ] all? over 2 tail-slice [ dup [ literal?>> ] when ] all? [
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ] [ 2 tail-slice ] dip fold-<tuple-boa>
[ <tuple-info> ] ] [
if <tuple-info>
] [ nip <class-info> ] if ; ] if ;
: propagate-<complex> ( node -- info ) : propagate-<complex> ( node -- info )
in-d>> [ value-info ] map complex <tuple-info> ; in-d>> [ value-info ] map complex <tuple-info> ;
@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ;
[ [ class>> ] [ object ] if* class-or ] reduce [ [ class>> ] [ object ] if* class-or ] reduce
<class-info> ; <class-info> ;
: tuple>array* ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
prefix ;
: literal-info-slot ( slot info -- info' )
{
{ [ dup tuple? ] [
tuple>array* nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond ;
: value-info-slot ( slot info -- info' ) : value-info-slot ( slot info -- info' )
#! Delegation. #! Delegation.
[ class>> complex class<= 1 3 ? - ] keep {
dup literal?>> [ { [ over 0 = ] [ 2drop fixnum <class-info> ] }
literal>> { { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
{ [ dup tuple? ] [ [ [ 1- ] [ slots>> ] bi* ?nth ]
tuple-slots 1 tail-slice nth <literal-info> } cond ;
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond
] [ slots>> ?nth ] if ;
: reader-word-outputs ( node -- infos ) : reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi [ relevant-slots ] [ in-d>> first ] bi