basis/compiler/tree/propagation/inlining/inlining.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes.algebra combinators
   4 combinators.short-circuit compiler.tree compiler.tree.builder
   5 compiler.tree.normalization compiler.tree.propagation.info
   6 compiler.tree.propagation.nodes compiler.tree.recursive generic
   7 generic.math generic.single generic.standard kernel locals math
   8 math.partial-dispatch namespaces quotations sequences words ;
   9 IN: compiler.tree.propagation.inlining
  10
  11 : splicing-call ( #call word -- nodes )
  12     [ [ in-d>> ] [ out-d>> ] bi ] dip <#call> 1array ;
  13
  14 : open-code-#call ( #call word/quot -- nodes/f )
  15     [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
  16
  17 : splicing-body ( #call quot/word -- nodes/f )
  18     open-code-#call dup [ analyze-recursive normalize ] when ;
  19
  20 ! Dispatch elimination
  21 : undo-inlining ( #call -- ? )
  22     f >>method f >>body f >>class drop f ;
  23
  24 : propagate-body ( #call -- ? )
  25     body>> (propagate) t ;
  26
  27 GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
  28
  29 M: word splicing-nodes splicing-call ;
  30
  31 M: callable splicing-nodes splicing-body ;
  32
  33 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
  34     dup [
  35         [ >>class ] dip
  36         over method>> over = [ drop propagate-body ] [
  37             2dup splicing-nodes dup [
  38                 [ >>method ] [ >>body ] bi* propagate-body
  39             ] [ 2drop undo-inlining ] if
  40         ] if
  41     ] [ 2drop undo-inlining ] if ;
  42
  43 : inlining-standard-method ( #call word -- class/f method/f )
  44     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
  45         2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
  46             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
  47             [ swap nth value-info class>> dup ] dip
  48             method-for-class
  49         ] if
  50     ] if ;
  51
  52 : inline-standard-method ( #call word -- ? )
  53     dupd inlining-standard-method eliminate-dispatch ;
  54
  55 : normalize-math-class ( class -- class' )
  56     {
  57         null
  58         fixnum bignum integer
  59         ratio rational
  60         float real
  61         complex number
  62         object
  63     } [ class<= ] with find nip ;
  64
  65 : inlining-math-method ( #call word -- class/f quot/f )
  66     swap in-d>>
  67     first2 [ value-info class>> normalize-math-class ] bi@
  68     3dup math-both-known?
  69     [ math-method* ] [ 3drop f ] if
  70     number swap ;
  71
  72 : inline-math-method ( #call word -- ? )
  73     dupd inlining-math-method eliminate-dispatch ;
  74
  75 ! Method body inlining
  76 SYMBOL: history
  77
  78 : already-inlined? ( obj -- ? ) history get member-eq? ;
  79
  80 : add-to-history ( obj -- ) history [ swap suffix ] change ;
  81
  82 :: inline-word ( #call word -- ? )
  83     word already-inlined? [ f ] [
  84         #call word splicing-body [
  85             word add-to-history
  86             #call body<<
  87             #call propagate-body
  88         ] [ f ] if*
  89     ] if ;
  90
  91 : always-inline-word? ( word -- ? )
  92     { curry compose } member-eq? ;
  93
  94 : never-inline-word? ( word -- ? )
  95     { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
  96
  97 : custom-inlining? ( word -- quot/f )
  98     "custom-inlining" word-prop ;
  99
 100 : inline-custom ( #call word -- ? )
 101     [ dup ] [ custom-inlining? ] bi*
 102     call( #call -- word/quot/f )
 103     object swap eliminate-dispatch ;
 104
 105 : (do-inlining) ( #call word -- ? )
 106     {
 107         { [ dup never-inline-word? ] [ 2drop f ] }
 108         { [ dup always-inline-word? ] [ inline-word ] }
 109         { [ dup standard-generic? ] [ inline-standard-method ] }
 110         { [ dup math-generic? ] [ inline-math-method ] }
 111         { [ dup inline? ] [ inline-word ] }
 112         [ 2drop f ]
 113     } cond ;
 114
 115 : do-inlining ( #call word -- ? )
 116     [
 117         dup custom-inlining? [ 2dup inline-custom ] [ f ] if
 118         [ 2drop t ] [ (do-inlining) ] if
 119     ] with-scope ;