Array length propagation

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -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 ;
 

unfinished/compiler/tree/propagation/info/info.factor

@@ -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<= ;

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -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

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -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 ;