1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel assocs arrays namespaces accessors sequences deques fry
4 search-deques dlists combinators.short-circuit make sets compiler.tree ;
5 IN: compiler.tree.recursive
7 TUPLE: call-site tail? node label ;
9 : recursive-phi-in ( #enter-recursive -- seq )
10 [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
14 TUPLE: call-tree-node label children calls ;
16 : (tail-calls) ( tail? seq -- seq' )
17 reverse [ swap [ and ] keep ] map nip reverse ;
19 : tail-calls ( tail? node -- seq )
24 [ #return-recursive? ]
28 SYMBOLS: children calls ;
30 GENERIC: node-call-tree ( tail? node -- )
32 : (build-call-tree) ( tail? nodes -- )
34 [ node-call-tree ] 2each ;
36 : build-call-tree ( nodes -- labels calls )
38 V{ } clone children set
40 [ t ] dip (build-call-tree)
45 M: #return-recursive node-call-tree
46 nip dup label>> (>>return) ;
48 M: #call-recursive node-call-tree
49 [ dup label>> call-site boa ] keep
50 [ drop calls get push ]
51 [ label>> calls>> push ] 2bi ;
53 M: #recursive node-call-tree
55 [ label>> V{ } clone >>calls drop ]
57 [ label>> ] [ child>> build-call-tree ] bi
58 call-tree-node boa children get push
61 M: #branch node-call-tree
62 children>> [ (build-call-tree) ] with each ;
64 M: node node-call-tree 2drop ;
66 SYMBOLS: not-loops recursive-nesting ;
68 : not-a-loop ( label -- ) not-loops get conjoin ;
70 : not-a-loop? ( label -- ? ) not-loops get key? ;
72 : non-tail-calls ( call-tree-node -- seq )
73 calls>> [ tail?>> not ] filter ;
75 : visit-back-edges ( call-tree -- )
77 [ non-tail-calls [ label>> not-a-loop ] each ]
78 [ children>> visit-back-edges ]
84 : check-cross-frame-call ( call-site -- )
85 label>> dup not-a-loop? [ drop ] [
86 recursive-nesting get <reversed> [
87 2dup eq? [ 2drop f ] [
88 not-a-loop? [ not-a-loop changed? on ] [ drop ] if t
93 : detect-cross-frame-calls ( call-tree -- )
94 ! Suppose we have a nesting of recursives A --> B --> C
95 ! B tail-calls A, and C non-tail-calls B. Then A cannot be
96 ! a loop, it needs its own procedure, since the call from
97 ! C to A crosses a call-frame boundary.
99 [ label>> recursive-nesting get push ]
100 [ calls>> [ check-cross-frame-call ] each ]
101 [ children>> detect-cross-frame-calls ] tri
102 recursive-nesting get pop*
105 : while-changing ( quot: ( -- ) -- )
107 [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
110 : detect-loops ( call-tree -- )
111 H{ } clone not-loops set
112 V{ } clone recursive-nesting set
114 [ '[ _ detect-cross-frame-calls ] while-changing ]
117 : mark-loops ( call-tree -- )
119 [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
120 [ children>> mark-loops ]
126 : analyze-recursive ( nodes -- nodes )
127 dup build-call-tree drop
128 [ detect-loops ] [ mark-loops ] bi ;