Array length propagation
parent
147a90a0b6
commit
a5efaa49a0
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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<= ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue