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