basis/optimizer/inlining/inlining.factor

   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 math.order namespaces sequences vectors words quotations
   6 hashtables combinators effects classes classes.union
   7 classes.algebra generic.math optimizer.math.partial
   8 continuations optimizer.def-use optimizer.backend
   9 generic.standard optimizer.specializers optimizer.def-use
  10 optimizer.pattern-match generic.standard optimizer.control
  11 kernel.private definitions sets summary ;
  12 IN: optimizer.inlining
  13
  14 : remember-inlining ( node history -- )
  15     [ swap set-node-history ] curry each-node ;
  16
  17 : inlining-quot ( node quot -- node )
  18     over node-in-d dataflow-with
  19     dup rot infer-classes/node ;
  20
  21 : splice-quot ( #call quot history -- node )
  22     #! Must add history *before* splicing in, otherwise
  23     #! the rest of the IR will also remember the history
  24     pick node-history append
  25     >r dupd inlining-quot dup r> remember-inlining
  26     tuck splice-node ;
  27
  28 ! A heuristic to avoid excessive inlining
  29 SYMBOL: recursive-calls
  30 DEFER: (flat-length)
  31
  32 : word-flat-length ( word -- n )
  33     {
  34         ! not inline
  35         { [ dup inline? not ] [ drop 1 ] }
  36         ! recursive and inline
  37         { [ dup recursive-calls get key? ] [ drop 10 ] }
  38         ! inline
  39         [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
  40     } cond ;
  41
  42 : (flat-length) ( seq -- n )
  43     [
  44         {
  45             { [ dup quotation? ] [ (flat-length) 2 + ] }
  46             { [ dup array? ] [ (flat-length) ] }
  47             { [ dup word? ] [ word-flat-length ] }
  48             [ drop 0 ]
  49         } cond
  50     ] sigma ;
  51
  52 : flat-length ( word -- n )
  53     H{ } clone recursive-calls [
  54         [ recursive-calls get conjoin ]
  55         [ def>> (flat-length) 5 /i ]
  56         bi
  57     ] with-variable ;
  58
  59 ! Single dispatch method inlining optimization
  60 ! : dispatching-class ( node generic -- method/f )
  61 !     tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
  62 !     [ node-literal swap single-effective-method ]
  63 !     [ node-class swap specific-method ]
  64 !     if ;
  65
  66 : dispatching-class ( node generic -- method/f )
  67     tuck dispatch# over in-d>> <reversed> ?nth
  68     node-class swap specific-method ;
  69
  70 : inline-standard-method ( node generic -- node )
  71     dupd dispatching-class dup
  72     [ 1quotation f splice-quot ] [ 2drop t ] if ;
  73
  74 ! Partial dispatch of math-generic words
  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 -- quot/f )
  86     swap node-input-classes
  87     [ first normalize-math-class ]
  88     [ second normalize-math-class ] bi
  89     3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
  90
  91 : inline-math-method ( #call word -- node/t )
  92     [ drop ] [ inlining-math-method ] 2bi
  93     dup [ f splice-quot ] [ 2drop t ] if ;
  94
  95 : inline-math-partial ( #call word -- node/t )
  96     [ drop ]
  97     [
  98         "derived-from" word-prop first
  99         inlining-math-method dup
 100     ]
 101     [ nip 1quotation ] 2tri
 102     [ = not ] [ drop ] 2bi and
 103     [ f splice-quot ] [ 2drop t ] if ;
 104
 105 : inline-method ( #call -- node )
 106     dup param>> {
 107         { [ dup standard-generic? ] [ inline-standard-method ] }
 108         { [ dup math-generic? ] [ inline-math-method ] }
 109         { [ dup math-partial? ] [ inline-math-partial ] }
 110         [ 2drop t ]
 111     } cond ;
 112
 113 : literal-quot ( node literals -- quot )
 114     #! Outputs a quotation which drops the node's inputs, and
 115     #! pushes some literals.
 116     >r node-in-d length \ drop <repetition>
 117     r> [ literalize ] map append >quotation ;
 118
 119 : inline-literals ( node literals -- node )
 120     #! Make #shuffle -> #push -> #return -> successor
 121     dupd literal-quot f splice-quot ;
 122
 123 ! Resolve type checks at compile time where possible
 124 : comparable? ( actual testing -- ? )
 125     #! If actual is a subset of testing or if the two classes
 126     #! are disjoint, return t.
 127     2dup class<= >r classes-intersect? not r> or ;
 128
 129 : optimize-check? ( #call value class -- ? )
 130     >r node-class r> comparable? ;
 131
 132 : evaluate-check ( node value class -- ? )
 133     >r node-class r> class<= ;
 134
 135 : optimize-check ( #call value class -- node )
 136     #! If the predicate is followed by a branch we fold it
 137     #! immediately
 138     [ evaluate-check ] [ 2drop ] 3bi
 139     dup successor>> #if? [
 140         dup drop-inputs >r
 141         successor>> swap 0 1 ? fold-branch
 142         r> swap >>successor
 143     ] [
 144         swap 1array inline-literals
 145     ] if ;
 146
 147 : (optimize-predicate) ( #call -- #call value class )
 148     [ ] [ in-d>> first ] [ param>> "predicating" word-prop ] tri ;
 149
 150 : optimize-predicate? ( #call -- ? )
 151     dup param>> "predicating" word-prop [
 152         (optimize-predicate) optimize-check?
 153     ] [ drop f ] if ;
 154
 155 : optimize-predicate ( #call -- node )
 156     (optimize-predicate) optimize-check ;
 157
 158 : flush-eval? ( #call -- ? )
 159     dup node-param "flushable" word-prop
 160     [ node-out-d [ unused? ] all? ] [ drop f ] if ;
 161
 162 ERROR: flushed-eval-error word ;
 163
 164 M: flushed-eval-error summary
 165     drop "Flushed evaluation of word would have thrown an error" ;
 166
 167 : flushed-eval-quot ( #call -- quot )
 168     #! A quotation to replace flushed evaluations with. We can't
 169     #! just remove the code altogether, because if the optimizer
 170     #! knows the input types of a word, it assumes the inputs are
 171     #! of this type after the word returns, since presumably
 172     #! the word would have checked input types itself. However,
 173     #! if the word gets flushed, then it won't do this checking;
 174     #! so we have to do it here.
 175     [
 176         dup param>> "input-classes" word-prop [
 177             make-specializer %
 178             [ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
 179             \ unless ,
 180         ] when*
 181         dup in-d>> length [ \ drop , ] times
 182         out-d>> length [ f , ] times
 183     ] [ ] make ;
 184
 185 : flush-eval ( #call -- node )
 186     dup param>> +inlined+ depends-on
 187     dup flushed-eval-quot f splice-quot ;
 188
 189 : partial-eval? ( #call -- ? )
 190     dup node-param "foldable" word-prop [
 191         dup node-in-d [ node-literal? ] with all?
 192     ] [
 193         drop f
 194     ] if ;
 195
 196 : literal-in-d ( #call -- inputs )
 197     dup node-in-d [ node-literal ] with map ;
 198
 199 : partial-eval ( #call -- node )
 200     dup node-param +inlined+ depends-on
 201     dup literal-in-d over node-param 1quotation
 202     [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
 203
 204 : define-identities ( words identities -- )
 205     [ "identities" set-word-prop ] curry each ;
 206
 207 : find-identity ( node -- quot )
 208     [ node-param "identities" word-prop ] keep
 209     [ swap first in-d-match? ] curry find
 210     nip dup [ second ] when ;
 211
 212 : apply-identities ( node -- node/f )
 213     dup find-identity f splice-quot ;
 214
 215 : splice-word-def ( #call word def -- node )
 216     [ drop +inlined+ depends-on ] [ swap 1array ] 2bi
 217     splice-quot ;
 218
 219 : classes-known? ( #call -- ? )
 220     node-input-classes [
 221         [ class-types length 1 = ]
 222         [ union-class? not ]
 223         bi and
 224     ] contains? ;
 225
 226 : inlining-rank ( #call -- n )
 227     {
 228         [ param>> flat-length 24 swap [-] 4 /i ]
 229         [ param>> "default" word-prop -4 0 ? ]
 230         [ param>> "specializer" word-prop 1 0 ? ]
 231         [ param>> method-body? 1 0 ? ]
 232         [ classes-known? 2 0 ? ]
 233     } cleave + + + + ;
 234
 235 : should-inline? ( #call -- ? )
 236     inlining-rank 5 >= ;
 237
 238 : optimistic-inline? ( #call -- ? )
 239     dup param>> "specializer" word-prop
 240     [ should-inline? ] [ drop f ] if ;
 241
 242 : already-inlined? ( #call -- ? )
 243     [ param>> ] [ history>> ] bi memq? ;
 244
 245 : optimistic-inline ( #call -- node )
 246     dup already-inlined? [ drop t ] [
 247         dup param>> dup def>> splice-word-def
 248     ] if ;
 249
 250 : method-body-inline? ( #call -- ? )
 251     dup param>> method-body?
 252     [ should-inline? ] [ drop f ] if ;
 253
 254 M: #call optimize-node*
 255     {
 256         { [ dup flush-eval? ] [ flush-eval ] }
 257         { [ dup partial-eval? ] [ partial-eval ] }
 258         { [ dup find-identity ] [ apply-identities ] }
 259         { [ dup optimizer-hook ] [ optimize-hook ] }
 260         { [ dup optimize-predicate? ] [ optimize-predicate ] }
 261         { [ dup optimistic-inline? ] [ optimistic-inline ] }
 262         { [ dup method-body-inline? ] [ optimistic-inline ] }
 263         [ inline-method ]
 264     } cond dup not ;