Beefed up normalization pass cleans up stack usage, simplifying recursive propagation

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

@@ -2,3 +2,4 @@ IN: compiler.tree.combinators.tests
 USING: compiler.tree.combinators tools.test kernel ;
 
 { 1 0 } [ [ drop ] each-node ] must-infer-as
+{ 1 1 } [ [ ] map-nodes ] must-infer-as

unfinished/compiler/tree/combinators/combinators.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel accessors sequences compiler.tree ;
+USING: fry kernel accessors sequences sequences.deep
+compiler.tree ;
 IN: compiler.tree.combinators
 
 : each-node ( nodes quot -- )
@@ -15,3 +16,15 @@ IN: compiler.tree.combinators
             ] if
         ] bi
     ] each ; inline
+
+: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
+    dup dup '[
+        @
+        dup #branch? [
+            [ [ , map-nodes ] map ] change-children
+        ] [
+            dup #recursive? [
+                [ , map-nodes ] change-child
+            ] when
+        ] if
+    ] map flatten ; inline recursive

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

@@ -34,13 +34,6 @@ M: #copy compute-copy-equiv*
 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/normalization/normalization-tests.factor

@@ -2,18 +2,18 @@ IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.normalization
 compiler.tree sequences accessors tools.test kernel ;
 
-\ collect-introductions must-infer
+\ count-introductions must-infer
 \ fixup-enter-recursive must-infer
 \ eliminate-introductions must-infer
 \ normalize must-infer
 
-[ 3 ] [ [ 3drop 1 2 3 ] build-tree collect-introductions ] unit-test
+[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
 
-[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree collect-introductions ] unit-test
+[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
 
-[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test
+[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
 
-[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test
+[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
 
 : foo ( -- ) swap ; inline recursive
 

unfinished/compiler/tree/normalization/normalization.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math accessors kernel arrays
-stack-checker.backend compiler.tree compiler.tree.combinators ;
+USING: fry namespaces sequences math accessors kernel arrays
+stack-checker.backend stack-checker.inlining compiler.tree
+compiler.tree.combinators ;
 IN: compiler.tree.normalization
 
 ! A transform pass done before optimization can begin to
@@ -13,29 +14,52 @@ IN: compiler.tree.normalization
 !
 ! - We collect #return-recursive and #call-recursive nodes and
 ! store them in the #recursive's label slot.
-
-GENERIC: normalize* ( node -- )
+!
+! - We normalize #call-recursive as follows. The stack checker
+! says that the inputs of a #call-recursive are the entire stack
+! at the time of the call. This is a conservative estimate; we
+! don't know the exact number of stack values it touches until
+! the #return-recursive node has been visited, because of row
+! polymorphism. So in the normalize pass, we split a
+! #call-recursive into a #copy of the unchanged values and a
+! #call-recursive with trimmed inputs and outputs.
 
 ! Collect introductions
 SYMBOL: introductions
 
-GENERIC: collect-introductions* ( node -- )
+GENERIC: count-introductions* ( node -- )
 
-: collect-introductions ( nodes -- n )
+: count-introductions ( nodes -- n )
+    #! Note: we use each, not each-node, since the #branch
+    #! method recurses into children directly and we don't
+    #! recurse into #recursive at all.
     [
         0 introductions set
-        [ collect-introductions* ] each
+        [ count-introductions* ] each
         introductions get
     ] with-scope ;
 
-M: #introduce collect-introductions* drop introductions inc ;
+M: #introduce count-introductions* drop introductions inc ;
 
-M: #branch collect-introductions*
+M: #branch count-introductions*
     children>>
-    [ collect-introductions ] map supremum
+    [ count-introductions ] map supremum
     introductions [ + ] change ;
 
-M: node collect-introductions* drop ;
+M: node count-introductions* drop ;
+
+! Collect label info
+GENERIC: collect-label-info ( node -- )
+
+M: #return-recursive collect-label-info dup label>> (>>return) ;
+
+M: #call-recursive collect-label-info dup label>> calls>> push ;
+
+M: #recursive collect-label-info
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions drop ;
+
+M: node collect-label-info drop ;
 
 ! Eliminate introductions
 SYMBOL: introduction-stack
@@ -73,22 +97,29 @@ M: #phi eliminate-introductions*
 M: node eliminate-introductions* ;
 
 : eliminate-introductions ( recursive n -- )
-    make-values introduction-stack set
-    [ fixup-enter-recursive ]
-    [ child>> [ eliminate-introductions* ] change-each ] bi ;
+    make-values introduction-stack [
+        [ fixup-enter-recursive ]
+        [ child>> [ eliminate-introductions* ] change-each ] bi
+    ] with-variable ;
+
+! Normalize
+GENERIC: normalize* ( node -- node' )
 
 M: #recursive normalize*
-    [
-        [ child>> collect-introductions ]
-        [ swap eliminate-introductions ]
-        bi
-    ] with-scope ;
+    dup dup label>> introductions>> eliminate-introductions ;
 
-! Collect label info
-M: #return-recursive normalize* dup label>> (>>return) ;
+: unchanged-underneath ( #call-recursive -- n )
+    [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 
-M: #call-recursive normalize* dup label>> calls>> push ;
+M: #call-recursive normalize*
+    dup unchanged-underneath
+    [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
+    [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
+    2bi 2array ;
 
-M: node normalize* drop ;
+M: node normalize* ;
 
-: normalize ( node -- node ) dup [ normalize* ] each-node ;
+: normalize ( nodes -- nodes' )
+    [ [ collect-label-info ] each-node ]
+    [ [ normalize* ] map-nodes ]
+    bi ;

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

@@ -406,3 +406,10 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     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
+
+: recursive-test-7 ( a -- b )
+    dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
+
+[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test

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

@@ -10,33 +10,25 @@ compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
-! row polymorphism is causing problems
-
-: longest-suffix ( seq1 seq2 -- seq1' seq2' )
-    2dup min-length [ tail-slice* ] curry bi@ ;
-
-: suffixes= ( seq1 seq2 -- ? )
-    longest-suffix sequence= ;
-
 : check-fixed-point ( node infos1 infos2 -- node )
-    suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline
+    sequence= [ 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 ;
+    [ label>> calls>> [ node-input-infos ] map flip ]
+    [ in-d>> [ value-info ] map ] bi ;
 
-: generalize-counter-interval ( i1 i2 -- i3 )
+: generalize-counter-interval ( interval initial-interval -- interval' )
     {
-        { [ 2dup interval<= ] [ 1./0. [a,a] ] }
-        { [ 2dup interval>= ] [ -1./0. [a,a] ] }
+        { [ 2dup = ] [ 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 ;
 
 : generalize-counter ( info' initial -- info )
     [ drop clone ] [ [ interval>> ] bi@ ] 2bi
-    generalize-counter-interval >>interval
-    f >>literal? f >>literal ;
+    generalize-counter-interval >>interval ;
 
 : unify-recursive-stacks ( stacks initial -- infos )
     over empty? [ nip ] [
@@ -72,12 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
     [ generalize-return-interval ] map ;
 
 M: #call-recursive propagate-before ( #call-label -- )
-    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 ;
+    dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
+    [ check-fixed-point ] keep
+    generalize-return swap out-d>> set-value-infos ;
 
 M: #return-recursive propagate-before ( #return-recursive -- )
     dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi

unfinished/stack-checker/inlining/inlining.factor

@@ -17,7 +17,7 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive word enter-out return calls fixed-point ;
+TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new