Beefed up normalization pass cleans up stack usage, simplifying recursive propagation
parent
9cc761d899
commit
9d24828604
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue