steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-07-27 22:47:40 -05:00
parent 9cc761d899
commit 9d24828604
8 changed files with 95 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
unfinished/compiler/tree/combinators/combinators-tests.factor
View File

@ -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

15
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -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

7
unfinished/compiler/tree/copy-equiv/copy-equiv.factor
View File

@ -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 )

10
unfinished/compiler/tree/normalization/normalization-tests.factor
View File

@ -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

79
unfinished/compiler/tree/normalization/normalization.factor
View File

@ -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 ;

7
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

35
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -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

2
unfinished/stack-checker/inlining/inlining.factor
View File

@ -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