core/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 namespaces sequences vectors words quotations hashtables
   6 combinators classes classes.algebra generic.math
   7 optimizer.math.partial continuations optimizer.def-use
   8 optimizer.backend generic.standard optimizer.specializers
   9 optimizer.def-use optimizer.pattern-match generic.standard
  10 optimizer.control kernel.private definitions ;
  11 IN: optimizer.inlining
  12
  13 : remember-inlining ( node history -- )
  14     [ swap set-node-history ] curry each-node ;
  15
  16 : inlining-quot ( node quot -- node )
  17     over node-in-d dataflow-with
  18     dup rot infer-classes/node ;
  19
  20 : splice-quot ( #call quot history -- node )
  21     #! Must add history *before* splicing in, otherwise
  22     #! the rest of the IR will also remember the history
  23     pick node-history append
  24     >r dupd inlining-quot dup r> remember-inlining
  25     tuck splice-node ;
  26
  27 ! A heuristic to avoid excessive inlining
  28 DEFER: (flat-length)
  29
  30 : word-flat-length ( word -- n )
  31     {
  32         ! heuristic: { ... } declare comes up in method bodies
  33         ! and we don't care about it
  34         { [ dup \ declare eq? ] [ drop -2 ] }
  35         ! not inline
  36         { [ dup inline? not ] [ drop 1 ] }
  37         ! recursive and inline
  38         { [ dup get ] [ drop 1 ] }
  39         ! inline
  40         [ dup dup set def>> (flat-length) ]
  41     } cond ;
  42
  43 : (flat-length) ( seq -- n )
  44     [
  45         {
  46             { [ dup quotation? ] [ (flat-length) 1+ ] }
  47             { [ dup array? ] [ (flat-length) ] }
  48             { [ dup word? ] [ word-flat-length ] }
  49             [ drop 1 ]
  50         } cond
  51     ] map sum ;
  52
  53 : flat-length ( word -- n )
  54     [ def>> (flat-length) ] with-scope ;
  55
  56 ! Single dispatch method inlining optimization
  57 ! : dispatching-class ( node generic -- method/f )
  58 !     tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
  59 !     [ node-literal swap single-effective-method ]
  60 !     [ node-class swap specific-method ]
  61 !     if ;
  62
  63 : dispatching-class ( node generic -- method/f )
  64     tuck dispatch# over in-d>> <reversed> ?nth
  65     node-class swap specific-method ;
  66
  67 : inline-standard-method ( node generic -- node )
  68     dupd dispatching-class dup
  69     [ 1quotation f splice-quot ] [ 2drop t ] if ;
  70
  71 ! Partial dispatch of math-generic words
  72 : normalize-math-class ( class -- class' )
  73     {
  74         null
  75         fixnum bignum integer
  76         ratio rational
  77         float real
  78         complex number
  79         object
  80     } [ class<= ] with find nip ;
  81
  82 : inlining-math-method ( #call word -- quot/f )
  83     swap node-input-classes
  84     [ first normalize-math-class ]
  85     [ second normalize-math-class ] bi
  86     3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
  87
  88 : inline-math-method ( #call word -- node/t )
  89     [ drop ] [ inlining-math-method ] 2bi
  90     dup [ f splice-quot ] [ 2drop t ] if ;
  91
  92 : inline-math-partial ( #call word -- node/t )
  93     [ drop ]
  94     [
  95         "derived-from" word-prop first
  96         inlining-math-method dup
  97     ]
  98     [ nip 1quotation ] 2tri
  99     [ = not ] [ drop ] 2bi and
 100     [ f splice-quot ] [ 2drop t ] if ;
 101
 102 : inline-method ( #call -- node )
 103     dup node-param {
 104         { [ dup standard-generic? ] [ inline-standard-method ] }
 105         { [ dup math-generic? ] [ inline-math-method ] }
 106         { [ dup math-partial? ] [ inline-math-partial ] }
 107         [ 2drop t ]
 108     } cond ;
 109
 110 : literal-quot ( node literals -- quot )
 111     #! Outputs a quotation which drops the node's inputs, and
 112     #! pushes some literals.
 113     >r node-in-d length \ drop <repetition>
 114     r> [ literalize ] map append >quotation ;
 115
 116 : inline-literals ( node literals -- node )
 117     #! Make #shuffle -> #push -> #return -> successor
 118     dupd literal-quot f splice-quot ;
 119
 120 ! Resolve type checks at compile time where possible
 121 : comparable? ( actual testing -- ? )
 122     #! If actual is a subset of testing or if the two classes
 123     #! are disjoint, return t.
 124     2dup class<= >r classes-intersect? not r> or ;
 125
 126 : optimize-check? ( #call value class -- ? )
 127     >r node-class r> comparable? ;
 128
 129 : evaluate-check ( node value class -- ? )
 130     >r node-class r> class<= ;
 131
 132 : optimize-check ( #call value class -- node )
 133     #! If the predicate is followed by a branch we fold it
 134     #! immediately
 135     [ evaluate-check ] [ 2drop ] 3bi
 136     dup successor>> #if? [
 137         dup drop-inputs >r
 138         successor>> swap 0 1 ? fold-branch
 139         r> swap >>successor
 140     ] [
 141         swap 1array inline-literals
 142     ] if ;
 143
 144 : (optimize-predicate) ( #call -- #call value class )
 145     [ ] [ in-d>> first ] [ param>> "predicating" word-prop ] tri ;
 146
 147 : optimize-predicate? ( #call -- ? )
 148     dup param>> "predicating" word-prop [
 149         (optimize-predicate) optimize-check?
 150     ] [ drop f ] if ;
 151
 152 : optimize-predicate ( #call -- node )
 153     (optimize-predicate) optimize-check ;
 154
 155 : flush-eval? ( #call -- ? )
 156     dup node-param "flushable" word-prop [
 157         node-out-d [ unused? ] all?
 158     ] [
 159         drop f
 160     ] if ;
 161
 162 : flush-eval ( #call -- node )
 163     dup node-param +inlined+ depends-on
 164     dup node-out-d length f <repetition> inline-literals ;
 165
 166 : partial-eval? ( #call -- ? )
 167     dup node-param "foldable" word-prop [
 168         dup node-in-d [ node-literal? ] with all?
 169     ] [
 170         drop f
 171     ] if ;
 172
 173 : literal-in-d ( #call -- inputs )
 174     dup node-in-d [ node-literal ] with map ;
 175
 176 : partial-eval ( #call -- node )
 177     dup node-param +inlined+ depends-on
 178     dup literal-in-d over node-param 1quotation
 179     [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
 180
 181 : define-identities ( words identities -- )
 182     [ "identities" set-word-prop ] curry each ;
 183
 184 : find-identity ( node -- quot )
 185     [ node-param "identities" word-prop ] keep
 186     [ swap first in-d-match? ] curry find
 187     nip dup [ second ] when ;
 188
 189 : apply-identities ( node -- node/f )
 190     dup find-identity f splice-quot ;
 191
 192 : optimistic-inline? ( #call -- ? )
 193     dup node-param "specializer" word-prop dup [
 194         >r node-input-classes r> specialized-length tail*
 195         [ class-types length 1 = ] all?
 196     ] [
 197         2drop f
 198     ] if ;
 199
 200 : splice-word-def ( #call word -- node )
 201     dup +inlined+ depends-on
 202     dup def>> swap 1array splice-quot ;
 203
 204 : optimistic-inline ( #call -- node )
 205     dup node-param over node-history memq? [
 206         drop t
 207     ] [
 208         dup node-param splice-word-def
 209     ] if ;
 210
 211 : method-body-inline? ( #call -- ? )
 212     node-param dup method-body?
 213     [ flat-length 10 <= ] [ drop f ] if ;
 214
 215 M: #call optimize-node*
 216     {
 217         { [ dup flush-eval? ] [ flush-eval ] }
 218         { [ dup partial-eval? ] [ partial-eval ] }
 219         { [ dup find-identity ] [ apply-identities ] }
 220         { [ dup optimizer-hook ] [ optimize-hook ] }
 221         { [ dup optimize-predicate? ] [ optimize-predicate ] }
 222         { [ dup optimistic-inline? ] [ optimistic-inline ] }
 223         { [ dup method-body-inline? ] [ optimistic-inline ] }
 224         [ inline-method ]
 225     } cond dup not ;