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