basis/compiler/tree/propagation/inlining/inlining.factor

   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.math
   5 classes.algebra classes.union sets quotations assocs combinators
   6 words namespaces continuations classes fry combinators.smart
   7 compiler.tree
   8 compiler.tree.builder
   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
  15
  16 ! We count nodes up-front; if there are relatively few nodes,
  17 ! we are more eager to inline
  18 SYMBOL: node-count
  19
  20 : count-nodes ( nodes -- n )
  21     0 swap [ drop 1+ ] each-node ;
  22
  23 : compute-node-count ( nodes -- ) count-nodes node-count set ;
  24
  25 ! We try not to inline the same word too many times, to avoid
  26 ! combinatorial explosion
  27 SYMBOL: inlining-count
  28
  29 ! Splicing nodes
  30 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
  31
  32 M: word splicing-nodes
  33     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
  34
  35 M: callable splicing-nodes
  36     build-sub-tree analyze-recursive normalize ;
  37
  38 ! Dispatch elimination
  39 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
  40     dup [
  41         [ >>class ] dip
  42         over method>> over = [ drop ] [
  43             2dup splicing-nodes
  44             [ >>method ] [ >>body ] bi*
  45         ] if
  46         body>> (propagate) t
  47     ] [ 2drop f >>method f >>body f >>class drop f ] if ;
  48
  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
  53         specific-method
  54     ] if ;
  55
  56 : inline-standard-method ( #call word -- ? )
  57     dupd inlining-standard-method eliminate-dispatch ;
  58
  59 : normalize-math-class ( class -- class' )
  60     {
  61         null
  62         fixnum bignum integer
  63         ratio rational
  64         float real
  65         complex number
  66         object
  67     } [ class<= ] with find nip ;
  68
  69 : inlining-math-method ( #call word -- class/f quot/f )
  70     swap in-d>>
  71     first2 [ value-info class>> normalize-math-class ] bi@
  72     3dup math-both-known?
  73     [ math-method* ] [ 3drop f ] if
  74     number swap ;
  75
  76 : inline-math-method ( #call word -- ? )
  77     dupd inlining-math-method eliminate-dispatch ;
  78
  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 ;
  83
  84 : inline-math-partial ( #call word -- ? )
  85     dupd inlining-math-partial eliminate-dispatch ;
  86
  87 ! Method body inlining
  88 SYMBOL: recursive-calls
  89 DEFER: (flat-length)
  90
  91 : word-flat-length ( word -- n )
  92     {
  93         ! special-case
  94         { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
  95         ! not inline
  96         { [ dup inline? not ] [ drop 1 ] }
  97         ! recursive and inline
  98         { [ dup recursive-calls get key? ] [ drop 10 ] }
  99         ! inline
 100         [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
 101     } cond ;
 102
 103 : (flat-length) ( seq -- n )
 104     [
 105         {
 106             { [ dup quotation? ] [ (flat-length) 2 + ] }
 107             { [ dup array? ] [ (flat-length) ] }
 108             { [ dup word? ] [ word-flat-length ] }
 109             [ drop 0 ]
 110         } cond
 111     ] sigma ;
 112
 113 : flat-length ( word -- n )
 114     H{ } clone recursive-calls [
 115         [ recursive-calls get conjoin ]
 116         [ def>> (flat-length) 5 /i ]
 117         bi
 118     ] with-variable ;
 119
 120 : classes-known? ( #call -- ? )
 121     in-d>> [
 122         value-info class>>
 123         [ class-types length 1 = ]
 124         [ union-class? not ]
 125         bi and
 126     ] any? ;
 127
 128 : node-count-bias ( -- n )
 129     45 node-count get [-] 8 /i ;
 130
 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 ;
 134
 135 : inlining-rank ( #call word -- n )
 136     [
 137         [ classes-known? 2 0 ? ]
 138         [
 139             {
 140                 [ body-length-bias ]
 141                 [ "default" word-prop -4 0 ? ]
 142                 [ "specializer" word-prop 1 0 ? ]
 143                 [ method-body? 1 0 ? ]
 144             } cleave
 145             node-count-bias
 146             loop-nesting get 0 or 2 *
 147         ] bi*
 148     ] sum-outputs ;
 149
 150 : should-inline? ( #call word -- ? )
 151     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
 152
 153 SYMBOL: history
 154
 155 : remember-inlining ( word -- )
 156     [ inlining-count get inc-at ]
 157     [ history [ swap suffix ] change ]
 158     bi ;
 159
 160 : inline-word-def ( #call word quot -- ? )
 161     over history get memq? [ 3drop f ] [
 162         [
 163             [ remember-inlining ] dip
 164             [ drop ] [ splicing-nodes ] 2bi
 165             [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
 166         ] with-scope node-count +@
 167         t
 168     ] if ;
 169
 170 : inline-word ( #call word -- ? )
 171     dup def>> inline-word-def ;
 172
 173 : inline-method-body ( #call word -- ? )
 174     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 175
 176 : always-inline-word? ( word -- ? )
 177     { curry compose } memq? ;
 178
 179 : never-inline-word? ( word -- ? )
 180     [ deferred? ] [ { call execute } memq? ] bi or ;
 181
 182 : custom-inlining? ( word -- ? )
 183     "custom-inlining" word-prop ;
 184
 185 : inline-custom ( #call word -- ? )
 186     [ dup ] [ "custom-inlining" word-prop ] bi*
 187     call( #call -- word/quot/f )
 188     object swap eliminate-dispatch ;
 189
 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 ;
 193
 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.)
 203     {
 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 ] }
 210         [ 2drop f ]
 211     } cond ;
 212
 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 ;