1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel arrays sequences math math.order call
4 math.partial-dispatch generic generic.standard generic.math
5 classes.algebra classes.union sets quotations assocs combinators
6 words namespaces continuations classes fry combinators.smart
9 compiler.tree.recursive
10 compiler.tree.combinators
11 compiler.tree.normalization
12 compiler.tree.propagation.info
13 compiler.tree.propagation.nodes ;
14 IN: compiler.tree.propagation.inlining
16 ! We count nodes up-front; if there are relatively few nodes,
17 ! we are more eager to inline
20 : count-nodes ( nodes -- n )
21 0 swap [ drop 1+ ] each-node ;
23 : compute-node-count ( nodes -- ) count-nodes node-count set ;
25 ! We try not to inline the same word too many times, to avoid
26 ! combinatorial explosion
27 SYMBOL: inlining-count
30 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
32 M: word splicing-nodes
33 [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
35 M: callable splicing-nodes
36 build-sub-tree analyze-recursive normalize ;
38 ! Dispatch elimination
39 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
42 over method>> over = [ drop ] [
44 [ >>method ] [ >>body ] bi*
47 ] [ 2drop f >>method f >>body f >>class drop f ] if ;
49 : inlining-standard-method ( #call word -- class/f method/f )
50 dup "methods" word-prop assoc-empty? [ 2drop f f ] [
51 [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
52 [ swap nth value-info class>> dup ] dip
56 : inline-standard-method ( #call word -- ? )
57 dupd inlining-standard-method eliminate-dispatch ;
59 : normalize-math-class ( class -- class' )
67 } [ class<= ] with find nip ;
69 : inlining-math-method ( #call word -- class/f quot/f )
71 first2 [ value-info class>> normalize-math-class ] bi@
73 [ math-method* ] [ 3drop f ] if
76 : inline-math-method ( #call word -- ? )
77 dupd inlining-math-method eliminate-dispatch ;
79 : inlining-math-partial ( #call word -- class/f quot/f )
80 [ "derived-from" word-prop first inlining-math-method ]
81 [ nip 1quotation ] 2bi
82 [ = not ] [ drop ] 2bi and ;
84 : inline-math-partial ( #call word -- ? )
85 dupd inlining-math-partial eliminate-dispatch ;
87 ! Method body inlining
88 SYMBOL: recursive-calls
91 : word-flat-length ( word -- n )
94 { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
96 { [ dup inline? not ] [ drop 1 ] }
97 ! recursive and inline
98 { [ dup recursive-calls get key? ] [ drop 10 ] }
100 [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
103 : (flat-length) ( seq -- n )
106 { [ dup quotation? ] [ (flat-length) 2 + ] }
107 { [ dup array? ] [ (flat-length) ] }
108 { [ dup word? ] [ word-flat-length ] }
113 : flat-length ( word -- n )
114 H{ } clone recursive-calls [
115 [ recursive-calls get conjoin ]
116 [ def>> (flat-length) 5 /i ]
120 : classes-known? ( #call -- ? )
123 [ class-types length 1 = ]
128 : node-count-bias ( -- n )
129 45 node-count get [-] 8 /i ;
131 : body-length-bias ( word -- n )
132 [ flat-length ] [ inlining-count get at 0 or ] bi
133 over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
135 : inlining-rank ( #call word -- n )
137 [ classes-known? 2 0 ? ]
141 [ "default" word-prop -4 0 ? ]
142 [ "specializer" word-prop 1 0 ? ]
143 [ method-body? 1 0 ? ]
146 loop-nesting get 0 or 2 *
150 : should-inline? ( #call word -- ? )
151 dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
155 : remember-inlining ( word -- )
156 [ inlining-count get inc-at ]
157 [ history [ swap suffix ] change ]
160 : inline-word-def ( #call word quot -- ? )
161 over history get memq? [ 3drop f ] [
163 [ remember-inlining ] dip
164 [ drop ] [ splicing-nodes ] 2bi
165 [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
166 ] with-scope node-count +@
170 : inline-word ( #call word -- ? )
171 dup def>> inline-word-def ;
173 : inline-method-body ( #call word -- ? )
174 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
176 : always-inline-word? ( word -- ? )
177 { curry compose } memq? ;
179 : never-inline-word? ( word -- ? )
180 [ deferred? ] [ { call execute } memq? ] bi or ;
182 : custom-inlining? ( word -- ? )
183 "custom-inlining" word-prop ;
185 : inline-custom ( #call word -- ? )
186 [ dup ] [ "custom-inlining" word-prop ] bi*
187 call( #call -- word/quot/f )
188 object swap eliminate-dispatch ;
190 : inline-instance-check ( #call word -- ? )
191 over in-d>> second value-info literal>> dup class?
192 [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
194 : (do-inlining) ( #call word -- ? )
195 #! If the generic was defined in an outer compilation unit,
196 #! then it doesn't have a definition yet; the definition
197 #! is built at the end of the compilation unit. We do not
198 #! attempt inlining at this stage since the stack discipline
199 #! is not finalized yet, so dispatch# might return an out
200 #! of bounds value. This case comes up if a parsing word
201 #! calls the compiler at parse time (doing so is
202 #! discouraged, but it should still work.)
204 { [ dup never-inline-word? ] [ 2drop f ] }
205 { [ dup \ instance? eq? ] [ inline-instance-check ] }
206 { [ dup always-inline-word? ] [ inline-word ] }
207 { [ dup standard-generic? ] [ inline-standard-method ] }
208 { [ dup math-generic? ] [ inline-math-method ] }
209 { [ dup method-body? ] [ inline-method-body ] }
213 : do-inlining ( #call word -- ? )
214 #! Note the logic here: if there's a custom inlining hook,
215 #! it is permitted to return f, which means that we try the
216 #! normal inlining heuristic.
217 dup custom-inlining? [ 2dup inline-custom ] [ f ] if
218 [ 2drop t ] [ (do-inlining) ] if ;