Propagation tracks length just like any other read-only slot

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 7f5b9f6fcdf68a73907a7be57de27d6f4f662880..b154845c076d88bc9f78740fbcc90cf2fcfbaa1e 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -31,7 +31,6 @@ class
 interval
 literal
 literal?
-length
 slots ;
 
 CONSTANT: null-info T{ value-info f null empty-interval }
@@ -74,13 +73,20 @@ UNION: fixed-length array byte-array string ;
         ] unless
     ] unless ;
 
+: length-slots ( length class -- slots )
+    "slots" word-prop length 1 - f <array>
+    swap prefix ;
+
 : init-literal-info ( info -- info )
     empty-interval >>interval
     dup literal>> literal-class >>class
     dup literal>> {
         { [ dup real? ] [ [a,a] >>interval ] }
         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
-        { [ dup fixed-length? ] [ length <literal-info> >>length ] }
+        { [ dup fixed-length? ] [
+            [ length <literal-info> ] [ class ] bi
+            length-slots >>slots
+        ] }
         [ drop ]
     } cond ; inline
 
@@ -158,11 +164,11 @@ UNION: fixed-length array byte-array string ;
         t >>literal?
     init-value-info ; foldable
 
-: <sequence-info> ( value -- info )
+: <sequence-info'> ( length class -- info )
     <value-info>
-        object >>class
-        swap value-info >>length
-    init-value-info ; foldable
+        over >>class
+        [ length-slots ] dip swap >>slots
+    init-value-info ;
 
 : <tuple-info> ( slots class -- info )
     <value-info>
@@ -185,13 +191,6 @@ DEFER: value-info-intersect
 
 DEFER: (value-info-intersect)
 
-: intersect-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ drop ] }
-        { [ over not ] [ nip ] }
-        [ value-info-intersect ]
-    } cond ;
-
 : intersect-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -215,7 +214,6 @@ DEFER: (value-info-intersect)
         [ [ class>> ] bi@ class-and >>class ]
         [ [ interval>> ] bi@ interval-intersect >>interval ]
         [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ intersect-lengths >>length ]
         [ intersect-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -236,13 +234,6 @@ DEFER: value-info-union
 
 DEFER: (value-info-union)
 
-: union-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ nip ] }
-        { [ over not ] [ drop ] }
-        [ value-info-union ]
-    } cond ;
-
 : union-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -261,7 +252,6 @@ DEFER: (value-info-union)
         [ [ class>> ] bi@ class-or >>class ]
         [ [ interval>> ] bi@ interval-union >>interval ]
         [ union-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ union-lengths >>length ]
         [ union-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -293,7 +283,6 @@ DEFER: (value-info-union)
                 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
                 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
                 { [ 2dup literals<= not ] [ f ] }
-                { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
                 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
                 [ t ]
             } cond 2nip

diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index eb4158e7563ec7487460a3aff2958a8afd8dff2c..d4ab697e21d558b473cdfd15720ac0ea2d5187bf 100644 (file)
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive
             [ clone ] dip
             [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
             [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
-            [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
-            tri
+            bi
         ] if
     ] if ;
 

diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 18d31985d6579fd9a279ab74bbfd76963ca39850..6429928294e1ea16528db3ed1b27c506dc24e7b3 100644 (file)
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
 
-UNION: fixed-length-sequence array byte-array string ;
-
 : sequence-constructor? ( word -- ? )
     { <array> <byte-array> (byte-array) <string> } member-eq? ;
 
@@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ;
     } at ;
 
 : propagate-sequence-constructor ( #call word -- infos )
-    [ in-d>> first <sequence-info> ]
-    [ constructor-output-class <class-info> ]
-    bi* value-info-intersect 1array ;
+    [ in-d>> first value-info ]
+    [ constructor-output-class ] bi*
+    <sequence-info'> 1array ;
 
 : fold-<tuple-boa> ( values class -- info )
     [ [ literal>> ] map ] dip prefix >tuple
@@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ;
 : value-info-slot ( slot info -- info' )
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
-        { [ 2dup length-accessor? ] [ nip length>> ] }
         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
         [ [ 1 - ] [ slots>> ] bi* ?nth ]
     } cond [ object-info ] unless* ;