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