1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel assocs arrays namespaces accessors sequences deques
4 search-deques dlists compiler.tree compiler.tree.combinators ;
5 IN: compiler.tree.recursive
8 GENERIC: collect-label-info ( node -- )
10 M: #return-recursive collect-label-info
11 dup label>> (>>return) ;
13 M: #call-recursive collect-label-info
14 dup label>> calls>> push ;
16 M: #recursive collect-label-info
17 label>> V{ } clone >>calls drop ;
19 M: node collect-label-info drop ;
21 ! A loop is a #recursive which only tail calls itself, and those
22 ! calls are nested inside other loops only. We optimistically
23 ! assume all #recursive nodes are loops, disqualifying them as
24 ! we see evidence to the contrary.
25 : (tail-calls) ( tail? seq -- seq' )
26 reverse [ swap [ and ] keep ] map nip reverse ;
28 : tail-calls ( tail? node -- seq )
32 [ #return-recursive? ]
41 GENERIC: collect-loop-info* ( tail? node -- )
43 : non-tail-label-info ( nodes -- )
44 [ f swap collect-loop-info* ] each ;
46 : (collect-loop-info) ( tail? nodes -- )
47 [ tail-calls ] keep [ collect-loop-info* ] 2each ;
49 : remember-loop-info ( label -- )
50 loop-stack get length swap loop-heights get set-at ;
52 M: #recursive collect-loop-info*
56 [ swap 2array loop-stack [ swap suffix ] change ]
57 [ remember-loop-info ]
61 [ t swap child>> (collect-loop-info) ] bi
64 : current-loop-nesting ( label -- alist )
65 loop-stack get swap loop-heights get at tail ;
67 : disqualify-loop ( label -- )
68 work-list get push-front ;
70 M: #call-recursive collect-loop-info*
72 swap [ dup disqualify-loop ] unless
73 dup current-loop-nesting
74 [ keys [ loop-calls get push-at ] with each ]
75 [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
78 M: #if collect-loop-info*
79 children>> [ (collect-loop-info) ] with each ;
81 M: #dispatch collect-loop-info*
82 children>> [ (collect-loop-info) ] with each ;
84 M: node collect-loop-info* 2drop ;
86 : collect-loop-info ( node -- )
88 H{ } clone loop-calls set
89 H{ } clone loop-heights set
90 <hashed-dlist> work-list set
91 t swap (collect-loop-info) ;
93 : disqualify-loops ( -- )
97 [ loop-calls get at [ disqualify-loop ] each ]
102 : analyze-recursive ( nodes -- nodes )
103 dup [ collect-label-info ] each-node
104 dup collect-loop-info disqualify-loops ;