1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generic assocs inference inference.class
4 inference.dataflow inference.backend inference.state io kernel
5 math namespaces sequences vectors words quotations hashtables
6 combinators classes classes.algebra generic.math continuations
7 optimizer.def-use optimizer.backend generic.standard ;
16 ! #if ----> #merge ----> #return
24 ! NOT A LOOP (call to A not in tail position):
29 ! #if ----> ... ----> #merge ----> #return
39 ! NOT A LOOP (call to A nested inside another label which is
45 ! #if ----> #merge ----> ... ----> #return
62 ! Mapping word => { node { nesting tail? }+ height }
63 ! We record all calls to a label, their control nesting and
64 ! whether it is a tail call or not
67 GENERIC: collect-label-info* ( node -- )
69 M: #label collect-label-info*
70 [ V{ } clone node-stack get length 3array ] keep
71 node-param label-info get set-at ;
73 M: #call-label collect-label-info*
74 node-param label-info get at
75 node-stack get over third tail
76 [ [ #label? ] filter [ node-param ] map ] keep
77 [ node-successor #tail? ] all? 2array
80 M: node collect-label-info*
83 : collect-label-info ( node -- )
84 H{ } clone label-info set
85 [ collect-label-info* ] each-node ;
87 ! Mapping word => label
88 SYMBOL: potential-loops
90 : remove-non-tail-calls ( -- )
92 [ nip second [ second ] all? ] assoc-filter
96 : remove-non-loop-calls ( -- )
97 ! Boolean is set to t if something changed.
98 ! We recurse until a fixed point is reached.
100 ! If label X is called from within a label Y that is
101 ! no longer a potential loop, then X is no longer a
102 ! potential loop either.
103 over potential-loops get key? [
104 second [ first ] map concat
105 potential-loops get [ key? ] curry all?
106 [ drop ] [ potential-loops get delete-at t or ] if
108 ] assoc-each [ remove-non-loop-calls ] when ;
110 : detect-loops ( node -- node )
114 remove-non-tail-calls
115 remove-non-loop-calls
116 potential-loops get [
117 nip t swap set-#label-loop?
121 ! ! ! Constant branch folding
125 ! #if ----> #merge ----> C
145 : fold-branch ( node branch# -- node )
146 over node-children nth
147 swap node-successor over splice-node ;
150 : known-boolean-value? ( node value -- value ? )
155 { [ dup null class<= ] [ drop f f ] }
156 { [ dup \ f class-not class<= ] [ drop t t ] }
157 { [ dup \ f class<= ] [ drop f t ] }
162 : fold-if-branch? ( node -- value ? )
163 dup node-in-d first known-boolean-value? ;
165 : fold-if-branch ( node value -- node' )
168 r> [ set-node-successor ] keep ;
170 ! ! ! Lifting code after a conditional if one branch throws
174 ! #if ----> #merge ----> B ----> #return/#values
185 ! #if ----> #merge (*) ----> #return/#values (**)
200 ! (*) has the same outputs as the inputs of (**), and it is not
201 ! the same node as (***)
203 ! Note: if (**) is #return is is sound to put #terminate there,
204 ! but not if (**) is #
206 : only-one ( seq -- elt/f )
207 dup length 1 = [ first ] [ drop f ] if ;
209 : lift-throw-tail? ( #if -- tail/? )
210 dup node-successor #tail?
211 [ drop f ] [ active-children only-one ] if ;
213 : clone-node ( node -- newnode )
214 clone dup [ clone ] modify-values ;
216 : lift-branch ( node tail -- )
219 dup node-in-d \ #merge out-node
220 [ set-node-successor ] keep -rot
221 >r dup node-successor r> splice-node
224 M: #if optimize-node*
225 dup fold-if-branch? [ fold-if-branch t ] [
226 drop dup lift-throw-tail? dup [
233 ! Loop tail hoising: code after a loop can sometimes go in the
234 ! non-recursive branch of the loop
238 ! #label -> C -> #return 1
240 ! -> #if -> #merge (*) -> #return 2
254 ! #label -> #return 1
256 ! -> #if -------> #merge (*) -> #return 2
257 ! | \-------------------/
260 ! A B unreacachable code needed to
261 ! | | preserve invariants
270 : find-tail ( node -- tail )
272 dup node-successor #tail? [
273 node-successor find-tail
277 : child-tails ( node -- seq )
278 node-children [ find-tail ] map ;
280 GENERIC: add-loop-exit* ( label node -- )
282 M: #branch add-loop-exit*
283 child-tails [ add-loop-exit* ] with each ;
285 M: #call-label add-loop-exit*
286 tuck node-param eq? [ drop ] [ node-successor , ] if ;
288 M: #terminate add-loop-exit*
291 M: node add-loop-exit*
292 nip node-successor dup #terminate? [ drop ] [ , ] if ;
294 : find-loop-exits ( label node -- seq )
295 [ add-loop-exit* ] { } make ;
297 : find-final-if ( node -- #if/f )
300 dup node-successor #tail? [
301 node-successor find-final-if
304 node-successor find-final-if
308 : detach-node-successor ( node -- successor )
309 dup node-successor #terminate rot set-node-successor ;
311 : lift-loop-tail? ( #label -- tail/f )
312 dup node-successor node-successor [
313 dup node-param swap node-child find-final-if dup [
314 find-loop-exits only-one
318 M: #loop optimize-node*
319 dup lift-loop-tail? dup [
320 last-node "values" set
322 dup node-successor "tail" set
323 dup node-successor last-node "return" set
324 dup node-child find-final-if node-successor "merge" set
327 "return" get clone-node over set-node-successor
329 "merge" get clone-node "tail" get over set-node-successor
330 ! #values -> #merge ->C
331 "values" get set-node-successor