Working on recursive propagation

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces disjoint-sets sequences assocs
+USING: namespaces disjoint-sets sequences assocs math
 kernel accessors fry
 compiler.tree compiler.tree.def-use compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
@@ -31,6 +31,16 @@ M: #r> compute-copy-equiv*
 M: #copy compute-copy-equiv*
     [ in-d>> ] [ out-d>> ] bi are-copies-of ;
 
+M: #return-recursive compute-copy-equiv*
+    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+
+: unchanged-underneath ( #call-recursive -- n )
+    [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
+
+M: #call-recursive compute-copy-equiv*
+    [ in-d>> ] [ out-d>> ] [ unchanged-underneath ] tri
+    '[ , head ] bi@ are-copies-of ;
+
 M: node compute-copy-equiv* drop ;
 
 : compute-copy-equiv ( node -- node )

unfinished/compiler/tree/dead-code/dead-code.factor

@@ -21,9 +21,7 @@ M: #call mark-live-values
     [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
 
 M: #return mark-live-values
-    #! Values returned by local #recursive functions can be
-    #! killed if they're unused.
-    dup label>> [ drop ] [ look-at-inputs ] if ;
+    look-at-inputs ;
 
 M: node mark-live-values drop ;
 

unfinished/compiler/tree/def-use/def-use.factor

@@ -52,12 +52,16 @@ M: node node-defs-values out-d>> ;
     [ dup node-uses-values [ use-value ] with each ]
     [ dup node-defs-values [ def-value ] with each ] bi ;
 
+: check-def ( node -- )
+    [ "No def" throw ] unless ;
+
+: check-use ( uses -- )
+    [ empty? [ "No use" throw ] when ]
+    [ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
+
 : check-def-use ( -- )
     def-use get [
-        nip
-        [ node>> [ "No def" throw ] unless ]
-        [ uses>> all-unique? [ "Uses not all unique" throw ] unless ]
-        bi
+        nip [ node>> check-def ] [ uses>> check-use ] bi
     ] assoc-each ;
 
 : compute-def-use ( node -- node )

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

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

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

@@ -27,6 +27,8 @@ literal?
 length
 slots ;
 
+: null-info T{ value-info f null empty-interval } ; inline
+
 : class-interval ( class -- interval )
     dup real class<=
     [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@@ -200,15 +202,14 @@ DEFER: (value-info-union)
 
 : value-infos-union ( infos -- info )
     dup empty?
-    [ drop null <class-info> ]
+    [ drop null-info ]
     [ dup first [ value-info-union ] reduce ] if ;
 
 ! Current value --> info mapping
 SYMBOL: value-infos
 
 : value-info ( value -- info )
-    resolve-copy value-infos get at
-    T{ value-info f null empty-interval } or ;
+    resolve-copy value-infos get at null-info or ;
 
 : set-value-info ( info value -- )
     resolve-copy value-infos get set-at ;
@@ -233,3 +234,12 @@ SYMBOL: value-infos
 
 : value-is? ( value class -- ? )
     [ value-info class>> ] dip class<= ;
+
+: node-value-info ( node value -- info )
+    swap info>> at* [ drop null-info ] unless ;
+
+: node-input-infos ( node -- seq )
+    dup in-d>> [ node-value-info ] with map ;
+
+: node-output-infos ( node -- seq )
+    dup out-d>> [ node-value-info ] with map ;

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -16,6 +16,7 @@ GENERIC: propagate-around ( node -- )
 
 : (propagate) ( node -- )
     [
+        USING: classes prettyprint ; dup class .
         [ propagate-around ] [ successor>> ] bi
         (propagate)
     ] when* ;

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

@@ -4,7 +4,8 @@ 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 classes.tuple.private
-math.functions math.private strings layouts ;
+math.functions math.private strings layouts
+compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -383,12 +384,25 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     [ { float } declare 10 [ 2.3 * ] times ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ 0 10 [ nip ] each-integer ] final-classes
+] unit-test
+
+[ V{ t } ] [
+    [ t 10 [ nip 0 >= ] each-integer ] final-literals
+] 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
+    dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
 
-[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test
+[ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
+
+: recursive-test-6 ( a -- b )
+    dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
+
+[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] 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 arrays
+USING: kernel sequences accessors arrays fry math.intervals
+combinators
 stack-checker.inlining
 compiler.tree
 compiler.tree.propagation.info
@@ -9,54 +10,75 @@ compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
-! What if we reach a fixed point for the phi but not for the
-! #call-label output?
-
-! We need to compute scalar evolution so that sccp doesn't
-! evaluate loops
-
 ! row polymorphism is causing problems
 
-! infer-branch cloning and subsequent loss of state causing problems
+: longest-suffix ( seq1 seq2 -- seq1' seq2' )
+    2dup min-length [ tail-slice* ] curry bi@ ;
 
-: 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
+: suffixes= ( seq1 seq2 -- ? )
+    longest-suffix sequence= ;
+
+: check-fixed-point ( node infos1 infos2 -- node )
+    suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline
+
+: recursive-stacks ( #enter-recursive -- stacks initial )
+    [ label>> calls>> [ node-input-infos ] map ]
+    [ in-d>> [ value-info ] map ] bi
+    [ length '[ , tail* ] map flip ] keep ;
+
+: generalize-counter-interval ( i1 i2 -- i3 )
+    {
+        { [ 2dup interval<= ] [ 1./0. [a,a] ] }
+        { [ 2dup interval>= ] [ -1./0. [a,a] ] }
+        [ [-inf,inf] ]
+    } cond nip interval-union ;
+
+: generalize-counter ( info' initial -- info )
+    [ drop clone ] [ [ interval>> ] bi@ ] 2bi
+    generalize-counter-interval >>interval
+    f >>literal? f >>literal ;
+
+: unify-recursive-stacks ( stacks initial -- infos )
+    over empty? [ nip ] [
+        [
+            [ sift value-infos-union ] dip
+            [ generalize-counter ] keep
+            value-info-union
+        ] 2map
     ] if ;
 
-: 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 ;
+: propagate-recursive-phi ( #enter-recursive -- )
+    [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
+    [ node-output-infos check-fixed-point drop ] 2keep
+    out-d>> set-value-infos ;
 
 USING: namespaces math ;
 SYMBOL: iter-counter
 0 iter-counter set-global
 M: #recursive propagate-around ( #recursive -- )
-    "#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
+    dup label>> t >>fixed-point drop
+    [ node-child first>> [ propagate-recursive-phi ] [ (propagate) ] bi ]
+    [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ]
+    bi ;
+
+: generalize-return-interval ( info -- info' )
+    dup literal?>> [
+        clone [-inf,inf] >>interval
+    ] unless ;
+
+: generalize-return ( infos -- infos' )
+    [ generalize-return-interval ] map ;
 
 M: #call-recursive propagate-before ( #call-label -- )
-    [ 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 ;
+    dup
+    [ node-output-infos ]
+    [ label>> return>> node-input-infos ]
+    bi check-fixed-point
+    [ label>> return>> node-input-infos generalize-return ] [ out-d>> ] bi
+    longest-suffix set-value-infos ;
 
-M: #return propagate-before ( #return -- )
-    "#return" print
-    dup label>> [
-        [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri
-        compute-fixed-point
-    ] [ drop ] if ;
+M: #return-recursive propagate-before ( #return-recursive -- )
+    dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
+    check-fixed-point drop ;

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

@@ -77,7 +77,7 @@ UNION: fixed-length-sequence array byte-array string ;
     relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
 
 : no-reader-methods ( input slots -- info )
-    2drop null <class-info> ;
+    2drop null-info ;
 
 : same-offset ( slots -- slot/f )
     dup [ dup [ read-only>> ] when ] all? [

unfinished/compiler/tree/tree.factor

@@ -35,15 +35,6 @@ M: node hashcode* drop node hashcode* ;
         2drop f
     ] if ;
 
-: node-value-info ( node value -- info )
-    swap info>> at ;
-
-: node-input-infos ( node -- seq )
-    dup in-d>> [ node-value-info ] with map ;
-
-: node-output-infos ( node -- seq )
-    dup out-d>> [ node-value-info ] with map ;
-
 TUPLE: #introduce < node values ;
 
 : #introduce ( values -- node )
@@ -99,7 +90,9 @@ TUPLE: #r> < node ;
 
 TUPLE: #terminate < node ;
 
-: #terminate ( -- node ) \ #terminate new ;
+: #terminate ( stack -- node )
+    \ #terminate new
+        swap >>in-d ;
 
 TUPLE: #branch < node ;
 
@@ -133,23 +126,37 @@ TUPLE: #declare < node declaration ;
     \ #declare new
         swap >>declaration ;
 
-TUPLE: #return < node label ;
+TUPLE: #return < node ;
 
-: #return ( label stack -- node )
+: #return ( stack -- node )
     \ #return new
-        swap >>in-d
-        swap >>label ;
+        swap >>in-d ;
 
 TUPLE: #recursive < node word label loop? returns calls ;
 
-: #recursive ( word label inputs outputs child -- node )
+: #recursive ( word label inputs child -- node )
     \ #recursive new
         swap 1array >>children
-        swap >>out-d
         swap >>in-d
         swap >>label
         swap >>word ;
 
+TUPLE: #enter-recursive < node label ;
+
+: #enter-recursive ( label inputs outputs -- node )
+    \ #enter-recursive new
+        swap >>out-d
+        swap >>in-d
+        swap >>label ;
+
+TUPLE: #return-recursive < node label ;
+
+: #return-recursive ( label inputs outputs -- node )
+    \ #return-recursive new
+        swap >>out-d
+        swap >>in-d
+        swap >>label ;
+
 TUPLE: #copy < node ;
 
 : #copy ( inputs outputs -- node )
@@ -175,13 +182,15 @@ TUPLE: node-list first last ;
 M: node-list child-visitor node-list new ;
 M: node-list #introduce, #introduce node, ;
 M: node-list #call, #call node, ;
-M: node-list #call-recursive, #call-recursive node, ;
 M: node-list #push, #push node, ;
 M: node-list #shuffle, #shuffle node, ;
 M: node-list #drop, #drop node, ;
 M: node-list #>r, #>r node, ;
 M: node-list #r>, #r> node, ;
 M: node-list #return, #return node, ;
+M: node-list #enter-recursive, #enter-recursive node, ;
+M: node-list #return-recursive, #return-recursive [ node, ] [ dup label>> (>>return) ] bi ;
+M: node-list #call-recursive, #call-recursive [ node, ] [ dup label>> calls>> push ] bi ;
 M: node-list #terminate, #terminate node, ;
 M: node-list #if, #if node, ;
 M: node-list #dispatch, #dispatch node, ;

unfinished/compiler/tree/untupling/untupling.factor

@@ -29,8 +29,7 @@ M: #call compute-untupling*
         [ drop mark-escaping-values ]
     } case ;
 
-M: #return compute-untupling*
-    dup label>> [ drop ] [ mark-escaping-values ] if ;
+M: #return compute-untupling* mark-escaping-values ;
 
 M: node compute-untupling* drop ;
 

unfinished/stack-checker/backend/backend.factor

@@ -82,7 +82,7 @@ M: wrapper apply-object
 M: object apply-object push-literal ;
 
 : terminate ( -- )
-    terminated? on #terminate, ;
+    terminated? on meta-d get clone #terminate, ;
 
 : infer-quot ( quot rstate -- )
     recursive-state get [
@@ -113,10 +113,10 @@ M: object apply-object push-literal ;
     ] if ;
 
 : infer->r ( n -- )
-    consume-d [ dup copy-values #>r, ] [ output-r ] bi ;
+    consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
 
 : infer-r> ( n -- )
-    consume-r [ dup copy-values #r>, ] [ output-d ] bi ;
+    consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
 
 : undo-infer ( -- )
     recorded get [ f +inferred-effect+ set-word-prop ] each ;
@@ -140,7 +140,7 @@ M: object apply-object push-literal ;
 
 : end-infer ( -- )
     check->r
-    f meta-d get clone #return, ;
+    meta-d get clone #return, ;
 
 : effect-required? ( word -- ? )
     {

unfinished/stack-checker/inlining/inlining.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces assocs kernel sequences words accessors
 definitions math effects classes arrays combinators vectors
+arrays
 stack-checker.state
 stack-checker.visitor
 stack-checker.backend
@@ -16,12 +17,12 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive word phi-in phi-out returns ;
+TUPLE: inline-recursive word enter-out return calls fixed-point ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new
         swap >>word
-        V{ } clone >>returns ;
+        V{ } clone >>calls ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;
@@ -29,23 +30,20 @@ TUPLE: inline-recursive word phi-in phi-out returns ;
 : make-copies ( values effect-in -- values' )
     [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
 
-SYMBOL: phi-in
-SYMBOL: phi-out
+SYMBOL: enter-in
+SYMBOL: enter-out
 
 : prepare-stack ( word -- )
     required-stack-effect in>> [ length ensure-d ] keep
-    [ drop 1vector phi-in set ]
-    [ make-copies phi-out set ]
-    2bi ;
+    [ drop enter-in set ] [ make-copies enter-out set ] 2bi ;
 
-: emit-phi-function ( label -- )
-    phi-in get >>phi-in
-    phi-out get >>phi-out drop
-    phi-in get phi-out get { { } } { } #phi,
-    phi-out get >vector meta-d set ;
+: emit-enter-recursive ( label -- )
+    enter-out get >>enter-out
+    enter-in get enter-out get #enter-recursive,
+    enter-out get >vector meta-d set ;
 
 : entry-stack-height ( label -- stack )
-    phi-out>> length ;
+    enter-out>> length ;
 
 : check-return ( word label -- )
     2dup
@@ -59,7 +57,7 @@ SYMBOL: phi-out
 
 : end-recursive-word ( word label -- )
     [ check-return ]
-    [ meta-d get [ #return, ] [ swap returns>> push ] 2bi ]
+    [ meta-d get dup copy-values dup meta-d set #return-recursive, ]
     bi ;
 
 : recursive-word-inputs ( label -- n )
@@ -72,7 +70,7 @@ SYMBOL: phi-out
         nest-visitor
 
         dup <inline-recursive>
-        [ dup emit-phi-function (inline-word) ]
+        [ dup emit-enter-recursive (inline-word) ]
         [ end-recursive-word ]
         [ ]
         2tri
@@ -86,7 +84,7 @@ SYMBOL: phi-out
 
 : inline-recursive-word ( word -- )
     (inline-recursive-word)
-    [ consume-d ] [ dup output-d ] [ ] tri* #recursive, ;
+    [ consume-d ] [ output-d ] [ ] tri* #recursive, ;
 
 : check-call-height ( word label -- )
     entry-stack-height current-stack-height >
@@ -96,18 +94,13 @@ SYMBOL: phi-out
     required-stack-effect in>> length meta-d get swap tail* ;
 
 : check-call-site-stack ( stack label -- )
-    tuck phi-out>>
+    tuck enter-out>>
     [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
     [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
 
 : add-call ( word label -- )
     [ check-call-height ]
-    [
-        [ call-site-stack ] dip
-        [ check-call-site-stack ]
-        [ phi-in>> swap [ suffix ] 2change-each ]
-        2bi
-    ] 2bi ;
+    [ [ call-site-stack ] dip check-call-site-stack ] 2bi ;
 
 : adjust-stack-effect ( effect -- effect' )
     [ in>> ] [ out>> ] bi

unfinished/stack-checker/transforms/transforms.factor

@@ -4,7 +4,8 @@ USING: fry accessors arrays kernel words sequences generic math
 namespaces quotations assocs combinators classes.tuple
 classes.tuple.private effects summary hashtables classes generic
 sets definitions generic.standard slots.private continuations
-stack-checker.backend stack-checker.state stack-checker.errors ;
+stack-checker.backend stack-checker.state stack-checker.visitor
+stack-checker.errors ;
 IN: stack-checker.transforms
 
 SYMBOL: +transform-quot+
@@ -15,8 +16,9 @@ SYMBOL: +transform-n+
         drop recursive-state get 1array
     ] [
         consume-d
+        [ #drop, ]
         [ [ literal value>> ] map ]
-        [ first literal recursion>> ] bi prefix
+        [ first literal recursion>> ] tri prefix
     ] if
     swap with-datastack ;
 

unfinished/stack-checker/visitor/dummy/dummy.factor

@@ -11,12 +11,14 @@ M: f #push, 2drop ;
 M: f #shuffle, 3drop ;
 M: f #>r, 2drop ;
 M: f #r>, 2drop ;
-M: f #return, 2drop ;
-M: f #terminate, ;
+M: f #return, drop ;
+M: f #enter-recursive, 3drop ;
+M: f #return-recursive, 3drop ;
+M: f #terminate, drop ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
 M: f #phi, 2drop 2drop ;
 M: f #declare, drop ;
-M: f #recursive, drop drop drop drop drop ;
+M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;

unfinished/stack-checker/visitor/visitor.factor

@@ -17,11 +17,13 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
 HOOK: #drop, stack-visitor ( values -- )
 HOOK: #>r, stack-visitor ( inputs outputs -- )
 HOOK: #r>, stack-visitor ( inputs outputs -- )
-HOOK: #terminate, stack-visitor ( -- )
+HOOK: #terminate, stack-visitor ( stack -- )
 HOOK: #if, stack-visitor ( ? true false -- )
 HOOK: #dispatch, stack-visitor ( n branches -- )
 HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
 HOOK: #declare, stack-visitor ( declaration -- )
-HOOK: #return, stack-visitor ( label stack -- )
-HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
+HOOK: #return, stack-visitor ( stack -- )
+HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
+HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
+HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
 HOOK: #copy, stack-visitor ( inputs outputs -- )