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>
null <class-info> value-info-union >literal<
] unit-test
[ ] [ { } value-infos-union drop ] unit-test

View File

@ -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 )
[ <value-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 )
[ <value-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 <class-info> ]
[ dup first [ value-info-union ] reduce ] if ;
! Current value --> info mapping
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
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 <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
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 <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
] 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

View File

@ -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 <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 -- ? )
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 )
#! Delegation
in-d>> [ value-info ] map unclip-last
literal>> class>> dup immutable-tuple-class? [
over [ literal?>> ] all?
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
[ <tuple-info> ]
if
] [ nip <class-info> ] if ;
literal>> class>> [ read-only-slots ] keep
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
[ 2 tail-slice ] dip fold-<tuple-boa>
] [
<tuple-info>
] if ;
: propagate-<complex> ( node -- 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-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' )
#! Delegation.
[ class>> complex class<= 1 3 ? - ] keep
dup literal?>> [
literal>> {
{ [ dup tuple? ] [
tuple-slots 1 tail-slice nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond
] [ slots>> ?nth ] if ;
{
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
[ [ 1- ] [ slots>> ] bi* ?nth ]
} cond ;
: reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi