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 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         ! 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     [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
  66
  67 ! Partial dispatch of math-generic words
  68 : normalize-math-class ( class -- class' )
  69     {
  70         null
  71         fixnum bignum integer
  72         ratio rational
  73         float real
  74         complex number
  75         object
  76     } [ class<= ] with find nip ;
  77
  78 : inlining-math-method ( #call word -- quot/f )
  79     swap node-input-classes
  80     [ first normalize-math-class ]
  81     [ second normalize-math-class ] bi
  82     3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
  83
  84 : inline-math-method ( #call word -- node/t )
  85     [ drop ] [ inlining-math-method ] 2bi
  86     dup [ f splice-quot ] [ 2drop t ] if ;
  87
  88 : inline-math-partial ( #call word -- node/t )
  89     [ drop ]
  90     [
  91         "derived-from" word-prop first
  92         inlining-math-method dup
  93     ]
  94     [ nip 1quotation ] 2tri
  95     [ = not ] [ drop ] 2bi and
  96     [ f splice-quot ] [ 2drop t ] if ;
  97
  98 : inline-method ( #call -- node )
  99     dup node-param {
 100         { [ dup standard-generic? ] [ inline-standard-method ] }
 101         { [ dup math-generic? ] [ inline-math-method ] }
 102         { [ dup math-partial? ] [ inline-math-partial ] }
 103         [ 2drop t ]
 104     } cond ;
 105
 106 ! Resolve type checks at compile time where possible
 107 : comparable? ( actual testing -- ? )
 108     #! If actual is a subset of testing or if the two classes
 109     #! are disjoint, return t.
 110     2dup class<= >r classes-intersect? not r> or ;
 111
 112 : optimize-predicate? ( #call -- ? )
 113     dup node-param "predicating" word-prop dup [
 114         >r node-class-first r> comparable?
 115     ] [
 116         2drop f
 117     ] if ;
 118
 119 : literal-quot ( node literals -- quot )
 120     #! Outputs a quotation which drops the node's inputs, and
 121     #! pushes some literals.
 122     >r node-in-d length \ drop <repetition>
 123     r> [ literalize ] map append >quotation ;
 124
 125 : inline-literals ( node literals -- node )
 126     #! Make #shuffle -> #push -> #return -> successor
 127     dupd literal-quot f splice-quot ;
 128
 129 : evaluate-predicate ( #call -- ? )
 130     dup node-param "predicating" word-prop >r
 131     node-class-first r> class<= ;
 132
 133 : optimize-predicate ( #call -- node )
 134     #! If the predicate is followed by a branch we fold it
 135     #! immediately
 136     dup evaluate-predicate swap
 137     dup node-successor #if? [
 138         dup drop-inputs >r
 139         node-successor swap 0 1 ? fold-branch
 140         r> [ set-node-successor ] keep
 141     ] [
 142         swap 1array inline-literals
 143     ] if ;
 144
 145 : optimizer-hooks ( node -- conditions )
 146     node-param "optimizer-hooks" word-prop ;
 147
 148 : optimizer-hook ( node -- pair/f )
 149     dup optimizer-hooks [ first call ] find 2nip ;
 150
 151 : optimize-hook ( node -- )
 152     dup optimizer-hook second call ;
 153
 154 : define-optimizers ( word optimizers -- )
 155     "optimizer-hooks" set-word-prop ;
 156
 157 : flush-eval? ( #call -- ? )
 158     dup node-param "flushable" word-prop [
 159         node-out-d [ unused? ] all?
 160     ] [
 161         drop f
 162     ] if ;
 163
 164 : flush-eval ( #call -- node )
 165     dup node-param +inlined+ depends-on
 166     dup node-out-d length f <repetition> inline-literals ;
 167
 168 : partial-eval? ( #call -- ? )
 169     dup node-param "foldable" word-prop [
 170         dup node-in-d [ node-literal? ] with all?
 171     ] [
 172         drop f
 173     ] if ;
 174
 175 : literal-in-d ( #call -- inputs )
 176     dup node-in-d [ node-literal ] with map ;
 177
 178 : partial-eval ( #call -- node )
 179     dup node-param +inlined+ depends-on
 180     dup literal-in-d over node-param 1quotation
 181     [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
 182
 183 : define-identities ( words identities -- )
 184     [ "identities" set-word-prop ] curry each ;
 185
 186 : find-identity ( node -- quot )
 187     [ node-param "identities" word-prop ] keep
 188     [ swap first in-d-match? ] curry find
 189     nip dup [ second ] when ;
 190
 191 : apply-identities ( node -- node/f )
 192     dup find-identity f splice-quot ;
 193
 194 : optimistic-inline? ( #call -- ? )
 195     dup node-param "specializer" word-prop dup [
 196         >r node-input-classes r> specialized-length tail*
 197         [ class-types length 1 = ] all?
 198     ] [
 199         2drop f
 200     ] if ;
 201
 202 : splice-word-def ( #call word -- node )
 203     dup +inlined+ depends-on
 204     dup word-def swap 1array splice-quot ;
 205
 206 : optimistic-inline ( #call -- node )
 207     dup node-param over node-history memq? [
 208         drop t
 209     ] [
 210         dup node-param splice-word-def
 211     ] if ;
 212
 213 : method-body-inline? ( #call -- ? )
 214     node-param dup method-body?
 215     [ flat-length 10 <= ] [ drop f ] if ;
 216
 217 M: #call optimize-node*
 218     {
 219         { [ dup flush-eval? ] [ flush-eval ] }
 220         { [ dup partial-eval? ] [ partial-eval ] }
 221         { [ dup find-identity ] [ apply-identities ] }
 222         { [ dup optimizer-hook ] [ optimize-hook ] }
 223         { [ dup optimize-predicate? ] [ optimize-predicate ] }
 224         { [ dup optimistic-inline? ] [ optimistic-inline ] }
 225         { [ dup method-body-inline? ] [ optimistic-inline ] }
 226         [ inline-method ]
 227     } cond dup not ;