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 : inlining-math-partial ( #call word -- class/f quot/f )
  83     [ "derived-from" word-prop first inlining-math-method ]
  84     [ nip 1quotation ] 2bi
  85     [ = not ] [ drop ] 2bi and ;
  86
  87 : inline-math-partial ( #call word -- ? )
  88     dupd inlining-math-partial eliminate-dispatch ;
  89
  90 ! Method body inlining
  91 SYMBOL: history
  92
  93 : already-inlined? ( obj -- ? ) history get member-eq? ;
  94
  95 : add-to-history ( obj -- ) history [ swap suffix ] change ;
  96
  97 :: inline-word ( #call word -- ? )
  98     word already-inlined? [ f ] [
  99         #call word splicing-body [
 100             word add-to-history
 101             #call (>>body)
 102             #call propagate-body
 103         ] [ f ] if*
 104     ] if ;
 105
 106 : always-inline-word? ( word -- ? )
 107     { curry compose } member-eq? ;
 108
 109 : never-inline-word? ( word -- ? )
 110     { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
 111
 112 : custom-inlining? ( word -- ? )
 113     "custom-inlining" word-prop ;
 114
 115 : inline-custom ( #call word -- ? )
 116     [ dup ] [ "custom-inlining" word-prop ] bi*
 117     call( #call -- word/quot/f )
 118     object swap eliminate-dispatch ;
 119
 120 : (do-inlining) ( #call word -- ? )
 121     #! If the generic was defined in an outer compilation unit,
 122     #! then it doesn't have a definition yet; the definition
 123     #! is built at the end of the compilation unit. We do not
 124     #! attempt inlining at this stage since the stack discipline
 125     #! is not finalized yet, so dispatch# might return an out
 126     #! of bounds value. This case comes up if a parsing word
 127     #! calls the compiler at parse time (doing so is
 128     #! discouraged, but it should still work.)
 129     {
 130         { [ dup never-inline-word? ] [ 2drop f ] }
 131         { [ dup always-inline-word? ] [ inline-word ] }
 132         { [ dup standard-generic? ] [ inline-standard-method ] }
 133         { [ dup math-generic? ] [ inline-math-method ] }
 134         { [ dup inline? ] [ inline-word ] }
 135         [ 2drop f ]
 136     } cond ;
 137
 138 : do-inlining ( #call word -- ? )
 139     #! Note the logic here: if there's a custom inlining hook,
 140     #! it is permitted to return f, which means that we try the
 141     #! normal inlining heuristic.
 142     [
 143         dup custom-inlining? [ 2dup inline-custom ] [ f ] if
 144         [ 2drop t ] [ (do-inlining) ] if
 145     ] with-scope ;