1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators.short-circuit compiler.tree fry
4 kernel namespaces sequences sets ;
5 FROM: namespaces => set ;
6 IN: compiler.tree.recursive
8 TUPLE: call-site tail? node label ;
10 : recursive-phi-in ( #enter-recursive -- seq )
11 [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
15 TUPLE: call-graph-node tail? label children calls ;
17 : (tail-calls) ( tail? seq -- seq' )
18 reverse [ swap [ and ] keep ] map nip reverse ;
20 : tail-calls ( tail? node -- seq )
25 [ #return-recursive? ]
29 SYMBOLS: children calls ;
31 GENERIC: node-call-graph ( tail? node -- )
33 : (build-call-graph) ( tail? nodes -- )
35 [ node-call-graph ] 2each ;
37 : build-call-graph ( nodes -- labels calls )
39 V{ } clone children set
41 [ t ] dip (build-call-graph)
46 M: #return-recursive node-call-graph
47 nip dup label>> return<< ;
49 M: #call-recursive node-call-graph
50 [ dup label>> call-site boa ] keep
51 [ drop calls get push ]
52 [ label>> calls>> push ] 2bi ;
54 M: #recursive node-call-graph
55 [ label>> V{ } clone >>calls drop ]
57 [ label>> ] [ child>> build-call-graph ] bi
58 call-graph-node boa children get push
61 M: #branch node-call-graph
62 children>> [ (build-call-graph) ] with each ;
64 M: #alien-callback node-call-graph
65 child>> (build-call-graph) ;
67 M: node node-call-graph 2drop ;
69 SYMBOLS: not-loops recursive-nesting ;
71 : not-a-loop ( label -- ) not-loops get adjoin ;
73 : not-a-loop? ( label -- ? ) not-loops get in? ;
75 : non-tail-calls ( call-graph-node -- seq )
76 calls>> [ tail?>> not ] filter ;
78 : visit-back-edges ( call-graph -- )
80 [ non-tail-calls [ label>> not-a-loop ] each ]
81 [ children>> visit-back-edges ]
87 : check-cross-frame-call ( call-site -- )
88 label>> dup not-a-loop? [ drop ] [
89 recursive-nesting get <reversed> [
90 2dup label>> eq? [ 2drop f ] [
91 [ label>> not-a-loop? ] [ tail?>> not ] bi or
92 [ not-a-loop changed? on ] [ drop ] if t
97 : detect-cross-frame-calls ( call-graph -- )
98 ! Suppose we have a nesting of recursives A --> B --> C
99 ! B tail-calls A, and C non-tail-calls B. Then A cannot be
100 ! a loop, it needs its own procedure, since the call from
101 ! C to A crosses a call-frame boundary.
103 [ recursive-nesting get push ]
104 [ calls>> [ check-cross-frame-call ] each ]
105 [ children>> detect-cross-frame-calls ] tri
106 recursive-nesting get pop*
109 : while-changing ( ... quot: ( ... -- ... ) -- ... )
111 [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
114 : detect-loops ( call-graph -- )
115 HS{ } clone not-loops set
116 V{ } clone recursive-nesting set
118 [ '[ _ detect-cross-frame-calls ] while-changing ]
121 : mark-loops ( call-graph -- )
123 [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
124 [ children>> mark-loops ]
132 : analyze-recursive ( nodes -- nodes )
133 dup build-call-graph drop