Merge branch 'master' of git://factorcode.org/git/factor

diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor
index 75477508c9cf302793c1baed4527e6b14195dde6..c483b8bdc6b3a20190ac1e4540e5b815009f89b2 100644 (file)
--- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor
@@ -166,19 +166,6 @@ M: object xyz ;
     \ +-integer-fixnum inlined?
 ] unit-test
 
-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-] unit-test
-
 [ t ] [
     [ { array-capacity } declare 0 < ] \ < inlined?
 ] unit-test
@@ -208,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- )
 
 M: fixnum annotate-entry-test-1 drop ;
 
-: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
-    2over >= [
-        3drop
+: (annotate-entry-test-2) ( from to -- )
+    2dup >= [
+        2drop
     ] [
-        [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
+        >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
     ] if ; inline recursive
 
 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
 
 [ f ] [
-    [ { bignum } declare [ ] annotate-entry-test-2 ]
+    [ { bignum } declare annotate-entry-test-2 ]
     \ annotate-entry-test-1 inlined?
 ] unit-test
 
@@ -277,11 +264,6 @@ cell-bits 32 = [
     ] unit-test
 ] when
 
-[ f ] [
-    [ { integer } declare -63 shift 4095 bitand ]
-    \ shift inlined?
-] unit-test
-
 [ t ] [
     [ B{ 1 0 } *short 0 number= ]
     \ number= inlined?
@@ -328,36 +310,6 @@ cell-bits 32 = [
     ] \ + inlined?
 ] unit-test
 
-[ f ] [
-    [
-        256 mod
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ f ] [
-    [
-        dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare 256 rem
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { integer } declare [ 256 rem ] map
-    ] { mod fixnum-mod rem } inlined?
-] unit-test
-
 [ t ] [
     [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
 ] unit-test
@@ -393,21 +345,6 @@ cell-bits 32 = [
     [ 27/2 fib ] { < - } inlined?
 ] unit-test
 
-: hang-regression ( m n -- x )
-    over 0 number= [
-        nip
-    ] [
-        dup [
-            drop 1 hang-regression
-        ] [
-            dupd hang-regression hang-regression
-        ] if
-    ] if ; inline recursive
-
-[ t ] [
-    [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
-] { } inlined? ] unit-test
-
 [ t ] [
     [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
 ] unit-test
@@ -421,16 +358,6 @@ cell-bits 32 = [
     \ fixnum-bitand inlined?
 ] unit-test
 
-[ t ] [
-    [ { integer } declare 127 bitand 3 + ]
-    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
-] unit-test
-
-[ f ] [
-    [ { integer } declare 127 bitand 3 + ]
-    { >fixnum } inlined?
-] unit-test
-
 [ t ] [
     [ { fixnum } declare [ drop ] each-integer ]
     { < <-integer-fixnum +-integer-fixnum + } inlined?
@@ -448,7 +375,7 @@ cell-bits 32 = [
 
 [ t ] [
     [ { fixnum } declare 0 [ + ] reduce ]
-    { < <-integer-fixnum } inlined?
+    { < <-integer-fixnum nth-unsafe } inlined?
 ] unit-test
 
 [ f ] [
@@ -456,22 +383,6 @@ cell-bits 32 = [
     \ +-integer-fixnum inlined?
 ] unit-test
 
-[ t ] [
-    [
-        { integer } declare
-        dup 0 >= [
-            615949 * 797807 + 20 2^ mod dup 19 2^ -
-        ] [ dup ] if
-    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { fixnum } declare
-        615949 * 797807 + 20 2^ mod dup 19 2^ -
-    ] { >fixnum } inlined?
-] unit-test
-
 [ f ] [
     [
         { integer } declare [ ] map
@@ -490,56 +401,6 @@ cell-bits 32 = [
     ] \ >fixnum inlined?
 ] unit-test
 
-[ t ] [
-    [
-        { integer } declare 0 swap
-        [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
-
-[ t ] [
-    [
-        { fixnum } declare 0 swap
-        [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
-] unit-test
-
-[ t ] [
-    [ hashtable new ] \ new inlined?
-] unit-test
-
-[ t ] [
-    [ dup hashtable eq? [ new ] when ] \ new inlined?
-] unit-test
-
-[ t ] [
-    [ { hashtable } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-[ t ] [
-    [ { vector } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-[ f ] [
-    [ { assoc } declare hashtable instance? ] \ instance? inlined?
-] unit-test
-
-TUPLE: declared-fixnum { x fixnum } ;
-
-[ t ] [
-    [ { declared-fixnum } declare [ 1 + ] change-x ]
-    { + fixnum+ >fixnum } inlined?
-] unit-test
-
-[ t ] [
-    [ { declared-fixnum } declare x>> drop ]
-    { slot } inlined?
-] unit-test
-
 [ t ] [
     [
         { array } declare length
@@ -565,12 +426,6 @@ TUPLE: declared-fixnum { x fixnum } ;
 
 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
 
-[ t ] [
-    [
-        { integer } declare [ 256 mod ] map
-    ] { mod fixnum-mod } inlined?
-] unit-test
-
 [ t ] [
     [
         { integer } declare [ 0 >= ] map

diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor
index 7b4727ffcf52a09bb13dd374ff3484842f1de641..08fd12f177eed13a92ced91585894945cbc24b45 100644 (file)
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-namespaces
+classes.algebra namespaces assocs math math.private
+math.partial-dispatch
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -20,7 +21,13 @@ GENERIC: cleanup* ( node -- node/nodes )
     #! do it since the logic is a bit more involved
     [ cleanup* ] map flatten ;
 
-: cleanup-constant-folding ( #call -- nodes )
+: cleanup-folding? ( #call -- ? )
+    node-output-infos dup empty?
+    [ drop f ] [ [ literal?>> ] all? ] if ;
+
+: cleanup-folding ( #call -- nodes )
+    #! Replace a #call having a known result with a #drop of its
+    #! inputs followed by #push nodes for the outputs.
     [
         [ node-output-infos ] [ out-d>> ] bi
         [ [ literal>> ] dip #push ] 2map
@@ -30,10 +37,27 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup-inlining ( #call -- nodes )
     body>> cleanup ;
 
+! Removing overflow checks
+: no-overflow-variant ( op -- fast-op )
+    H{
+        { fixnum+ fixnum+fast }
+        { fixnum- fixnum-fast }
+        { fixnum* fixnum*fast }
+        { fixnum-shift fixnum-shift-fast }
+    } at ;
+
+: remove-overflow-check? ( #call -- ? )
+    dup word>> no-overflow-variant
+    [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+
+: remove-overflow-check ( #call -- #call )
+    [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+
 M: #call cleanup*
     {
-        { [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
         { [ dup body>> ] [ cleanup-inlining ] }
+        { [ dup cleanup-folding? ] [ cleanup-folding ] }
+        { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
         [ ]
     } cond ;
 

diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 2442a796f27931f614746b7c2b34b55ba62bbf4a..bba920949bc0472a800dcf25fbefb6ebf47d79f7 100644 (file)
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -24,7 +24,7 @@ GENERIC: live-branches ( #branch -- indices )
 
 M: #if live-branches
     in-d>> first value-info class>> {
-        { [ dup null class<= ] [ { f f } ] }
+        { [ dup null-class? ] [ { f f } ] }
         { [ dup true-class? ] [ { t f } ] }
         { [ dup false-class? ] [ { f t } ] }
         [ { t t } ]

diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
index 5991af92eed23bcc2014a367cc2f415141075a05..24f4ca59dcfc6df0f616e72a0964d565305c8fc9 100644 (file)
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@@ -68,6 +68,5 @@ TUPLE: test-tuple { x read-only } ;
 
 [ t ] [
     f f 3 <literal-info> 3array test-tuple <tuple-info> dup
-    object <class-info>
-    value-info-intersect =
+    object-info value-info-intersect =
 ] unit-test

diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index 93057aebc1929aa08da59fe27882ecb5af9c122f..3d79840f7ea5da548fc1fe03a6a21cb41e6db2f1 100644 (file)
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -5,6 +5,12 @@ accessors math math.intervals namespaces sequences words
 combinators arrays compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
+: false-class? ( class -- ? ) \ f class<= ;
+
+: true-class? ( class -- ? ) \ f class-not class<= ;
+
+: null-class? ( class -- ? ) null class<= ;
+
 SYMBOL: +interval+
 
 GENERIC: eql? ( obj1 obj2 -- ? )
@@ -29,6 +35,8 @@ slots ;
 
 : null-info T{ value-info f null empty-interval } ; inline
 
+: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+
 : class-interval ( class -- interval )
     dup real class<=
     [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@@ -57,7 +65,7 @@ slots ;
         dup literal>> class >>class
         dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
     ] [
-        dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
+        dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
             null >>class
             empty-interval >>interval
         ] [
@@ -154,8 +162,8 @@ DEFER: (value-info-intersect)
 
 : value-info-intersect ( info1 info2 -- info )
     {
-        { [ dup class>> null class<= ] [ nip ] }
-        { [ over class>> null class<= ] [ drop ] }
+        { [ dup class>> null-class? ] [ nip ] }
+        { [ over class>> null-class? ] [ drop ] }
         [ (value-info-intersect) ]
     } cond ;
 
@@ -200,8 +208,8 @@ DEFER: (value-info-union)
 
 : value-info-union ( info1 info2 -- info )
     {
-        { [ dup class>> null class<= ] [ drop ] }
-        { [ over class>> null class<= ] [ nip ] }
+        { [ dup class>> null-class? ] [ drop ] }
+        { [ over class>> null-class? ] [ nip ] }
         [ (value-info-union) ]
     } cond ;
 
@@ -225,16 +233,12 @@ SYMBOL: value-infos
 : value-literal ( value -- obj ? )
     value-info >literal< ;
 
-: false-class? ( class -- ? ) \ f class<= ;
-
-: true-class? ( class -- ? ) \ f class-not class<= ;
-
 : possible-boolean-values ( info -- values )
     dup literal?>> [
         literal>> 1array
     ] [
         class>> {
-            { [ dup null class<= ] [ { } ] }
+            { [ dup null-class? ] [ { } ] }
             { [ dup true-class? ] [ { t } ] }
             { [ dup false-class? ] [ { f } ] }
             [ { t f } ]

diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
index af9d9bab4a9ef6f505e8cbae6549b3f9e1f28dad..08fdb36cae046fc9db654f17059eddd6da2aef75 100644 (file)
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -5,10 +5,12 @@ math.partial-dispatch math.intervals math.parser math.order
 layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
-compiler.tree.propagation.info compiler.tree.propagation.nodes
-compiler.tree.propagation.constraints
+compiler.tree.comparisons
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.slots
-compiler.tree.comparisons ;
+compiler.tree.propagation.simple
+compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.known-words
 
 \ fixnum
@@ -76,7 +78,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 : binary-op-class ( info1 info2 -- newclass )
     [ class>> ] bi@
-    2dup [ null class<= ] either? [ 2drop null ] [
+    2dup [ null-class? ] either? [ 2drop null ] [
         [ math-closure ] bi@ math-class-max
     ] if ;
 
@@ -87,13 +89,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
     [ fixnum class<= ] [ fixnum fits? ] bi* and ;
 
 : may-overflow ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
         2dup won't-overflow?
         [ [ integer math-class-max ] dip ] unless
     ] unless ;
 
 : may-be-rational ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
         [ rational math-class-max ] dip
     ] unless ;
 
@@ -107,7 +109,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     [ real math-class-min ] dip ;
 
 : float-valued ( class interval -- class' interval' )
-    over null class<= [
+    over null-class? [
         [ drop float ] dip
     ] unless ;
 
@@ -167,7 +169,7 @@ generic-comparison-ops [
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
     [ [ interval>> ] bi@ ] dip interval-comparison {
-        { incomparable [ object <class-info> ] }
+        { incomparable [ object-info ] }
         { t [ t <literal-info> ] }
         { f [ f <literal-info> ] }
     } case ;
@@ -184,7 +186,7 @@ generic-comparison-ops [
 ] each
 
 : maybe-or-never ( ? -- info )
-    [ object <class-info> ] [ \ f <class-info> ] if ;
+    [ object-info ] [ f <literal-info> ] if ;
 
 : info-intervals-intersect? ( info1 info2 -- ? )
     [ interval>> ] bi@ intervals-intersect? ;
@@ -259,5 +261,16 @@ generic-comparison-ops [
 
 \ slot [
     dup literal?>>
-    [ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
+    [ literal>> swap value-info-slot ] [ 2drop object-info ] if
+] +outputs+ set-word-prop
+
+\ instance? [
+    [ value-info ] dip over literal>> class? [
+        [ literal>> ] dip predicate-constraints
+    ] [ 2drop f ] if
+] +constraints+ set-word-prop
+
+\ instance? [
+    dup literal>> class?
+    [ literal>> predicate-output-infos ] [ 2drop f ] if
 ] +outputs+ set-word-prop

diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 3c85665ba78920915e9c096fb3d6ed91f6a944e1..c6e7865c48d3e3324cdee57c94a09d05417aa5fd 100644 (file)
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -5,7 +5,8 @@ accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
 byte-arrays classes.algebra classes.tuple.private
 math.functions math.private strings layouts
-compiler.tree.propagation.info slots.private ;
+compiler.tree.propagation.info slots.private words hashtables
+classes assocs ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -475,3 +476,55 @@ M: array iterate first t ;
     iterate [ dead-loop ] when ; inline recursive
 
 [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
+
+: hang-1 ( m -- x )
+    dup 0 number= [ hang-1 ] unless ; inline recursive
+
+[ ] [ [ 3 hang-1 ] final-info drop ] unit-test
+
+: hang-2 ( m n -- x )
+    over 0 number= [
+        nip
+    ] [
+        dup [
+            drop 1 hang-2
+        ] [
+            dupd hang-2 hang-2
+        ] if
+    ] if ; inline recursive
+
+[ ] [ [ 3 over hang-2 ] final-info drop ] unit-test
+
+[ ] [
+    [
+        dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
+    ] final-info drop
+] unit-test
+
+[ V{ word } ] [
+    [ { hashtable } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ { vector } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ object } ] [
+    [ { assoc } declare hashtable instance? ] final-classes
+] unit-test
+
+[ V{ word } ] [
+    [ { string } declare string? ] final-classes
+] unit-test
+
+[ V{ POSTPONE: f } ] [
+    [ 3 string? ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare [ ] curry obj>> ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
+] unit-test

diff --git a/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor
new file mode 100644 (file)
index 0000000..cf72a2a
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/recursive/recursive-tests.factor
@@ -0,0 +1,19 @@
+IN: compiler.tree.propagation.recursive.tests
+USING: tools.test compiler.tree.propagation.recursive
+math.intervals kernel ;
+
+[ T{ interval f { 0 t } { 1/0. t } } ] [
+    T{ interval f { 1 t } { 1 t } }
+    T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+] unit-test
+
+[ T{ interval f { -1/0. t } { 10 t } } ] [
+    T{ interval f { -1 t } { -1 t } }
+    T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+] unit-test
+
+[ t ] [
+    T{ interval f { 1 t } { 268435455 t } }
+    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    generalize-counter-interval =
+] unit-test

diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 97801e289e79a246957b0ce81e84d46cb91b356f..c5fb04e3227a5ca43b469ab5001dcb6406009f28 100644 (file)
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -21,16 +21,18 @@ IN: compiler.tree.propagation.recursive
 
 : generalize-counter-interval ( interval initial-interval -- interval' )
     {
-        { [ 2dup = ] [ empty-interval ] }
+        { [ 2dup interval-subset? ] [ empty-interval ] }
         { [ over empty-interval eq? ] [ empty-interval ] }
         { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
         { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
         [ [-inf,inf] ]
-    } cond nip interval-union ;
+    } cond interval-union nip ;
 
 : generalize-counter ( info' initial -- info )
-    [ drop clone ] [ [ interval>> ] bi@ ] 2bi
-    generalize-counter-interval >>interval ;
+    2dup [ class>> null-class? ] either? [ drop ] [
+        [ drop clone ] [ [ interval>> ] bi@ ] 2bi
+        generalize-counter-interval >>interval
+    ] if ;
 
 : unify-recursive-stacks ( stacks initial -- infos )
     over empty? [ nip ] [
@@ -65,7 +67,7 @@ M: #recursive propagate-around ( #recursive -- )
     ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
 
 : generalize-return-interval ( info -- info' )
-    dup literal?>> [
+    dup [ literal?>> ] [ class>> null-class? ] bi or [
         clone [-inf,inf] >>interval
     ] unless ;
 

diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index d0e2426b0cb2b224c2e4799e937600effd7dbd3e..589ad6db4c8d42801f406e50c48c743e12f0b53e 100644 (file)
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -17,7 +17,7 @@ IN: compiler.tree.propagation.simple
 ! Propagation for straight-line code.
 
 M: #introduce propagate-before
-    value>> object <class-info> swap set-value-info ;
+    value>> object-info swap set-value-info ;
 
 M: #push propagate-before
     [ literal>> <literal-info> ] [ out-d>> first ] bi
@@ -67,15 +67,27 @@ M: #declare propagate-before
     bi* with-datastack
     [ <literal-info> ] map ;
 
+: predicate-output-infos ( info class -- info )
+    [ class>> ] dip {
+        { [ 2dup class<= ] [ t <literal-info> ] }
+        { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
+        [ object-info ]
+    } cond 2nip ;
+
+: propagate-predicate ( #call word -- infos )
+    [ in-d>> first value-info ] [ "predicating" word-prop ] bi*
+    predicate-output-infos 1array ;
+
 : default-output-value-infos ( #call word -- infos )
     "default-output-classes" word-prop
-    [ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
+    [ class-infos ] [ out-d>> length object-info <repetition> ] ?if ;
 
 : output-value-infos ( #call word -- infos )
     {
         { [ 2dup foldable-call? ] [ fold-call ] }
         { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
+        { [ dup predicate? ] [ propagate-predicate ] }
         { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
         [ default-output-value-infos ]
     } cond ;

diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor
index 8a23d360cc7677a089b4119d3592658884b3f669..2924eb436901e5fd16e9d9510faae909a59b764b 100644 (file)
--- a/unfinished/compiler/tree/propagation/slots/slots.factor
+++ b/unfinished/compiler/tree/propagation/slots/slots.factor
@@ -3,7 +3,7 @@
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
 words math math.private combinators sequences.private namespaces
-classes compiler.tree.propagation.info ;
+slots.private classes compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
@@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
     bi* value-info-intersect 1array ;
 
 : tuple-constructor? ( word -- ? )
-    { <tuple-boa> <complex> } memq? ;
+    { <tuple-boa> curry compose <complex> } memq? ;
 
 : read-only-slots ( values class -- slots )
     #! Delegation.
@@ -41,46 +41,43 @@ UNION: fixed-length-sequence array byte-array string ;
     [ , f , [ literal>> ] map % ] { } make >tuple
     <literal-info> ;
 
-: propagate-<tuple-boa> ( #call -- info )
-    #! Delegation
-    in-d>> [ value-info ] map unclip-last
-    literal>> class>> [ read-only-slots ] keep
+: (propagate-tuple-constructor) ( values class -- info )
+    [ [ value-info ] map ] dip [ read-only-slots ] keep
     over 2 tail-slice [ dup [ literal?>> ] when ] all? [
         [ 2 tail-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
+: propagate-<tuple-boa> ( #call -- info )
+    #! Delegation
+    in-d>> unclip-last
+    value-info literal>> class>> (propagate-tuple-constructor) ;
+
+: propagate-curry ( #call -- info )
+    in-d>> \ curry (propagate-tuple-constructor) ;
+
+: propagate-compose ( #call -- info )
+    in-d>> \ compose (propagate-tuple-constructor) ;
+
 : propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
 
 : propagate-tuple-constructor ( #call word -- infos )
     {
         { \ <tuple-boa> [ propagate-<tuple-boa> ] }
+        { \ curry [ propagate-curry ] }
+        { \ compose [ propagate-compose ] } 
         { \ <complex> [ propagate-<complex> ] }
     } case 1array ;
 
-: tuple>array* ( tuple -- array )
-    prepare-tuple>array
-    >r copy-tuple-slots r>
-    prefix ;
-
 : read-only-slot? ( n class -- ? )
     all-slots [ offset>> = ] with find nip
     dup [ read-only>> ] when ;
 
 : literal-info-slot ( slot object -- info/f )
-    2dup class read-only-slot? [
-        {
-            { [ dup tuple? ] [
-                [ 1- ] [ tuple>array* ] bi* nth <literal-info>
-            ] }
-            { [ dup complex? ] [
-                [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
-                2array nth <literal-info>
-            ] }
-        } cond
-    ] [ 2drop f ] if ;
+    2dup class read-only-slot?
+    [ swap slot <literal-info> ] [ 2drop f ] if ;
 
 : length-accessor? ( slot info -- ? )
     [ 1 = ] [ length>> ] bi* and ;
@@ -92,4 +89,4 @@ UNION: fixed-length-sequence array byte-array string ;
         { [ 2dup length-accessor? ] [ nip length>> ] }
         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
         [ [ 1- ] [ slots>> ] bi* ?nth ]
-    } cond [ object <class-info> ] unless* ;
+    } cond [ object-info ] unless* ;

diff --git a/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor
new file mode 100644 (file)
index 0000000..a940a63
--- /dev/null
+++ b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor
@@ -0,0 +1,119 @@
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+    [ { declared-fixnum } declare [ 1 + ] change-x ]
+    { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { declared-fixnum } declare x>> drop ]
+    { slot } inlined?
+] unit-test
+
+[ t ] [
+    [ hashtable new ] \ new inlined?
+] unit-test
+
+[ t ] [
+    [ dup hashtable eq? [ new ] when ] \ new inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare -63 shift 4095 bitand ]
+    \ shift inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare
+        dup 0 >= [
+            615949 * 797807 + 20 2^ mod dup 19 2^ -
+        ] [ dup ] if
+    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare
+        615949 * 797807 + 20 2^ mod dup 19 2^ -
+    ] { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+] unit-test
+
+
+
+[ t ] [
+    [
+        { integer } declare [ 256 mod ] map
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+
+[ f ] [
+    [
+        256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+    [
+        dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 256 rem
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 rem ] map
+    ] { mod fixnum-mod rem } inlined?
+] unit-test

diff --git a/unfinished/math/partial-dispatch/partial-dispatch.factor b/unfinished/math/partial-dispatch/partial-dispatch.factor
index 625770e09f827dba9bd561389c09df2265678a2b..9211a41aa772a0326f1f2eb1a6ae6254b98ec8ce 100644 (file)
--- a/unfinished/math/partial-dispatch/partial-dispatch.factor
+++ b/unfinished/math/partial-dispatch/partial-dispatch.factor
@@ -44,28 +44,23 @@ PREDICATE: math-partial < word
         bi
     ] "" make "math.partial-dispatch" lookup ;
 
-: integer-op-word ( triple fix-word big-word -- word )
-    [
-        drop
-        name>> "fast" tail? >r
-        [ "-" % ] [ name>> % ] interleave
-        r> [ "-fast" % ] when
-    ] "" make "math.partial-dispatch" create ;
+: integer-op-word ( triple -- word )
+    [ name>> ] map "-" join "math.partial-dispatch" create ;
 
-: integer-op-quot ( word fix-word big-word -- quot )
+: integer-op-quot ( triple fix-word big-word -- quot )
     rot integer-op-combinator 1quotation 2curry ;
 
-: define-integer-op-word ( word fix-word big-word -- )
+: define-integer-op-word ( triple fix-word big-word -- )
     [
-        [ integer-op-word ] [ integer-op-quot ] 3bi
+        [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
         (( x y -- z )) define-declared
-    ]
-    [
-        [ integer-op-word ] [ 2drop ] 3bi
+    ] [
+        2drop
+        [ integer-op-word ] keep
         "derived-from" set-word-prop
     ] 3bi ;
 
-: define-integer-op-words ( words fix-word big-word -- )
+: define-integer-op-words ( triples fix-word big-word -- )
     [ define-integer-op-word ] 2curry each ;
 
 : integer-op-triples ( word -- triples )
@@ -78,7 +73,7 @@ PREDICATE: math-partial < word
 : define-integer-ops ( word fix-word big-word -- )
     >r >r integer-op-triples r> r>
     [ define-integer-op-words ]
-    [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+    [ 2drop [ dup integer-op-word ] { } map>assoc % ]
     3bi ;
 
 : define-math-ops ( op -- )
@@ -160,15 +155,10 @@ SYMBOL: fast-math-ops
         \ number= \ eq? \ bignum= define-integer-ops
     ] { } make >hashtable math-ops set-global
 
-    [
-        { { + fixnum fixnum } fixnum+fast } ,
-        { { - fixnum fixnum } fixnum-fast } ,
-        { { * fixnum fixnum } fixnum*fast } ,
-        { { shift fixnum fixnum } fixnum-shift-fast } ,
-
-        \ + \ fixnum+fast \ bignum+ define-integer-ops
-        \ - \ fixnum-fast \ bignum- define-integer-ops
-        \ * \ fixnum*fast \ bignum* define-integer-ops
-        \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
-    ] { } make >hashtable fast-math-ops set-global
+    H{
+        { { + fixnum fixnum } fixnum+fast }
+        { { - fixnum fixnum } fixnum-fast }
+        { { * fixnum fixnum } fixnum*fast }
+        { { shift fixnum fixnum } fixnum-shift-fast }
+    } fast-math-ops set-global
 ] with-compilation-unit

diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor
index 3fcbc2d023da880bc84821d462b2bfb8b7793c1f..3c7ae101e387ef7444d9e019a3ae2e90efa930de 100755 (executable)
--- a/unfinished/stack-checker/stack-checker-tests.factor
+++ b/unfinished/stack-checker/stack-checker-tests.factor
@@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
 sorting assocs definitions prettyprint io inspector
 classes.tuple classes.union classes.predicate debugger
 threads.private io.streams.string io.timeouts io.thread
-sequences.private destructors combinators ;
+sequences.private destructors combinators eval ;
 IN: stack-checker.tests
 
 : short-effect ( effect -- pair )