Improve branch folding

db4
Slava Pestov 2008-07-24 00:14:13 -05:00
parent f53baa2529
commit 8e847749ce
4 changed files with 60 additions and 10 deletions
unfinished/compiler/tree/propagation

View File

@ -16,7 +16,8 @@ GENERIC: child-constraints ( node -- seq )
M: #if child-constraints
in-d>> first [ =t ] [ =f ] bi 2array ;
M: #dispatch child-constraints drop f ;
M: #dispatch child-constraints
children>> length f <repetition> ;
GENERIC: live-children ( #branch -- children )
@ -27,15 +28,22 @@ M: #if live-children
2bi 2array ;
M: #dispatch live-children
children>> ;
[ children>> ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? [ drop f ] unless ] map-index ;
: infer-children ( node -- assocs )
[ live-children ] [ child-constraints ] bi [
[
value-infos [ clone ] change
constraints [ clone ] change
assume
[ first>> (propagate) ] when*
over [
value-infos [ clone ] change
constraints [ clone ] change
assume
first>> (propagate)
] [
2drop
value-infos off
constraints off
] if
] H{ } make-assoc
] 2map ;

View File

@ -56,3 +56,8 @@ IN: compiler.tree.propagation.info.tests
fixnum 19 29 [a,b] <class/interval-info>
value-info-intersect
] unit-test
[ 3 t ] [
3 <literal-info>
null <class-info> value-info-union >literal<
] unit-test

View File

@ -84,23 +84,37 @@ literal? ;
[ drop >literal< ]
} cond ;
: value-info-intersect ( info1 info2 -- info )
: (value-info-intersect) ( info1 info2 -- info )
[ [ class>> ] bi@ class-and ]
[ [ interval>> ] bi@ interval-intersect ]
[ intersect-literals ]
2tri <value-info> ;
: value-info-intersect ( info1 info2 -- info )
{
{ [ dup class>> null class<= ] [ nip ] }
{ [ over class>> null class<= ] [ drop ] }
[ (value-info-intersect) ]
} cond ;
: union-literals ( info1 info2 -- literal literal? )
2dup [ literal?>> ] both? [
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
] [ 2drop f f ] if ;
: value-info-union ( info1 info2 -- info )
: (value-info-union) ( info1 info2 -- info )
[ [ class>> ] bi@ class-or ]
[ [ interval>> ] bi@ interval-union ]
[ union-literals ]
2tri <value-info> ;
: value-info-union ( info1 info2 -- info )
{
{ [ dup class>> null class<= ] [ drop ] }
{ [ over class>> null class<= ] [ nip ] }
[ (value-info-union) ]
} cond ;
: value-infos-union ( infos -- info )
dup first [ value-info-union ] reduce ;

View File

@ -2,7 +2,7 @@ USING: kernel compiler.tree.builder compiler.tree
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 ;
alien.accessors alien.c-types sequences.private ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -178,7 +178,7 @@ IN: compiler.tree.propagation.tests
[ V{ f } ] [
[
/f
dup 0.0 < [ dup 0.0 > [ drop 0.0 ] unless ] [ drop 0.0 ] if
dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
] final-literals
] unit-test
@ -197,3 +197,26 @@ IN: compiler.tree.propagation.tests
[ V{ t } ] [
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
] unit-test
[ V{ "d" } ] [
[
3 {
[ "a" ]
[ "b" ]
[ "c" ]
[ "d" ]
[ "e" ]
[ "f" ]
[ "g" ]
[ "h" ]
} dispatch
] final-literals
] unit-test
[ V{ "hi" } ] [
[ [ "hi" ] [ 123 3 throw ] if ] final-literals
] unit-test
[ V{ fixnum } ] [
[ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
] unit-test