1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel arrays sequences math math.order
4 math.partial-dispatch generic generic.standard generic.single generic.math
5 classes.algebra classes.union sets quotations assocs combinators
6 words namespaces continuations classes fry combinators.smart hints
10 compiler.tree.recursive
11 compiler.tree.combinators
12 compiler.tree.normalization
13 compiler.tree.propagation.info
14 compiler.tree.propagation.nodes ;
15 IN: compiler.tree.propagation.inlining
17 ! We count nodes up-front; if there are relatively few nodes,
18 ! we are more eager to inline
21 : count-nodes ( nodes -- n )
22 0 swap [ drop 1 + ] each-node ;
24 : compute-node-count ( nodes -- ) count-nodes node-count set ;
26 ! We try not to inline the same word too many times, to avoid
27 ! combinatorial explosion
28 SYMBOL: inlining-count
31 : splicing-call ( #call word -- nodes )
32 [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
34 : open-code-#call ( #call word/quot -- nodes/f )
35 [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
37 : splicing-body ( #call quot/word -- nodes/f )
38 open-code-#call dup [ analyze-recursive normalize ] when ;
40 ! Dispatch elimination
41 : undo-inlining ( #call -- ? )
42 f >>method f >>body f >>class drop f ;
44 : propagate-body ( #call -- ? )
45 body>> (propagate) t ;
47 GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
49 M: word splicing-nodes splicing-call ;
51 M: callable splicing-nodes splicing-body ;
53 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
56 over method>> over = [ drop propagate-body ] [
57 2dup splicing-nodes dup [
58 [ >>method ] [ >>body ] bi* propagate-body
59 ] [ 2drop undo-inlining ] if
61 ] [ 2drop undo-inlining ] if ;
63 : inlining-standard-method ( #call word -- class/f method/f )
64 dup "methods" word-prop assoc-empty? [ 2drop f f ] [
65 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
66 [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
67 [ swap nth value-info class>> dup ] dip
72 : inline-standard-method ( #call word -- ? )
73 dupd inlining-standard-method eliminate-dispatch ;
75 : normalize-math-class ( class -- class' )
83 } [ class<= ] with find nip ;
85 : inlining-math-method ( #call word -- class/f quot/f )
87 first2 [ value-info class>> normalize-math-class ] bi@
89 [ math-method* ] [ 3drop f ] if
92 : inline-math-method ( #call word -- ? )
93 dupd inlining-math-method eliminate-dispatch ;
95 : inlining-math-partial ( #call word -- class/f quot/f )
96 [ "derived-from" word-prop first inlining-math-method ]
97 [ nip 1quotation ] 2bi
98 [ = not ] [ drop ] 2bi and ;
100 : inline-math-partial ( #call word -- ? )
101 dupd inlining-math-partial eliminate-dispatch ;
103 ! Method body inlining
104 SYMBOL: recursive-calls
107 : word-flat-length ( word -- n )
110 { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
112 { [ dup inline? not ] [ drop 1 ] }
113 ! recursive and inline
114 { [ dup recursive-calls get key? ] [ drop 10 ] }
116 [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
119 : (flat-length) ( seq -- n )
122 { [ dup quotation? ] [ (flat-length) 2 + ] }
123 { [ dup array? ] [ (flat-length) ] }
124 { [ dup word? ] [ word-flat-length ] }
129 : flat-length ( word -- n )
130 H{ } clone recursive-calls [
131 [ recursive-calls get conjoin ]
132 [ def>> (flat-length) 5 /i ]
136 : classes-known? ( #call -- ? )
139 [ class-types length 1 = ]
144 : node-count-bias ( -- n )
145 45 node-count get [-] 8 /i ;
147 : body-length-bias ( word -- n )
148 [ flat-length ] [ inlining-count get at 0 or ] bi
149 over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ;
151 : inlining-rank ( #call word -- n )
153 [ classes-known? 2 0 ? ]
156 [ "specializer" word-prop 1 0 ? ]
157 [ method-body? 1 0 ? ]
160 loop-nesting get 0 or 2 *
164 : should-inline? ( #call word -- ? )
165 dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
169 : already-inlined? ( obj -- ? ) history get memq? ;
171 : add-to-history ( obj -- ) history [ swap suffix ] change ;
173 : remember-inlining ( word -- )
174 [ inlining-count get inc-at ]
178 :: inline-word ( #call word -- ? )
179 word already-inlined? [ f ] [
180 #call word splicing-body [
182 word remember-inlining
183 [ ] [ count-nodes ] [ (propagate) ] tri
185 [ #call (>>body) ] [ node-count +@ ] bi* t
189 : inline-method-body ( #call word -- ? )
190 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
192 : always-inline-word? ( word -- ? )
193 { curry compose } memq? ;
195 : never-inline-word? ( word -- ? )
196 [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
198 : custom-inlining? ( word -- ? )
199 "custom-inlining" word-prop ;
201 : inline-custom ( #call word -- ? )
202 [ dup ] [ "custom-inlining" word-prop ] bi*
203 call( #call -- word/quot/f )
204 object swap eliminate-dispatch ;
206 : (do-inlining) ( #call word -- ? )
207 #! If the generic was defined in an outer compilation unit,
208 #! then it doesn't have a definition yet; the definition
209 #! is built at the end of the compilation unit. We do not
210 #! attempt inlining at this stage since the stack discipline
211 #! is not finalized yet, so dispatch# might return an out
212 #! of bounds value. This case comes up if a parsing word
213 #! calls the compiler at parse time (doing so is
214 #! discouraged, but it should still work.)
216 { [ dup never-inline-word? ] [ 2drop f ] }
217 { [ dup always-inline-word? ] [ inline-word ] }
218 { [ dup standard-generic? ] [ inline-standard-method ] }
219 { [ dup math-generic? ] [ inline-math-method ] }
220 { [ dup method-body? ] [ inline-method-body ] }
224 : do-inlining ( #call word -- ? )
225 #! Note the logic here: if there's a custom inlining hook,
226 #! it is permitted to return f, which means that we try the
227 #! normal inlining heuristic.
228 dup custom-inlining? [ 2dup inline-custom ] [ f ] if
229 [ 2drop t ] [ (do-inlining) ] if ;