Debugging slot propagation, starting recursive propagation

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

@@ -61,3 +61,5 @@ IN: compiler.tree.propagation.info.tests
     3 <literal-info>
     null <class-info> value-info-union >literal<
 ] unit-test
+
+[ ] [ { } value-infos-union drop ] unit-test

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

@@ -113,6 +113,8 @@ slots ;
 
 DEFER: value-info-intersect
 
+DEFER: (value-info-intersect)
+
 : intersect-lengths ( info1 info2 -- length )
     [ length>> ] bi@ {
         { [ dup not ] [ drop ] }
@@ -120,10 +122,17 @@ DEFER: value-info-intersect
         [ value-info-intersect ]
     } cond ;
 
+: intersect-slot ( info1 info2 -- info )
+    {
+        { [ dup not ] [ nip ] }
+        { [ over not ] [ drop ] }
+        [ (value-info-intersect) ]
+    } cond ;
+
 : intersect-slots ( info1 info2 -- slots )
     [ slots>> ] bi@
     2dup [ length ] bi@ =
-    [ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
+    [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
 
 : (value-info-intersect) ( info1 info2 -- info )
     [ <value-info> ] 2dip
@@ -150,6 +159,8 @@ DEFER: value-info-intersect
 
 DEFER: value-info-union
 
+DEFER: (value-info-union)
+
 : union-lengths ( info1 info2 -- length )
     [ length>> ] bi@ {
         { [ dup not ] [ nip ] }
@@ -157,10 +168,17 @@ DEFER: value-info-union
         [ value-info-union ]
     } cond ;
 
+: union-slot ( info1 info2 -- info )
+    {
+        { [ dup not ] [ nip ] }
+        { [ over not ] [ drop ] }
+        [ (value-info-union) ]
+    } cond ;
+
 : union-slots ( info1 info2 -- slots )
     [ slots>> ] bi@
     2dup [ length ] bi@ =
-    [ [ value-info-union ] 2map ] [ 2drop f ] if ;
+    [ [ union-slot ] 2map ] [ 2drop f ] if ;
 
 : (value-info-union) ( info1 info2 -- info )
     [ <value-info> ] 2dip
@@ -181,7 +199,9 @@ DEFER: value-info-union
     } cond ;
 
 : value-infos-union ( infos -- info )
-    dup first [ value-info-union ] reduce ;
+    dup empty?
+    [ drop null <class-info> ]
+    [ dup first [ value-info-union ] reduce ] if ;
 
 ! Current value --> info mapping
 SYMBOL: value-infos

unfinished/compiler/tree/propagation/known-words/known-words.factor

@@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
 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
+classes.tuple alien.accessors classes.tuple.private slots.private
 compiler.tree.propagation.info compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints
+compiler.tree.propagation.slots
 compiler.tree.comparisons ;
 IN: compiler.tree.propagation.known-words
 
@@ -258,3 +259,8 @@ generic-comparison-ops [
 
 ! the output of clone has the same type as the input
 { clone (clone) } [ [ ] +outputs+ set-word-prop ] each
+
+\ slot [
+    dup literal?>>
+    [ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
+] +outputs+ set-word-prop

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

@@ -3,8 +3,8 @@ 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
-byte-arrays classes.algebra math.functions math.private
-strings ;
+byte-arrays classes.algebra classes.tuple.private
+math.functions math.private strings layouts ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -235,12 +235,39 @@ IN: compiler.tree.propagation.tests
     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 ] unit-test
 
+[ V{ object } ] [
+    [ 0 * 10 < ] final-classes
+] unit-test
+
 [ V{ string string } ] [
     [
         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
     ] final-classes
 ] unit-test
 
+[ V{ float } ] [
+    [ { real float } declare + ] final-classes
+] unit-test
+
+[ V{ float } ] [
+    [ { float real } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
+] unit-test
+
+cell-bits 32 = [
+    [ V{ integer } ] [
+        [ { fixnum } declare 1 swap 31 bitand shift ]
+        final-classes
+    ] unit-test
+] when
+
 ! Array length propagation
 [ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
 
@@ -323,6 +350,10 @@ TUPLE: mutable-tuple-test { x sequence } ;
     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 ] unit-test
 
+[ V{ tuple-layout } ] [
+    [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
+] unit-test
+
 ! Mixed mutable and immutable slots
 TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 
@@ -332,3 +363,32 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
         [ x>> ] [ y>> ] bi
     ] final-classes
 ] unit-test
+
+! Recursive propagation
+: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
+
+[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
+
+: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
+
+[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
+
+: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
+
+[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
+
+[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
+
+[ V{ float } ] [
+    [ { float } declare 10 [ 2.3 * ] times ] final-classes
+] unit-test
+
+: recursive-test-4 ( i n -- )
+    2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
+
+[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
+
+: recursive-test-5 ( a -- b )
+    dup 2 > [ dup 1 - recursive-test-5 * ] when ; inline recursive
+
+[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors
+USING: kernel sequences accessors arrays
+stack-checker.inlining
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -14,23 +15,48 @@ IN: compiler.tree.propagation.recursive
 ! We need to compute scalar evolution so that sccp doesn't
 ! evaluate loops
 
-: (merge-value-infos) ( inputs -- infos )
+! row polymorphism is causing problems
+
+! infer-branch cloning and subsequent loss of state causing problems
+
+: merge-value-infos ( inputs -- infos )
     [ [ value-info ] map value-infos-union ] map ;
+USE: io
+: compute-fixed-point ( label infos outputs -- )
+    2dup [ length ] bi@ = [ "Wrong length" throw ] unless
+    "compute-fixed-point" print USE: prettyprint
+    2dup [ value-info ] map 2dup . . [ = ] 2all? [ 3drop ] [
+        [ set-value-info ] 2each
+        f >>fixed-point drop
+    ] if ;
 
-: merge-value-infos ( inputs outputs -- fixed-point? )
-    [ (merge-value-infos) ] dip
-    [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
-
-: propagate-recursive-phi ( #phi -- fixed-point? )
-    [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
-    [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
-    bi and ;
+: propagate-recursive-phi ( label #phi -- )
+    "propagate-recursive-phi" print
+    [ [ phi-in-d>> merge-value-infos ] [ out-d>> ] bi compute-fixed-point ]
+    [ [ phi-in-r>> merge-value-infos ] [ out-r>> ] bi compute-fixed-point ] 2bi ;
 
+USING: namespaces math ;
+SYMBOL: iter-counter
+0 iter-counter set-global
 M: #recursive propagate-around ( #recursive -- )
-    dup
-    node-child
-    [ first>> (propagate) ] [ propagate-recursive-phi ] bi
-    [ drop ] [ propagate-around ] if ;
+    "#recursive" print
+    iter-counter inc
+    iter-counter get 10 > [ "Oops" throw ] when
+    [ label>> ] keep
+    [ node-child first>> propagate-recursive-phi ]
+    [ [ t >>fixed-point drop ] [ node-child first>> (propagate) ] bi* ]
+    [ swap fixed-point>> [ drop ] [ propagate-around ] if ]
+    2tri ; USE: assocs
 
 M: #call-recursive propagate-before ( #call-label -- )
-    [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
+    [ label>> ] [ label>> return>> [ value-info ] map ] [ out-d>> ] tri
+    dup [ dup value-infos get at [ drop ] [ object <class-info> swap set-value-info ] if ] each
+    2dup min-length [ tail* ] curry bi@
+    compute-fixed-point ;
+
+M: #return propagate-before ( #return -- )
+    "#return" print
+    dup label>> [
+        [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri
+        compute-fixed-point
+    ] [ drop ] if ;

unfinished/compiler/tree/propagation/slots/slots.factor

@@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
 : tuple-constructor? ( node -- ? )
     word>> { <tuple-boa> <complex> } memq? ;
 
+: read-only-slots ( values class -- slots )
+    #! Delegation.
+    all-slots rest-slice
+    [ read-only>> [ drop f ] unless ] 2map
+    { f f } prepend ;
+
+: fold-<tuple-boa> ( values class -- info )
+    [ , f , [ literal>> ] map % ] { } make >tuple
+    <literal-info> ;
+
 : propagate-<tuple-boa> ( node -- info )
     #! Delegation
     in-d>> [ value-info ] map unclip-last
-    literal>> class>> dup immutable-tuple-class? [
-        over [ literal?>> ] all?
-        [ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
-        [ <tuple-info> ]
-        if
-    ] [ nip <class-info> ] if ;
+    literal>> class>> [ read-only-slots ] keep
+    over 2 tail-slice [ dup [ literal?>> ] when ] all? [
+        [ 2 tail-slice ] dip fold-<tuple-boa>
+    ] [
+        <tuple-info>
+    ] if ;
 
 : propagate-<complex> ( node -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
@@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ;
     [ [ class>> ] [ object ] if* class-or ] reduce
     <class-info> ;
 
+: tuple>array* ( tuple -- array )
+    prepare-tuple>array
+    >r copy-tuple-slots r>
+    prefix ;
+
+: literal-info-slot ( slot info -- info' )
+    {
+        { [ dup tuple? ] [
+            tuple>array* nth <literal-info>
+        ] }
+        { [ dup complex? ] [
+            [ real-part ] [ imaginary-part ] bi
+            2array nth <literal-info>
+        ] }
+    } cond ;
+
 : value-info-slot ( slot info -- info' )
     #! Delegation.
-    [ class>> complex class<= 1 3 ? - ] keep
-    dup literal?>> [
-        literal>> {
-            { [ dup tuple? ] [
-                tuple-slots 1 tail-slice nth <literal-info>
-            ] }
-            { [ dup complex? ] [
-                [ real-part ] [ imaginary-part ] bi
-                2array nth <literal-info>
-            ] }
-        } cond
-    ] [ slots>> ?nth ] if ;
+    {
+        { [ over 0 = ] [ 2drop fixnum <class-info> ] }
+        { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
+        [ [ 1- ] [ slots>> ] bi* ?nth ]
+    } cond ;
 
 : reader-word-outputs ( node -- infos )
     [ relevant-slots ] [ in-d>> first ] bi