USING: compiler.tree.combinators tools.test kernel ;
{ 1 0 } [ [ drop ] each-node ] must-infer-as
+{ 1 1 } [ [ ] map-nodes ] must-infer-as
! 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 -- )
] 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
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 )
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
! 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
!
! - 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
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 ;
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
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 ] [
[ 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
: (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