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 namespaces sequences vectors words quotations hashtables
6 combinators classes classes.algebra generic.math
7 optimizer.math.partial continuations optimizer.def-use
8 optimizer.backend generic.standard optimizer.specializers
9 optimizer.def-use optimizer.pattern-match generic.standard
10 optimizer.control kernel.private definitions ;
11 IN: optimizer.inlining
13 : remember-inlining ( node history -- )
14 [ swap set-node-history ] curry each-node ;
16 : inlining-quot ( node quot -- node )
17 over node-in-d dataflow-with
18 dup rot infer-classes/node ;
20 : splice-quot ( #call quot history -- node )
21 #! Must add history *before* splicing in, otherwise
22 #! the rest of the IR will also remember the history
23 pick node-history append
24 >r dupd inlining-quot dup r> remember-inlining
27 ! A heuristic to avoid excessive inlining
30 : word-flat-length ( word -- n )
32 ! heuristic: { ... } declare comes up in method bodies
33 ! and we don't care about it
34 { [ dup \ declare eq? ] [ drop -2 ] }
36 { [ dup get ] [ drop 1 ] }
38 { [ dup inline? not ] [ drop 1 ] }
40 [ dup dup set def>> (flat-length) ]
43 : (flat-length) ( seq -- n )
46 { [ dup quotation? ] [ (flat-length) 1+ ] }
47 { [ dup array? ] [ (flat-length) ] }
48 { [ dup word? ] [ word-flat-length ] }
53 : flat-length ( seq -- n )
54 [ def>> (flat-length) ] with-scope ;
56 ! Single dispatch method inlining optimization
57 : node-class# ( node n -- class )
58 over node-in-d <reversed> ?nth node-class ;
60 : dispatching-class ( node word -- class )
61 [ dispatch# node-class# ] keep specific-method ;
63 : inline-standard-method ( node word -- node )
64 2dup dispatching-class dup
65 [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
67 ! Partial dispatch of math-generic words
68 : normalize-math-class ( class -- class' )
76 } [ class<= ] with find nip ;
78 : inlining-math-method ( #call word -- quot/f )
79 swap node-input-classes
80 [ first normalize-math-class ]
81 [ second normalize-math-class ] bi
82 3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
84 : inline-math-method ( #call word -- node/t )
85 [ drop ] [ inlining-math-method ] 2bi
86 dup [ f splice-quot ] [ 2drop t ] if ;
88 : inline-math-partial ( #call word -- node/t )
91 "derived-from" word-prop first
92 inlining-math-method dup
94 [ nip 1quotation ] 2tri
95 [ = not ] [ drop ] 2bi and
96 [ f splice-quot ] [ 2drop t ] if ;
98 : inline-method ( #call -- node )
100 { [ dup standard-generic? ] [ inline-standard-method ] }
101 { [ dup math-generic? ] [ inline-math-method ] }
102 { [ dup math-partial? ] [ inline-math-partial ] }
106 ! Resolve type checks at compile time where possible
107 : comparable? ( actual testing -- ? )
108 #! If actual is a subset of testing or if the two classes
109 #! are disjoint, return t.
110 2dup class<= >r classes-intersect? not r> or ;
112 : optimize-predicate? ( #call -- ? )
113 dup node-param "predicating" word-prop dup [
114 >r node-class-first r> comparable?
119 : literal-quot ( node literals -- quot )
120 #! Outputs a quotation which drops the node's inputs, and
121 #! pushes some literals.
122 >r node-in-d length \ drop <repetition>
123 r> [ literalize ] map append >quotation ;
125 : inline-literals ( node literals -- node )
126 #! Make #shuffle -> #push -> #return -> successor
127 dupd literal-quot f splice-quot ;
129 : evaluate-predicate ( #call -- ? )
130 dup node-param "predicating" word-prop >r
131 node-class-first r> class<= ;
133 : optimize-predicate ( #call -- node )
134 #! If the predicate is followed by a branch we fold it
136 dup evaluate-predicate swap
137 dup node-successor #if? [
139 node-successor swap 0 1 ? fold-branch
140 r> [ set-node-successor ] keep
142 swap 1array inline-literals
145 : optimizer-hooks ( node -- conditions )
146 node-param "optimizer-hooks" word-prop ;
148 : optimizer-hook ( node -- pair/f )
149 dup optimizer-hooks [ first call ] find 2nip ;
151 : optimize-hook ( node -- )
152 dup optimizer-hook second call ;
154 : define-optimizers ( word optimizers -- )
155 "optimizer-hooks" set-word-prop ;
157 : flush-eval? ( #call -- ? )
158 dup node-param "flushable" word-prop [
159 node-out-d [ unused? ] all?
164 : flush-eval ( #call -- node )
165 dup node-param +inlined+ depends-on
166 dup node-out-d length f <repetition> inline-literals ;
168 : partial-eval? ( #call -- ? )
169 dup node-param "foldable" word-prop [
170 dup node-in-d [ node-literal? ] with all?
175 : literal-in-d ( #call -- inputs )
176 dup node-in-d [ node-literal ] with map ;
178 : partial-eval ( #call -- node )
179 dup node-param +inlined+ depends-on
180 dup literal-in-d over node-param 1quotation
181 [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
183 : define-identities ( words identities -- )
184 [ "identities" set-word-prop ] curry each ;
186 : find-identity ( node -- quot )
187 [ node-param "identities" word-prop ] keep
188 [ swap first in-d-match? ] curry find
189 nip dup [ second ] when ;
191 : apply-identities ( node -- node/f )
192 dup find-identity f splice-quot ;
194 : optimistic-inline? ( #call -- ? )
195 dup node-param "specializer" word-prop dup [
196 >r node-input-classes r> specialized-length tail*
197 [ class-types length 1 = ] all?
202 : splice-word-def ( #call word -- node )
203 dup +inlined+ depends-on
204 dup def>> swap 1array splice-quot ;
206 : optimistic-inline ( #call -- node )
207 dup node-param over node-history memq? [
210 dup node-param splice-word-def
213 : method-body-inline? ( #call -- ? )
214 node-param dup method-body?
215 [ flat-length 10 <= ] [ drop f ] if ;
217 M: #call optimize-node*
219 { [ dup flush-eval? ] [ flush-eval ] }
220 { [ dup partial-eval? ] [ partial-eval ] }
221 { [ dup find-identity ] [ apply-identities ] }
222 { [ dup optimizer-hook ] [ optimize-hook ] }
223 { [ dup optimize-predicate? ] [ optimize-predicate ] }
224 { [ dup optimistic-inline? ] [ optimistic-inline ] }
225 { [ dup method-body-inline? ] [ optimistic-inline ] }