compiler.*, stack-checker.known-words: adds the integer-array-capacity

This commit adds the integer-array-capacity declaration on a few
words. It should make loopy code compile faster and fix #1339

basis/bit-arrays/bit-arrays.factor

@@ -1,14 +1,13 @@
 ! Copyright (C) 2007, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.data accessors io.binary math math.bitwise
-alien.accessors kernel kernel.private sequences
-sequences.private byte-arrays parser prettyprint.custom fry
-locals ;
+USING: accessors alien alien.accessors byte-arrays fry io.binary
+kernel kernel.private locals math math.bitwise parser
+prettyprint.custom sequences sequences.private ;
 IN: bit-arrays
 
 TUPLE: bit-array
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
+    { length array-capacity read-only }
+    { underlying byte-array read-only } ;
 
 <PRIVATE
 
@@ -17,7 +16,8 @@ TUPLE: bit-array
 : bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
 
 : bit-index ( n bit-array -- bit# byte# byte-array )
-    [ integer>fixnum bit/byte ] [ underlying>> ] bi* ; inline
+    [ { integer-array-capacity } declare integer>fixnum bit/byte ]
+    [ underlying>> ] bi* ; inline
 
 : bits>cells ( m -- n ) 31 + -5 shift ; inline
 

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -350,7 +350,7 @@ cell-bits 32 = [
     \ +-integer-fixnum inlined?
 ] unit-test
 
-{ f } [
+{ t } [
     [
         { integer } declare iota [ ] map
     ] \ integer>fixnum inlined?

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

@@ -180,7 +180,23 @@ IN: compiler.tree.dead-code.tests
 
 { [ drop ] } [ [ array instance? drop ] optimize-quot ] unit-test
 
-{ [ drop ] } [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
+{
+    [ f <array> drop ]
+    [ f <array> drop ]
+    [ drop ]
+} [
+    ! Not flushed because the first argument to <array> can be
+    ! something random which would cause an exception.
+    [ f <array> drop ] optimize-quot
+
+    ! This call is not flushed because the integer can be outside
+    ! array-capacity-interval
+    [ { integer } declare f <array> drop ] optimize-quot
+
+    ! Flushed because the declaration guarantees that the integer is
+    ! within the array-capacity-interval.
+    [ { integer-array-capacity } declare f <array> drop ] optimize-quot
+] unit-test
 
 { [ f <array> drop ] } [ [ f <array> drop ] optimize-quot ] unit-test
 

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

@@ -1,19 +1,68 @@
-USING: accessors alien alien.accessors alien.c-types alien.data arrays assocs
-byte-arrays classes classes.algebra classes.struct classes.tuple.private
-combinators.short-circuit compiler.tree compiler.tree.builder
-compiler.tree.checker compiler.tree.debugger compiler.tree.def-use
-compiler.tree.normalization compiler.tree.optimizer compiler.tree.propagation
-compiler.tree.propagation.info compiler.tree.recursive effects fry
-generic.single hashtables kernel kernel.private layouts locals math
-math.floats.private math.functions math.integers.private math.intervals
-math.libm math.order math.private quotations sets sequences sequences.private
-slots.private sorting specialized-arrays strings strings.private system
-tools.test vectors vocabs words ;
+USING: accessors alien alien.accessors alien.c-types alien.data arrays
+assocs byte-arrays classes classes.algebra classes.struct
+classes.tuple.private combinators.short-circuit compiler.tree
+compiler.tree.builder compiler.tree.debugger compiler.tree.optimizer
+compiler.tree.propagation.info effects fry generic.single hashtables
+kernel kernel.private layouts literals locals math math.floats.private
+math.functions math.integers.private math.intervals math.libm
+math.order math.private quotations sequences sequences.private sets
+slots.private sorting specialized-arrays strings strings.private
+system tools.test vectors vocabs words ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
 SPECIALIZED-ARRAY: void*
 IN: compiler.tree.propagation.tests
 
+! Arrays
+{ V{ array } } [
+    [ 10 f <array> ] final-classes
+] unit-test
+
+{ V{ array } } [
+    [ { array } declare ] final-classes
+] unit-test
+
+{ V{ array } } [
+    [ 10 f <array> swap [ ] [ ] if ] final-classes
+] unit-test
+
+{
+    T{ value-info-state
+       { class integer }
+       { interval $[ array-capacity-interval ] }
+    }
+} [
+    [ dup "foo" <array> drop ] final-info first
+] unit-test
+
+! Byte arrays
+{ V{ 3 } } [
+    [ 3 <byte-array> length ] final-literals
+] unit-test
+
+{ t } [
+    [ dup <byte-array> drop ] final-info first
+    integer-array-capacity <class-info> =
+] unit-test
+
+! Strings
+{ V{ 3 } } [
+    [ 3 f <string> length ] final-literals
+] unit-test
+
+{ V{ t } } [
+    [ { string } declare string? ] final-classes
+] unit-test
+
+{ V{ string } } [
+    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
+
+{ t } [
+    [ dupd <string> drop ] final-info first
+    integer-array-capacity <class-info> =
+] unit-test
+
 { { } } [
     all-words [
         "input-classes" word-prop [ class? ] all? not
@@ -34,12 +83,6 @@ IN: compiler.tree.propagation.tests
 
 { V{ fixnum object } } [ [ 1 swap ] final-classes ] unit-test
 
-{ V{ array } } [ [ 10 f <array> ] final-classes ] unit-test
-
-{ V{ array } } [ [ { array } declare ] final-classes ] unit-test
-
-{ V{ array } } [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
-
 { V{ fixnum } } [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
 
 { V{ 69 } } [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
@@ -464,9 +507,7 @@ cell-bits 32 = [
 
 { V{ 3 } } [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
 
-{ V{ 3 } } [ [ 3 <byte-array> length ] final-literals ] unit-test
 
-{ V{ 3 } } [ [ 3 f <string> length ] final-literals ] unit-test
 
 ! Slot propagation
 TUPLE: prop-test-tuple { x integer } ;
@@ -678,10 +719,6 @@ M: array iterate first t ; inline
     [ { assoc } declare hashtable instance? ] final-classes
 ] unit-test
 
-{ V{ t } } [
-    [ { string } declare string? ] final-classes
-] unit-test
-
 { V{ POSTPONE: f } } [
     [ 3 string? ] final-classes
 ] unit-test
@@ -690,10 +727,6 @@ M: array iterate first t ; inline
     [ { fixnum } declare [ ] curry obj>> ] final-classes
 ] unit-test
 
-{ V{ fixnum } } [
-    [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes
-] unit-test
-
 { V{ f } } [
     [ 10 eq? [ drop 3 ] unless ] final-literals
 ] unit-test
@@ -834,10 +867,6 @@ MIXIN: empty-mixin
     [ { word object } declare equal? ] final-classes
 ] unit-test
 
-{ V{ string } } [
-    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-] unit-test
-
 { t } [ [ dup t xor or ] final-classes first true-class? ] unit-test
 
 { t } [ [ dup t xor swap or ] final-classes first true-class? ] unit-test

basis/stack-checker/known-words/known-words.factor

@@ -326,10 +326,10 @@ M: object infer-call* \ call bad-macro-input ;
 
 ! Container constructors
 {
-    { (byte-array) { integer } { byte-array } }
-    { <array> { integer object } { array } }
-    { <byte-array> { integer } { byte-array } }
-    { <string> { integer integer } { string } }
+    { (byte-array) { integer-array-capacity } { byte-array } }
+    { <array> { integer-array-capacity object } { array } }
+    { <byte-array> { integer-array-capacity } { byte-array } }
+    { <string> { integer-array-capacity } { string } }
     { <tuple> { array } { tuple } }
 } make-flushable-primitives