core/compiler/inference/words.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays errors generic hashtables kernel
   4 math math-internals namespaces parser prettyprint sequences
   5 strings vectors words ;
   6 IN: inference
   7
   8 : consume-values ( seq node -- )
   9     >r length r>
  10     over ensure-values
  11     over 0 rot node-inputs
  12     meta-d get [ length swap - ] keep set-length ;
  13
  14 : produce-values ( seq node -- )
  15     >r [ drop <computed> ] map dup r> set-node-out-d
  16     meta-d get swap nappend ;
  17
  18 : recursing? ( word -- label/f )
  19     recursive-state get <reversed> assoc ;
  20
  21 : if-inline ( word true false -- )
  22     >r >r dup "inline" word-prop r> r> if ; inline
  23
  24 : make-call-node ( word -- node )
  25     [ dup recursing? [ #call-label ] [ #call ] ?if ]
  26     [ #call ]
  27     if-inline ;
  28
  29 : consume/produce ( effect word -- )
  30     meta-d get clone >r
  31     swap make-call-node dup node,
  32     over effect-in over consume-values
  33     over effect-out over produce-values
  34     r> over #call-label? [ swap set-node-in-d ] [ 2drop ] if
  35     effect-terminated? [ terminate ] when ;
  36
  37 TUPLE: no-effect word ;
  38
  39 : no-effect ( word -- * )
  40     <no-effect> inference-warning ;
  41
  42 : nest-node ( -- ) #entry node, ;
  43
  44 : unnest-node ( new-node -- new-node )
  45     dup node-param #return node,
  46     dataflow-graph get 1array over set-node-children ;
  47
  48 : add-recursive-state ( word label -- )
  49     2array recursive-state [ swap add ] change ;
  50
  51 : block-label ( word -- newword )
  52     word-name " - inlined" append f <word> ;
  53
  54 : inline-block ( word -- node-block data )
  55     [
  56         copy-inference nest-node
  57         dup block-label 2dup add-recursive-state
  58         #label >r word-def infer-quot r>
  59         unnest-node
  60     ] make-hash ;
  61
  62 : apply-infer ( hash -- )
  63     { meta-d meta-r d-in }
  64     [ [ swap hash ] keep set ] each-with ;
  65
  66 GENERIC: collect-recursion* ( label node -- )
  67
  68 M: node collect-recursion* 2drop ;
  69
  70 M: #call-label collect-recursion*
  71     tuck node-param eq? [ node-in-d , ] [ drop ] if ;
  72
  73 : collect-recursion ( #label -- seq )
  74     dup node-param swap
  75     [ [ collect-recursion* ] each-node-with ] { } make ;
  76
  77 : join-values ( node -- )
  78     collect-recursion meta-d get add unify-lengths unify-stacks
  79     meta-d [ length tail* >vector ] change ;
  80
  81 : splice-node ( node -- )
  82     dup node-successor [
  83         dup node, penultimate-node f over set-node-successor
  84         dup current-node set
  85     ] when drop ;
  86
  87 : inline-closure ( word -- )
  88     dup inline-block over recursive-label? [
  89         meta-d get >r
  90         drop join-values inline-block apply-infer
  91         r> over 2dup set-node-out-d set-node-in-d node,
  92     ] [
  93         apply-infer node-child node-successor splice-node drop
  94     ] if ;
  95
  96 : infer-compound ( word -- hash )
  97     [
  98         recursive-state get init-inference inline-block nip
  99     ] with-scope ;
 100
 101 GENERIC: infer-word ( word -- effect data )
 102
 103 M: word infer-word no-effect ;
 104
 105 TUPLE: effect-error word effect ;
 106
 107 : effect-error ( word effect -- * )
 108     <effect-error> inference-error ;
 109
 110 : check-effect ( word effect -- )
 111     over "infer" word-prop [
 112         over recorded get push
 113         over "declared-effect" word-prop 2dup
 114         [ swap effect<= [ effect-error ] unless ] [ 2drop ] if
 115     ] unless 2drop ;
 116
 117 : save-inferred-data ( word effect vars -- )
 118     >r over r>
 119     dup vars-trivial? [ drop f ] when
 120     "inferred-vars" set-word-prop
 121     "inferred-effect" set-word-prop ;
 122
 123 : finish-word ( word -- effect vars )
 124     current-effect inferred-vars get
 125     pick custom-infer? [
 126         rot drop
 127     ] [
 128         >r 2dup check-effect r>
 129         [ save-inferred-data ] 2keep
 130     ] if ;
 131
 132 M: compound infer-word
 133     [ dup infer-compound [ finish-word ] bind ]
 134     [ swap t "no-effect" set-word-prop rethrow ] recover ;
 135
 136 : custom-infer ( word -- )
 137     #! Customized inference behavior
 138     dup "inferred-vars" word-prop apply-vars
 139     dup "inferred-effect" word-prop effect-in ensure-values
 140     "infer" word-prop call ;
 141
 142 : apply-effect/vars ( word effect vars -- )
 143     apply-vars consume/produce ;
 144
 145 : cached-infer ( word -- )
 146     dup "inferred-effect" word-prop
 147     over "inferred-vars" word-prop
 148     apply-effect/vars ;
 149
 150 : default-apply-word ( word -- )
 151     {
 152         { [ dup "no-effect" word-prop ] [ no-effect ] }
 153         { [ dup "infer" word-prop ] [ custom-infer ] }
 154         { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
 155         { [ t ] [ dup infer-word apply-effect/vars ] }
 156     } cond ;
 157
 158 M: word apply-word default-apply-word ;
 159
 160 M: symbol apply-word apply-literal ;
 161
 162 TUPLE: recursive-declare-error word ;
 163
 164 : declared-infer ( word -- )
 165     dup stack-effect [
 166         consume/produce
 167     ] [
 168         <recursive-declare-error> inference-error
 169     ] if* ;
 170
 171 : apply-inline ( word -- )
 172     dup recursive-state get peek first eq?
 173     [ declared-infer ] [ inline-closure ] if ;
 174
 175 : apply-compound ( word -- )
 176     dup recursing?
 177     [ declared-infer ] [ default-apply-word ] if ;
 178
 179 : custom-infer-vars ( word -- )
 180     dup "infer-vars" word-prop dup [
 181         swap "inferred-effect" word-prop effect-in ensure-values
 182         call
 183     ] [
 184         2drop
 185     ] if ;
 186
 187 M: compound apply-word
 188     dup custom-infer-vars
 189     [ apply-inline ] [ apply-compound ] if-inline ;