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 combinators.short-circuit words namespaces continuations classes
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
18 : splicing-call ( #call word -- nodes )
19 [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
21 : open-code-#call ( #call word/quot -- nodes/f )
22 [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
24 : splicing-body ( #call quot/word -- nodes/f )
25 open-code-#call dup [ analyze-recursive normalize ] when ;
27 ! Dispatch elimination
28 : undo-inlining ( #call -- ? )
29 f >>method f >>body f >>class drop f ;
31 : propagate-body ( #call -- ? )
32 body>> (propagate) t ;
34 GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
36 M: word splicing-nodes splicing-call ;
38 M: callable splicing-nodes splicing-body ;
40 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
43 over method>> over = [ drop propagate-body ] [
44 2dup splicing-nodes dup [
45 [ >>method ] [ >>body ] bi* propagate-body
46 ] [ 2drop undo-inlining ] if
48 ] [ 2drop undo-inlining ] if ;
50 : inlining-standard-method ( #call word -- class/f method/f )
51 dup "methods" word-prop assoc-empty? [ 2drop f f ] [
52 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
53 [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
54 [ swap nth value-info class>> dup ] dip
59 : inline-standard-method ( #call word -- ? )
60 dupd inlining-standard-method eliminate-dispatch ;
62 : normalize-math-class ( class -- class' )
70 } [ class<= ] with find nip ;
72 : inlining-math-method ( #call word -- class/f quot/f )
74 first2 [ value-info class>> normalize-math-class ] bi@
76 [ math-method* ] [ 3drop f ] if
79 : inline-math-method ( #call word -- ? )
80 dupd inlining-math-method eliminate-dispatch ;
82 : inlining-math-partial ( #call word -- class/f quot/f )
83 [ "derived-from" word-prop first inlining-math-method ]
84 [ nip 1quotation ] 2bi
85 [ = not ] [ drop ] 2bi and ;
87 : inline-math-partial ( #call word -- ? )
88 dupd inlining-math-partial eliminate-dispatch ;
90 ! Method body inlining
93 : already-inlined? ( obj -- ? ) history get memq? ;
95 : add-to-history ( obj -- ) history [ swap suffix ] change ;
97 :: inline-word ( #call word -- ? )
98 word already-inlined? [ f ] [
99 #call word splicing-body [
106 : always-inline-word? ( word -- ? )
107 { curry compose } memq? ;
109 : never-inline-word? ( word -- ? )
110 { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
112 : custom-inlining? ( word -- ? )
113 "custom-inlining" word-prop ;
115 : inline-custom ( #call word -- ? )
116 [ dup ] [ "custom-inlining" word-prop ] bi*
117 call( #call -- word/quot/f )
118 object swap eliminate-dispatch ;
120 : (do-inlining) ( #call word -- ? )
121 #! If the generic was defined in an outer compilation unit,
122 #! then it doesn't have a definition yet; the definition
123 #! is built at the end of the compilation unit. We do not
124 #! attempt inlining at this stage since the stack discipline
125 #! is not finalized yet, so dispatch# might return an out
126 #! of bounds value. This case comes up if a parsing word
127 #! calls the compiler at parse time (doing so is
128 #! discouraged, but it should still work.)
130 { [ dup never-inline-word? ] [ 2drop f ] }
131 { [ dup always-inline-word? ] [ inline-word ] }
132 { [ dup standard-generic? ] [ inline-standard-method ] }
133 { [ dup math-generic? ] [ inline-math-method ] }
134 { [ dup inline? ] [ inline-word ] }
138 : do-inlining ( #call word -- ? )
139 #! Note the logic here: if there's a custom inlining hook,
140 #! it is permitted to return f, which means that we try the
141 #! normal inlining heuristic.
143 dup custom-inlining? [ 2dup inline-custom ] [ f ] if
144 [ 2drop t ] [ (do-inlining) ] if