compiler.tree.*: fixes the propagation and dead-code removal logic so it

becomes aware of integer-array-capacity

basis/compiler/tree/dead-code/simple/simple-docs.factor

@@ -1,4 +1,5 @@
-USING: compiler.tree help.markup help.syntax kernel sequences ;
+USING: compiler.tree help.markup help.syntax kernel math sequences
+strings ;
 IN: compiler.tree.dead-code.simple
 
 HELP: dead-flushable-call?
@@ -11,4 +12,4 @@ HELP: filter-corresponding
 
 HELP: flushable-call?
 { $values { "#call" #call } { "?" "boolean" } }
-{ $description { $link t } " if the call is flushable" } ;
+{ $description { $link t } " if the call is flushable. To be flushable, two conditions must hold; first the word must have been declared flushable. Then, if it has any \"input-classes\" declared, all inputs to the word must fit within those classes. For example, if an input is a " { $link string } " and the declared input class is " { $link integer } ", it doesn't fit and the word is not flushable." } ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -9,10 +9,10 @@ IN: compiler.tree.dead-code.simple
 
 : flushable-call? ( #call -- ? )
     dup word>> dup flushable? [
-        "input-classes" word-prop [ drop t ] [
+        word>input-infos [
             [ node-input-infos ] dip
-            [ [ class>> ] dip class<= ] 2all?
-        ] if-empty
+            [ value-info<= ] 2all?
+        ] [ drop t ] if*
     ] [ 2drop f ] if ;
 
 M: #call mark-live-values*

basis/compiler/tree/propagation/info/info-tests.factor

@@ -1,10 +1,12 @@
 USING: accessors alien arrays byte-arrays classes.algebra
-classes.struct compiler.tree.propagation.info kernel literals math
-math.intervals sequences sequences.private tools.test ;
+classes.struct compiler.tree.propagation.copy
+compiler.tree.propagation.info io.encodings.utf8 kernel literals math
+math.intervals namespaces sequences sequences.private tools.test ;
 IN: compiler.tree.propagation.info.tests
 
 { f } [ 0.0 -0.0 eql? ] unit-test
 
+! value-info-intersect
 { t t } [
     0 10 [a,b] <interval-info>
     5 20 [a,b] <interval-info>
@@ -51,13 +53,6 @@ IN: compiler.tree.propagation.info.tests
     value-info-intersect
 ] unit-test
 
-{ 3 t } [
-    3 <literal-info>
-    null-info value-info-union >literal<
-] unit-test
-
-{ } [ { } value-infos-union drop ] unit-test
-
 TUPLE: test-tuple { x read-only } ;
 
 { t } [
@@ -75,6 +70,30 @@ TUPLE: test-tuple { x read-only } ;
     [ interval>> 0 40 [a,b] = ] bi
 ] unit-test
 
+! refine-value-info
+{
+    $[ fixnum array-capacity-interval <class/interval-info> ]
+} [
+    H{ { 1234 1234 } } copies set
+    {
+        H{
+            { 1234 $[ fixnum <class-info> ] }
+        }
+    } value-infos set
+    integer array-capacity-interval <class/interval-info> 1234
+    refine-value-info
+    1234 value-info
+] unit-test
+
+! value-info-union
+
+{ 3 t } [
+    3 <literal-info>
+    null-info value-info-union >literal<
+] unit-test
+
+{ } [ { } value-infos-union drop ] unit-test
+
 ! interval>literal
 { 10 t } [
     fixnum 10 10 [a,b]  interval>literal
@@ -193,6 +212,9 @@ TUPLE: tup2 < tup1 bar ;
     tup1 <class-info> tup2 <class-info> value-info<=
 ] unit-test
 
+! <class-info>
+{ utf8 } [ utf8 <class-info> class>> ] unit-test
+
 ! init-interval
 {
     T{ value-info-state

basis/compiler/tree/propagation/info/info.factor

@@ -86,10 +86,12 @@ UNION: fixed-length array byte-array string ;
         [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
     } 1|| ;
 
+! Hardcoding classes is kind of a hack.
 : min-value ( class -- n )
     {
         { fixnum [ most-negative-fixnum ] }
         { array-capacity [ 0 ] }
+        { integer-array-capacity [ 0 ] }
         [ drop -1/0. ]
     } case ;
 
@@ -97,6 +99,7 @@ UNION: fixed-length array byte-array string ;
     {
         { fixnum [ most-positive-fixnum ] }
         { array-capacity [ max-array-capacity ] }
+        { integer-array-capacity [ max-array-capacity ] }
         [ drop 1/0. ]
     } case ;
 
@@ -104,9 +107,16 @@ UNION: fixed-length array byte-array string ;
     {
         { fixnum [ fixnum-interval ] }
         { array-capacity [ array-capacity-interval ] }
+        { integer-array-capacity [ array-capacity-interval ] }
         [ drop full-interval ]
     } case ;
 
+: fix-capacity-class ( class -- class' )
+    {
+        { array-capacity fixnum }
+        { integer-array-capacity integer }
+    } ?at drop ;
+
 : wrap-interval ( interval class -- interval' )
     class-interval 2dup interval-subset? [ drop ] [ nip ] if ;
 
@@ -125,6 +135,7 @@ UNION: fixed-length array byte-array string ;
             init-interval
             dup [ class>> ] [ interval>> ] bi interval>literal
             [ >>literal ] [ >>literal? ] bi*
+            [ fix-capacity-class ] change-class
         ] if
     ] if ; inline
 
@@ -323,3 +334,9 @@ SYMBOL: value-infos
         dup in-d>> last node-value-info
         literal>> first immutable-tuple-class?
     ] [ drop f ] if ;
+
+: class-infos ( classes/f -- infos )
+    [ <class-info> ] map ;
+
+: word>input-infos ( word -- input-infos/f )
+    "input-classes" word-prop class-infos ;

basis/compiler/tree/propagation/simple/simple-tests.factor

@@ -37,8 +37,7 @@ IN: compiler.tree.propagation.simple.tests
 
 { } [
     fixnum-value-infos setup-value-infos
-    #call-fixnum* dup word>> "input-classes" word-prop
-    propagate-input-classes
+    #call-fixnum* dup word>> word>input-infos propagate-input-infos
 ] unit-test
 
 {

basis/compiler/tree/propagation/simple/simple.factor

@@ -1,14 +1,12 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs classes
-classes.algebra classes.algebra.private classes.maybe
-classes.tuple.private combinators combinators.short-circuit
-compiler.tree compiler.tree.propagation.constraints
-compiler.tree.propagation.info
-compiler.tree.propagation.inlining
-compiler.tree.propagation.nodes compiler.tree.propagation.slots
-continuations fry kernel sequences stack-checker.dependencies
-words ;
+USING: accessors alien.c-types arrays assocs classes classes.algebra
+classes.algebra.private classes.maybe classes.tuple.private
+combinators combinators.short-circuit compiler.tree
+compiler.tree.propagation.constraints compiler.tree.propagation.info
+compiler.tree.propagation.inlining compiler.tree.propagation.nodes
+compiler.tree.propagation.slots continuations fry kernel
+math.intervals sequences stack-checker.dependencies words ;
 IN: compiler.tree.propagation.simple
 
 M: #introduce propagate-before
@@ -18,12 +16,9 @@ M: #push propagate-before
     [ literal>> <literal-info> ] [ out-d>> first ] bi
     set-value-info ;
 
-: refine-value-infos ( classes values -- )
+: refine-value-infos ( classes/f values -- )
     [ refine-value-info ] 2each ;
 
-: class-infos ( classes -- infos )
-    [ <class-info> ] map ;
-
 : set-value-infos ( infos values -- )
     [ set-value-info ] 2each ;
 
@@ -121,9 +116,6 @@ ERROR: invalid-outputs #call infos ;
     if ;
 
 : propagate-predicate ( #call word -- infos )
-    ! We need to force the caller word to recompile when the class
-    ! is redefined, since now we're making assumptions but the
-    ! class definition itself.
     [ in-d>> first value-info ]
     [ "predicating" word-prop ] bi*
     [ nip add-depends-on-conditionally ]
@@ -158,12 +150,11 @@ M: #call propagate-before
 M: #call annotate-node
     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
 
-: propagate-input-classes ( node input-classes -- )
-    class-infos swap in-d>> refine-value-infos ;
+: propagate-input-infos ( node infos/f -- )
+    swap in-d>> refine-value-infos ;
 
 M: #call propagate-after
-    dup word>> "input-classes" word-prop dup
-    [ propagate-input-classes ] [ 2drop ] if ;
+    dup word>> word>input-infos propagate-input-infos ;
 
 : propagate-alien-invoke ( node -- )
     [ out-d>> ] [ params>> return>> ] bi