1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays generic assocs inference inference.class
4 inference.dataflow inference.backend inference.state io kernel
5 math math.order namespaces sequences vectors words quotations
6 hashtables combinators effects classes classes.union
7 classes.algebra generic.math optimizer.math.partial
8 continuations optimizer.def-use optimizer.backend
9 generic.standard optimizer.specializers optimizer.def-use
10 optimizer.pattern-match generic.standard optimizer.control
11 kernel.private definitions sets summary ;
12 IN: optimizer.inlining
14 : remember-inlining ( node history -- )
15 [ swap set-node-history ] curry each-node ;
17 : inlining-quot ( node quot -- node )
18 over node-in-d dataflow-with
19 dup rot infer-classes/node ;
21 : splice-quot ( #call quot history -- node )
22 #! Must add history *before* splicing in, otherwise
23 #! the rest of the IR will also remember the history
24 pick node-history append
25 >r dupd inlining-quot dup r> remember-inlining
28 ! A heuristic to avoid excessive inlining
29 SYMBOL: recursive-calls
32 : word-flat-length ( word -- n )
35 { [ dup inline? not ] [ drop 1 ] }
36 ! recursive and inline
37 { [ dup recursive-calls get key? ] [ drop 10 ] }
39 [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
42 : (flat-length) ( seq -- n )
45 { [ dup quotation? ] [ (flat-length) 2 + ] }
46 { [ dup array? ] [ (flat-length) ] }
47 { [ dup word? ] [ word-flat-length ] }
52 : flat-length ( word -- n )
53 H{ } clone recursive-calls [
54 [ recursive-calls get conjoin ]
55 [ def>> (flat-length) 5 /i ]
59 ! Single dispatch method inlining optimization
60 ! : dispatching-class ( node generic -- method/f )
61 ! tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
62 ! [ node-literal swap single-effective-method ]
63 ! [ node-class swap specific-method ]
66 : dispatching-class ( node generic -- method/f )
67 tuck dispatch# over in-d>> <reversed> ?nth
68 node-class swap specific-method ;
70 : inline-standard-method ( node generic -- node )
71 dupd dispatching-class dup
72 [ 1quotation f splice-quot ] [ 2drop t ] if ;
74 ! Partial dispatch of math-generic words
75 : normalize-math-class ( class -- class' )
83 } [ class<= ] with find nip ;
85 : inlining-math-method ( #call word -- quot/f )
86 swap node-input-classes
87 [ first normalize-math-class ]
88 [ second normalize-math-class ] bi
89 3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
91 : inline-math-method ( #call word -- node/t )
92 [ drop ] [ inlining-math-method ] 2bi
93 dup [ f splice-quot ] [ 2drop t ] if ;
95 : inline-math-partial ( #call word -- node/t )
98 "derived-from" word-prop first
99 inlining-math-method dup
101 [ nip 1quotation ] 2tri
102 [ = not ] [ drop ] 2bi and
103 [ f splice-quot ] [ 2drop t ] if ;
105 : inline-method ( #call -- node )
107 { [ dup standard-generic? ] [ inline-standard-method ] }
108 { [ dup math-generic? ] [ inline-math-method ] }
109 { [ dup math-partial? ] [ inline-math-partial ] }
113 : literal-quot ( node literals -- quot )
114 #! Outputs a quotation which drops the node's inputs, and
115 #! pushes some literals.
116 >r node-in-d length \ drop <repetition>
117 r> [ literalize ] map append >quotation ;
119 : inline-literals ( node literals -- node )
120 #! Make #shuffle -> #push -> #return -> successor
121 dupd literal-quot f splice-quot ;
123 ! Resolve type checks at compile time where possible
124 : comparable? ( actual testing -- ? )
125 #! If actual is a subset of testing or if the two classes
126 #! are disjoint, return t.
127 2dup class<= >r classes-intersect? not r> or ;
129 : optimize-check? ( #call value class -- ? )
130 >r node-class r> comparable? ;
132 : evaluate-check ( node value class -- ? )
133 >r node-class r> class<= ;
135 : optimize-check ( #call value class -- node )
136 #! If the predicate is followed by a branch we fold it
138 [ evaluate-check ] [ 2drop ] 3bi
139 dup successor>> #if? [
141 successor>> swap 0 1 ? fold-branch
144 swap 1array inline-literals
147 : (optimize-predicate) ( #call -- #call value class )
148 [ ] [ in-d>> first ] [ param>> "predicating" word-prop ] tri ;
150 : optimize-predicate? ( #call -- ? )
151 dup param>> "predicating" word-prop [
152 (optimize-predicate) optimize-check?
155 : optimize-predicate ( #call -- node )
156 (optimize-predicate) optimize-check ;
158 : flush-eval? ( #call -- ? )
159 dup node-param "flushable" word-prop
160 [ node-out-d [ unused? ] all? ] [ drop f ] if ;
162 ERROR: flushed-eval-error word ;
164 M: flushed-eval-error summary
165 drop "Flushed evaluation of word would have thrown an error" ;
167 : flushed-eval-quot ( #call -- quot )
168 #! A quotation to replace flushed evaluations with. We can't
169 #! just remove the code altogether, because if the optimizer
170 #! knows the input types of a word, it assumes the inputs are
171 #! of this type after the word returns, since presumably
172 #! the word would have checked input types itself. However,
173 #! if the word gets flushed, then it won't do this checking;
174 #! so we have to do it here.
176 dup param>> "input-classes" word-prop [
178 [ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
181 dup in-d>> length [ \ drop , ] times
182 out-d>> length [ f , ] times
185 : flush-eval ( #call -- node )
186 dup param>> +inlined+ depends-on
187 dup flushed-eval-quot f splice-quot ;
189 : partial-eval? ( #call -- ? )
190 dup node-param "foldable" word-prop [
191 dup node-in-d [ node-literal? ] with all?
196 : literal-in-d ( #call -- inputs )
197 dup node-in-d [ node-literal ] with map ;
199 : partial-eval ( #call -- node )
200 dup node-param +inlined+ depends-on
201 dup literal-in-d over node-param 1quotation
202 [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
204 : define-identities ( words identities -- )
205 [ "identities" set-word-prop ] curry each ;
207 : find-identity ( node -- quot )
208 [ node-param "identities" word-prop ] keep
209 [ swap first in-d-match? ] curry find
210 nip dup [ second ] when ;
212 : apply-identities ( node -- node/f )
213 dup find-identity f splice-quot ;
215 : splice-word-def ( #call word def -- node )
216 [ drop +inlined+ depends-on ] [ swap 1array ] 2bi
219 : classes-known? ( #call -- ? )
221 [ class-types length 1 = ]
226 : inlining-rank ( #call -- n )
228 [ param>> flat-length 24 swap [-] 4 /i ]
229 [ param>> "default" word-prop -4 0 ? ]
230 [ param>> "specializer" word-prop 1 0 ? ]
231 [ param>> method-body? 1 0 ? ]
232 [ classes-known? 2 0 ? ]
235 : should-inline? ( #call -- ? )
238 : optimistic-inline? ( #call -- ? )
239 dup param>> "specializer" word-prop
240 [ should-inline? ] [ drop f ] if ;
242 : already-inlined? ( #call -- ? )
243 [ param>> ] [ history>> ] bi memq? ;
245 : optimistic-inline ( #call -- node )
246 dup already-inlined? [ drop t ] [
247 dup param>> dup def>> splice-word-def
250 : method-body-inline? ( #call -- ? )
251 dup param>> method-body?
252 [ should-inline? ] [ drop f ] if ;
254 M: #call optimize-node*
256 { [ dup flush-eval? ] [ flush-eval ] }
257 { [ dup partial-eval? ] [ partial-eval ] }
258 { [ dup find-identity ] [ apply-identities ] }
259 { [ dup optimizer-hook ] [ optimize-hook ] }
260 { [ dup optimize-predicate? ] [ optimize-predicate ] }
261 { [ dup optimistic-inline? ] [ optimistic-inline ] }
262 { [ dup method-body-inline? ] [ optimistic-inline ] }