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 combinators.short-circuit words namespaces continuations classes
   7 fry hints locals
   8 stack-checker.dependencies
   9 compiler.tree
  10 compiler.tree.builder
  11 compiler.tree.recursive
  12 compiler.tree.combinators
  13 compiler.tree.normalization
  14 compiler.tree.propagation.info
  15 compiler.tree.propagation.nodes ;
  16 IN: compiler.tree.propagation.inlining
  17
  18 ! Splicing nodes
  19 : splicing-call ( #call word -- nodes )
  20     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
  21
  22 : open-code-#call ( #call word/quot -- nodes/f )
  23     [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
  24
  25 : splicing-body ( #call quot/word -- nodes/f )
  26     open-code-#call dup [ analyze-recursive normalize ] when ;
  27
  28 ! Dispatch elimination
  29 : undo-inlining ( #call -- ? )
  30     f >>method f >>body f >>class drop f ;
  31
  32 : propagate-body ( #call -- ? )
  33     body>> (propagate) t ;
  34
  35 GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
  36
  37 M: word splicing-nodes splicing-call ;
  38
  39 M: callable splicing-nodes splicing-body ;
  40
  41 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
  42     dup [
  43         [ >>class ] dip
  44         over method>> over = [ drop propagate-body ] [
  45             2dup splicing-nodes dup [
  46                 [ >>method ] [ >>body ] bi* propagate-body
  47             ] [ 2drop undo-inlining ] if
  48         ] if
  49     ] [ 2drop undo-inlining ] if ;
  50
  51 ERROR: bad-splitting class generic ;
  52
  53 :: split-code ( class generic -- quot/f )
  54     class generic method :> my-method
  55     my-method [ class generic bad-splitting ] unless
  56     class generic my-method depends-on-method-is
  57     generic dispatch# (picker) :> picker
  58     [
  59         picker call class instance?
  60         [ my-method execute ]
  61         [ generic no-method ] if
  62     ] ;
  63
  64 :: split-method-call ( class generic -- quot/f )
  65     class generic subclass-with-only-method [
  66         [ class generic depends-on-single-method ]
  67         [ generic split-code ] bi
  68     ] [ f ] if* ;
  69
  70 : inlining-standard-method ( #call word -- class/f method/f )
  71     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
  72         2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
  73             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
  74             [ swap nth value-info class>> dup ] dip
  75             { [ method-for-class ] [ split-method-call ] } 2||
  76         ] if
  77     ] if ;
  78
  79 : inline-standard-method ( #call word -- ? )
  80     dupd inlining-standard-method eliminate-dispatch ;
  81
  82 : normalize-math-class ( class -- class' )
  83     {
  84         null
  85         fixnum bignum integer
  86         ratio rational
  87         float real
  88         complex number
  89         object
  90     } [ class<= ] with find nip ;
  91
  92 : inlining-math-method ( #call word -- class/f quot/f )
  93     swap in-d>>
  94     first2 [ value-info class>> normalize-math-class ] bi@
  95     3dup math-both-known?
  96     [ math-method* ] [ 3drop f ] if
  97     number swap ;
  98
  99 : inline-math-method ( #call word -- ? )
 100     dupd inlining-math-method eliminate-dispatch ;
 101
 102 ! Method body inlining
 103 SYMBOL: history
 104
 105 : already-inlined? ( obj -- ? ) history get member-eq? ;
 106
 107 : add-to-history ( obj -- ) history [ swap suffix ] change ;
 108
 109 :: inline-word ( #call word -- ? )
 110     word already-inlined? [ f ] [
 111         #call word splicing-body [
 112             word add-to-history
 113             #call body<<
 114             #call propagate-body
 115         ] [ f ] if*
 116     ] if ;
 117
 118 : always-inline-word? ( word -- ? )
 119     { curry compose } member-eq? ;
 120
 121 : never-inline-word? ( word -- ? )
 122     { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
 123
 124 : custom-inlining? ( word -- ? )
 125     "custom-inlining" word-prop ;
 126
 127 : inline-custom ( #call word -- ? )
 128     [ dup ] [ "custom-inlining" word-prop ] bi*
 129     call( #call -- word/quot/f )
 130     object swap eliminate-dispatch ;
 131
 132 : (do-inlining) ( #call word -- ? )
 133     #! If the generic was defined in an outer compilation unit,
 134     #! then it doesn't have a definition yet; the definition
 135     #! is built at the end of the compilation unit. We do not
 136     #! attempt inlining at this stage since the stack discipline
 137     #! is not finalized yet, so dispatch# might return an out
 138     #! of bounds value. This case comes up if a parsing word
 139     #! calls the compiler at parse time (doing so is
 140     #! discouraged, but it should still work.)
 141     {
 142         { [ dup never-inline-word? ] [ 2drop f ] }
 143         { [ dup always-inline-word? ] [ inline-word ] }
 144         { [ dup standard-generic? ] [ inline-standard-method ] }
 145         { [ dup math-generic? ] [ inline-math-method ] }
 146         { [ dup inline? ] [ inline-word ] }
 147         [ 2drop f ]
 148     } cond ;
 149
 150 : do-inlining ( #call word -- ? )
 151     #! Note the logic here: if there's a custom inlining hook,
 152     #! it is permitted to return f, which means that we try the
 153     #! normal inlining heuristic.
 154     [
 155         dup custom-inlining? [ 2dup inline-custom ] [ f ] if
 156         [ 2drop t ] [ (do-inlining) ] if
 157     ] with-scope ;