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

   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
   4 math.partial-dispatch generic generic.standard generic.math
   5 classes.algebra classes.union sets quotations assocs combinators
   6 words namespaces continuations classes fry
   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 -- )
  21     0 swap [ drop 1+ ] each-node node-count set ;
  22
  23 ! We try not to inline the same word too many times, to avoid
  24 ! combinatorial explosion
  25 SYMBOL: inlining-count
  26
  27 ! Splicing nodes
  28 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
  29
  30 M: word splicing-nodes
  31     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
  32
  33 M: callable splicing-nodes
  34     build-sub-tree analyze-recursive normalize ;
  35
  36 : propagate-body ( #call -- )
  37     body>> (propagate) ;
  38
  39 ! Dispatch elimination
  40 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
  41     dup [
  42         [ >>class ] dip
  43         over method>> over = [ drop ] [
  44             2dup splicing-nodes
  45             [ >>method ] [ >>body ] bi*
  46         ] if
  47         propagate-body t
  48     ] [ 2drop f >>method f >>body f >>class drop f ] if ;
  49
  50 : inlining-standard-method ( #call word -- class/f method/f )
  51     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
  52         [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
  53         [ swap nth value-info class>> dup ] dip
  54         specific-method
  55     ] if ;
  56
  57 : inline-standard-method ( #call word -- ? )
  58     dupd inlining-standard-method eliminate-dispatch ;
  59
  60 : normalize-math-class ( class -- class' )
  61     {
  62         null
  63         fixnum bignum integer
  64         ratio rational
  65         float real
  66         complex number
  67         object
  68     } [ class<= ] with find nip ;
  69
  70 : inlining-math-method ( #call word -- class/f quot/f )
  71     swap in-d>>
  72     first2 [ value-info class>> normalize-math-class ] bi@
  73     3dup math-both-known?
  74     [ math-method* ] [ 3drop f ] if
  75     number swap ;
  76
  77 : inline-math-method ( #call word -- ? )
  78     dupd inlining-math-method eliminate-dispatch ;
  79
  80 : inlining-math-partial ( #call word -- class/f quot/f )
  81     [ "derived-from" word-prop first inlining-math-method ]
  82     [ nip 1quotation ] 2bi
  83     [ = not ] [ drop ] 2bi and ;
  84
  85 : inline-math-partial ( #call word -- ? )
  86     dupd inlining-math-partial eliminate-dispatch ;
  87
  88 ! Method body inlining
  89 SYMBOL: recursive-calls
  90 DEFER: (flat-length)
  91
  92 : word-flat-length ( word -- n )
  93     {
  94         ! special-case
  95         { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
  96         ! not inline
  97         { [ dup inline? not ] [ drop 1 ] }
  98         ! recursive and inline
  99         { [ dup recursive-calls get key? ] [ drop 10 ] }
 100         ! inline
 101         [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
 102     } cond ;
 103
 104 : (flat-length) ( seq -- n )
 105     [
 106         {
 107             { [ dup quotation? ] [ (flat-length) 2 + ] }
 108             { [ dup array? ] [ (flat-length) ] }
 109             { [ dup word? ] [ word-flat-length ] }
 110             [ drop 0 ]
 111         } cond
 112     ] sigma ;
 113
 114 : flat-length ( word -- n )
 115     H{ } clone recursive-calls [
 116         [ recursive-calls get conjoin ]
 117         [ def>> (flat-length) 5 /i ]
 118         bi
 119     ] with-variable ;
 120
 121 : classes-known? ( #call -- ? )
 122     in-d>> [
 123         value-info class>>
 124         [ class-types length 1 = ]
 125         [ union-class? not ]
 126         bi and
 127     ] contains? ;
 128
 129 : node-count-bias ( -- n )
 130     45 node-count get [-] 8 /i ;
 131
 132 : body-length-bias ( word -- n )
 133     [ flat-length ] [ inlining-count get at 0 or ] bi
 134     over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
 135
 136 : inlining-rank ( #call word -- n )
 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
 149 : should-inline? ( #call word -- ? )
 150     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
 151
 152 SYMBOL: history
 153
 154 : remember-inlining ( word -- )
 155     [ inlining-count get inc-at ]
 156     [ history [ swap suffix ] change ]
 157     bi ;
 158
 159 : inline-word-def ( #call word quot -- ? )
 160     over history get memq? [ 3drop f ] [
 161         [
 162             swap remember-inlining
 163             dupd splicing-nodes >>body
 164             propagate-body
 165         ] with-scope
 166         t
 167     ] if ;
 168
 169 : inline-word ( #call word -- ? )
 170     dup def>> inline-word-def ;
 171
 172 : inline-method-body ( #call word -- ? )
 173     2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 174
 175 : always-inline-word? ( word -- ? )
 176     { curry compose } memq? ;
 177
 178 : custom-inlining? ( word -- ? )
 179     "custom-inlining" word-prop ;
 180
 181 : inline-custom ( #call word -- ? )
 182     [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
 183     first object swap eliminate-dispatch ;
 184
 185 : inline-instance-check ( #call word -- ? )
 186     over in-d>> second value-info literal>> dup class?
 187     [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
 188
 189 : (do-inlining) ( #call word -- ? )
 190     #! If the generic was defined in an outer compilation unit,
 191     #! then it doesn't have a definition yet; the definition
 192     #! is built at the end of the compilation unit. We do not
 193     #! attempt inlining at this stage since the stack discipline
 194     #! is not finalized yet, so dispatch# might return an out
 195     #! of bounds value. This case comes up if a parsing word
 196     #! calls the compiler at parse time (doing so is
 197     #! discouraged, but it should still work.)
 198     {
 199         { [ dup deferred? ] [ 2drop f ] }
 200         { [ dup \ instance? eq? ] [ inline-instance-check ] }
 201         { [ dup always-inline-word? ] [ inline-word ] }
 202         { [ dup standard-generic? ] [ inline-standard-method ] }
 203         { [ dup math-generic? ] [ inline-math-method ] }
 204         { [ dup method-body? ] [ inline-method-body ] }
 205         [ 2drop f ]
 206     } cond ;
 207
 208 : do-inlining ( #call word -- ? )
 209     #! Note the logic here: if there's a custom inlining hook,
 210     #! it is permitted to return f, which means that we try the
 211     #! normal inlining heuristic.
 212     dup custom-inlining? [ 2dup inline-custom ] [ f ] if
 213     [ 2drop t ] [ (do-inlining) ] if ;