From 9d248286045f3dd8f003c4292d711be65d2f813a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Jul 2008 22:47:40 -0500 Subject: [PATCH] Beefed up normalization pass cleans up stack usage, simplifying recursive propagation --- .../tree/combinators/combinators-tests.factor | 1 + .../tree/combinators/combinators.factor | 15 +++- .../tree/copy-equiv/copy-equiv.factor | 7 -- .../normalization/normalization-tests.factor | 10 +-- .../tree/normalization/normalization.factor | 79 +++++++++++++------ .../tree/propagation/propagation-tests.factor | 7 ++ .../propagation/recursive/recursive.factor | 35 +++----- .../stack-checker/inlining/inlining.factor | 2 +- 8 files changed, 95 insertions(+), 61 deletions(-) diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor index 12ab7e3563..66ad5e11f4 100644 --- a/unfinished/compiler/tree/combinators/combinators-tests.factor +++ b/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 diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index 94bcdb2d95..eafbb198a1 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/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 diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index 2b7b6c5ecb..a414554efc 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/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 ) diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor index 39a71ad0a6..91c11f3be6 100644 --- a/unfinished/compiler/tree/normalization/normalization-tests.factor +++ b/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 diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor index 38fa3e11b3..976d51dfb6 100644 --- a/unfinished/compiler/tree/normalization/normalization.factor +++ b/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 ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index f15927c8f4..6deb80947a 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/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 diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index e1905d5b44..8f50add191 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/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 diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 5dc159bcc4..ace1a043cb 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/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 ; : ( word -- label ) inline-recursive new