Debugging slot propagation, starting recursive propagation
parent
99522d1090
commit
e5b9c8287e
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue