Array length propagation

db4
Slava Pestov 2008-07-24 17:34:08 -05:00
parent 147a90a0b6
commit a5efaa49a0
4 changed files with 106 additions and 32 deletions

View File

@ -26,11 +26,9 @@ M: true-constraint assume
[ \ f class-not <class-info> swap value>> refine-value-info ]
bi ;
M: true-constraint satisfied?
value>> value-info class>> \ f class-not class<= ;
M: true-constraint satisfied? value>> \ f class-not value-is? ;
M: true-constraint satisfiable?
value>> value-info class>> \ f class-not classes-intersect? ;
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
TUPLE: false-constraint value ;

View File

@ -22,7 +22,8 @@ TUPLE: value-info
{ class initial: null }
{ interval initial: empty-interval }
literal
literal? ;
literal?
length ;
: class-interval ( class -- interval )
dup real class<=
@ -45,36 +46,54 @@ literal? ;
} cond
] if ;
: <value-info> ( class interval literal literal? -- info )
[
2nip
[ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
t
: <value-info> ( -- info ) \ value-info new ;
: init-value-info ( info -- info )
dup literal?>> [
dup literal>> class >>class
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
] [
drop
2dup [ null class<= ] [ empty-interval eq? ] bi* or [
2drop null empty-interval f f
dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
null >>class
empty-interval >>interval
] [
over integer class<= [ integral-closure ] when
2dup interval>literal
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
] if
\ value-info boa ; foldable
] if ;
: <class/interval-info> ( class interval -- info )
f f <value-info> ; foldable
<value-info>
swap >>interval
swap >>class
init-value-info ; foldable
: <class-info> ( class -- info )
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable
: <interval-info> ( interval -- info )
real swap <class/interval-info> ; foldable
<value-info>
real >>class
swap >>interval
init-value-info ; foldable
: <literal-info> ( literal -- info )
f f rot t <value-info> ; foldable
<value-info>
swap >>literal
t >>literal?
init-value-info ; foldable
: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
: <sequence-info> ( value -- info )
<value-info>
object >>class
[-inf,inf] >>interval
swap value-info >>length
init-value-info ; foldable
: >literal< ( info -- literal literal? )
[ literal>> ] [ literal?>> ] bi ;
: intersect-literals ( info1 info2 -- literal literal? )
{
@ -84,11 +103,24 @@ literal? ;
[ drop >literal< ]
} cond ;
DEFER: value-info-intersect
: intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ drop ] }
{ [ over not ] [ nip ] }
[ value-info-intersect ]
} cond ;
: (value-info-intersect) ( info1 info2 -- info )
[ [ class>> ] bi@ class-and ]
[ [ interval>> ] bi@ interval-intersect ]
[ intersect-literals ]
2tri <value-info> ;
[ <value-info> ] 2dip
{
[ [ class>> ] bi@ class-and >>class ]
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-intersect ( info1 info2 -- info )
{
@ -102,11 +134,24 @@ literal? ;
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
] [ 2drop f f ] if ;
DEFER: value-info-union
: union-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ value-info-union ]
} cond ;
: (value-info-union) ( info1 info2 -- info )
[ [ class>> ] bi@ class-or ]
[ [ interval>> ] bi@ interval-union ]
[ union-literals ]
2tri <value-info> ;
[ <value-info> ] 2dip
{
[ [ class>> ] bi@ class-or >>class ]
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-union ( info1 info2 -- info )
{
@ -144,3 +189,6 @@ SYMBOL: value-infos
[ { t f } ]
} cond nip
] if ;
: value-is? ( value class -- ? )
[ value-info class>> ] dip class<= ;

View File

@ -2,7 +2,8 @@ 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 sequences.private ;
alien.accessors alien.c-types sequences.private
byte-arrays ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -232,3 +233,9 @@ IN: compiler.tree.propagation.tests
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences assocs words namespaces
classes.algebra combinators classes continuations
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators classes
continuations arrays byte-arrays strings
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
@ -72,9 +73,29 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition>
] ?if ;
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( node -- ? )
word>> { <array> <byte-array> <string> } memq? ;
: propagate-sequence-constructor ( node -- infos )
[ default-output-value-infos first ]
[ in-d>> first <sequence-info> ]
bi value-info-intersect 1array ;
: length-accessor? ( node -- ? )
dup in-d>> first fixed-length-sequence value-is?
[ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos )
in-d>> first value-info length>>
[ array-capacity <class-info> ] unless* 1array ;
: output-value-infos ( node -- infos )
{
{ [ dup foldable-call? ] [ fold-call ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;