core/optimizer/inlining/inlining.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: 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 ;
  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         ! recursive
  36         { [ dup get ] [ drop 1 ] }
  37         ! not inline
  38         { [ dup inline? not ] [ drop 1 ] }
  39         ! inline
  40         [ dup dup set word-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 ( seq -- n )
  54     [ word-def (flat-length) ] with-scope ;
  55
  56 ! Single dispatch method inlining optimization
  57 : node-class# ( node n -- class )
  58     over node-in-d <reversed> ?nth node-class ;
  59
  60 : dispatching-class ( node word -- class )
  61     [ dispatch# node-class# ] keep specific-method ;
  62
  63 : inline-standard-method ( node word -- node )
  64     2dup dispatching-class dup [
  65         over +inlined+ depends-on
  66         swap method 1quotation f splice-quot
  67     ] [
  68         3drop t
  69     ] 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 ! Resolve type checks at compile time where possible
 111 : comparable? ( actual testing -- ? )
 112     #! If actual is a subset of testing or if the two classes
 113     #! are disjoint, return t.
 114     2dup class<= >r classes-intersect? not r> or ;
 115
 116 : optimize-predicate? ( #call -- ? )
 117     dup node-param "predicating" word-prop dup [
 118         >r node-class-first r> comparable?
 119     ] [
 120         2drop f
 121     ] if ;
 122
 123 : literal-quot ( node literals -- quot )
 124     #! Outputs a quotation which drops the node's inputs, and
 125     #! pushes some literals.
 126     >r node-in-d length \ drop <repetition>
 127     r> [ literalize ] map append >quotation ;
 128
 129 : inline-literals ( node literals -- node )
 130     #! Make #shuffle -> #push -> #return -> successor
 131     dupd literal-quot f splice-quot ;
 132
 133 : evaluate-predicate ( #call -- ? )
 134     dup node-param "predicating" word-prop >r
 135     node-class-first r> class<= ;
 136
 137 : optimize-predicate ( #call -- node )
 138     #! If the predicate is followed by a branch we fold it
 139     #! immediately
 140     dup evaluate-predicate swap
 141     dup node-successor #if? [
 142         dup drop-inputs >r
 143         node-successor swap 0 1 ? fold-branch
 144         r> [ set-node-successor ] keep
 145     ] [
 146         swap 1array inline-literals
 147     ] if ;
 148
 149 : optimizer-hooks ( node -- conditions )
 150     node-param "optimizer-hooks" word-prop ;
 151
 152 : optimizer-hook ( node -- pair/f )
 153     dup optimizer-hooks [ first call ] find 2nip ;
 154
 155 : optimize-hook ( node -- )
 156     dup optimizer-hook second call ;
 157
 158 : define-optimizers ( word optimizers -- )
 159     "optimizer-hooks" set-word-prop ;
 160
 161 : flush-eval? ( #call -- ? )
 162     dup node-param "flushable" word-prop [
 163         node-out-d [ unused? ] all?
 164     ] [
 165         drop f
 166     ] if ;
 167
 168 : flush-eval ( #call -- node )
 169     dup node-param +inlined+ depends-on
 170     dup node-out-d length f <repetition> inline-literals ;
 171
 172 : partial-eval? ( #call -- ? )
 173     dup node-param "foldable" word-prop [
 174         dup node-in-d [ node-literal? ] with all?
 175     ] [
 176         drop f
 177     ] if ;
 178
 179 : literal-in-d ( #call -- inputs )
 180     dup node-in-d [ node-literal ] with map ;
 181
 182 : partial-eval ( #call -- node )
 183     dup node-param +inlined+ depends-on
 184     dup literal-in-d over node-param 1quotation
 185     [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
 186
 187 : define-identities ( words identities -- )
 188     [ "identities" set-word-prop ] curry each ;
 189
 190 : find-identity ( node -- quot )
 191     [ node-param "identities" word-prop ] keep
 192     [ swap first in-d-match? ] curry find
 193     nip dup [ second ] when ;
 194
 195 : apply-identities ( node -- node/f )
 196     dup find-identity f splice-quot ;
 197
 198 : optimistic-inline? ( #call -- ? )
 199     dup node-param "specializer" word-prop dup [
 200         >r node-input-classes r> specialized-length tail*
 201         [ class-types length 1 = ] all?
 202     ] [
 203         2drop f
 204     ] if ;
 205
 206 : splice-word-def ( #call word -- node )
 207     dup +inlined+ depends-on
 208     dup word-def swap 1array splice-quot ;
 209
 210 : optimistic-inline ( #call -- node )
 211     dup node-param over node-history memq? [
 212         drop t
 213     ] [
 214         dup node-param splice-word-def
 215     ] if ;
 216
 217 : method-body-inline? ( #call -- ? )
 218     node-param dup method-body?
 219     [ flat-length 10 <= ] [ drop f ] if ;
 220
 221 M: #call optimize-node*
 222     {
 223         { [ dup flush-eval? ] [ flush-eval ] }
 224         { [ dup partial-eval? ] [ partial-eval ] }
 225         { [ dup find-identity ] [ apply-identities ] }
 226         { [ dup optimizer-hook ] [ optimize-hook ] }
 227         { [ dup optimize-predicate? ] [ optimize-predicate ] }
 228         { [ dup optimistic-inline? ] [ optimistic-inline ] }
 229         { [ dup method-body-inline? ] [ optimistic-inline ] }
 230         [ inline-method ]
 231     } cond dup not ;