core/inference/dataflow/dataflow.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic assocs kernel math namespaces parser
   4 sequences words vectors math.intervals effects classes
   5 inference.state accessors combinators ;
   6 IN: inference.dataflow
   7
   8 ! Computed value
   9 : <computed> ( -- value ) \ <computed> counter ;
  10
  11 ! Literal value
  12 TUPLE: value < identity-tuple literal uid recursion ;
  13
  14 : <value> ( obj -- value )
  15     <computed> recursive-state get value boa ;
  16
  17 M: value hashcode* nip value-uid ;
  18
  19 ! Result of curry
  20 TUPLE: curried obj quot ;
  21
  22 C: <curried> curried
  23
  24 ! Result of compose
  25 TUPLE: composed quot1 quot2 ;
  26
  27 C: <composed> composed
  28
  29 UNION: special curried composed ;
  30
  31 TUPLE: node < identity-tuple
  32 param
  33 in-d out-d in-r out-r
  34 classes literals intervals
  35 history successor children ;
  36
  37 M: node hashcode* drop node hashcode* ;
  38
  39 GENERIC: flatten-curry ( value -- )
  40
  41 M: curried flatten-curry
  42     [ obj>> flatten-curry ]
  43     [ quot>> flatten-curry ] bi ;
  44
  45 M: composed flatten-curry
  46     [ quot1>> flatten-curry ]
  47     [ quot2>> flatten-curry ] bi ;
  48
  49 M: object flatten-curry , ;
  50
  51 : flatten-curries ( seq -- newseq )
  52     dup [ special? ] contains? [
  53         [ [ flatten-curry ] each ] { } make
  54     ] when ;
  55
  56 : flatten-meta-d ( -- seq )
  57     meta-d get clone flatten-curries ;
  58
  59 : modify-values ( node quot -- )
  60     {
  61         [ change-in-d ]
  62         [ change-in-r ]
  63         [ change-out-d ]
  64         [ change-out-r ]
  65     } cleave drop ; inline
  66
  67 : node-shuffle ( node -- shuffle )
  68     [ in-d>> ] [ out-d>> ] bi <effect> ;
  69
  70 : param-node ( param class -- node )
  71     new swap >>param ; inline
  72
  73 : in-node ( seq class -- node )
  74     new swap >>in-d ; inline
  75
  76 : all-in-node ( class -- node )
  77     flatten-meta-d swap in-node ; inline
  78
  79 : out-node ( seq class -- node )
  80     new swap >>out-d ; inline
  81
  82 : all-out-node ( class -- node )
  83     flatten-meta-d swap out-node ; inline
  84
  85 : d-tail ( n -- seq )
  86     dup zero? [ drop f ] [ meta-d get swap tail* ] if ;
  87
  88 : r-tail ( n -- seq )
  89     dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
  90
  91 : node-child ( node -- child ) node-children first ;
  92
  93 TUPLE: #label < node word loop? returns calls ;
  94
  95 : #label ( word label -- node )
  96     \ #label param-node swap >>word ;
  97
  98 PREDICATE: #loop < #label #label-loop? ;
  99
 100 TUPLE: #entry < node ;
 101
 102 : #entry ( -- node ) \ #entry all-out-node ;
 103
 104 TUPLE: #call < node ;
 105
 106 : #call ( word -- node ) \ #call param-node ;
 107
 108 TUPLE: #call-label < node ;
 109
 110 : #call-label ( label -- node ) \ #call-label param-node ;
 111
 112 TUPLE: #push < node ;
 113
 114 : #push ( -- node ) \ #push new ;
 115
 116 TUPLE: #shuffle < node ;
 117
 118 : #shuffle ( -- node ) \ #shuffle new ;
 119
 120 TUPLE: #>r < node ;
 121
 122 : #>r ( -- node ) \ #>r new ;
 123
 124 TUPLE: #r> < node ;
 125
 126 : #r> ( -- node ) \ #r> new ;
 127
 128 TUPLE: #values < node ;
 129
 130 : #values ( -- node ) \ #values all-in-node ;
 131
 132 TUPLE: #return < node ;
 133
 134 : #return ( label -- node )
 135     \ #return all-in-node swap >>param ;
 136
 137 TUPLE: #branch < node ;
 138
 139 TUPLE: #if < #branch ;
 140
 141 : #if ( -- node ) peek-d 1array \ #if in-node ;
 142
 143 TUPLE: #dispatch < #branch ;
 144
 145 : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
 146
 147 TUPLE: #merge < node ;
 148
 149 : #merge ( -- node ) \ #merge all-out-node ;
 150
 151 TUPLE: #terminate < node ;
 152
 153 : #terminate ( -- node ) \ #terminate new ;
 154
 155 TUPLE: #declare < node ;
 156
 157 : #declare ( classes -- node ) \ #declare param-node ;
 158
 159 : node-inputs ( d-count r-count node -- )
 160     tuck
 161     [ swap d-tail flatten-curries >>in-d drop ]
 162     [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
 163
 164 : node-outputs ( d-count r-count node -- )
 165     tuck
 166     [ swap d-tail flatten-curries >>out-d drop ]
 167     [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
 168
 169 : node, ( node -- )
 170     dataflow-graph get [
 171         dup current-node [ set-node-successor ] change
 172     ] [
 173         dup dataflow-graph set  current-node set
 174     ] if ;
 175
 176 : node-values ( node -- values )
 177     { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
 178     4array concat ;
 179
 180 : last-node ( node -- last )
 181     dup successor>> [ last-node ] [ ] ?if ;
 182
 183 : penultimate-node ( node -- penultimate )
 184     dup successor>> dup [
 185         dup successor>>
 186         [ nip penultimate-node ] [ drop ] if
 187     ] [
 188         2drop f
 189     ] if ;
 190
 191 : #drop ( n -- #shuffle )
 192     d-tail flatten-curries \ #shuffle in-node ;
 193
 194 : node-exists? ( node quot -- ? )
 195     over [
 196         2dup 2slip rot [
 197             2drop t
 198         ] [
 199             >r [ children>> ] [ successor>> ] bi suffix r>
 200             [ node-exists? ] curry contains?
 201         ] if
 202     ] [
 203         2drop f
 204     ] if ; inline
 205
 206 GENERIC: calls-label* ( label node -- ? )
 207
 208 M: node calls-label* 2drop f ;
 209
 210 M: #call-label calls-label* param>> eq? ;
 211
 212 : calls-label? ( label node -- ? )
 213     [ calls-label* ] with node-exists? ;
 214
 215 : recursive-label? ( node -- ? )
 216     [ param>> ] keep calls-label? ;
 217
 218 SYMBOL: node-stack
 219
 220 : >node ( node -- ) node-stack get push ;
 221 : node> ( -- node ) node-stack get pop ;
 222 : node@ ( -- node ) node-stack get peek ;
 223
 224 : iterate-next ( -- node ) node@ successor>> ;
 225
 226 : iterate-nodes ( node quot -- )
 227     over [
 228         [ swap >node call node> drop ] keep iterate-nodes
 229     ] [
 230         2drop
 231     ] if ; inline
 232
 233 : (each-node) ( quot -- next )
 234     node@ [ swap call ] 2keep
 235     node-children [
 236         [
 237             [ (each-node) ] keep swap
 238         ] iterate-nodes
 239     ] each drop
 240     iterate-next ; inline
 241
 242 : with-node-iterator ( quot -- )
 243     >r V{ } clone node-stack r> with-variable ; inline
 244
 245 : each-node ( node quot -- )
 246     [
 247         swap [
 248             [ (each-node) ] keep swap
 249         ] iterate-nodes drop
 250     ] with-node-iterator ; inline
 251
 252 : map-children ( node quot -- )
 253     over [
 254         over children>> [
 255             [ map ] curry change-children drop
 256         ] [
 257             2drop
 258         ] if
 259     ] [
 260         2drop
 261     ] if ; inline
 262
 263 : (transform-nodes) ( prev node quot -- )
 264     dup >r call dup [
 265         >>successor
 266         successor>> dup successor>>
 267         r> (transform-nodes)
 268     ] [
 269         r> 2drop f >>successor drop
 270     ] if ; inline
 271
 272 : transform-nodes ( node quot -- new-node )
 273     over [
 274         [ call dup dup successor>> ] keep (transform-nodes)
 275     ] [ drop ] if ; inline
 276
 277 : node-literal? ( node value -- ? )
 278     dup value? >r swap literals>> key? r> or ;
 279
 280 : node-literal ( node value -- obj )
 281     dup value?
 282     [ nip value-literal ] [ swap literals>> at ] if ;
 283
 284 : node-interval ( node value -- interval )
 285     swap intervals>> at ;
 286
 287 : node-class ( node value -- class )
 288     swap classes>> at object or ;
 289
 290 : node-input-classes ( node -- seq )
 291     dup in-d>> [ node-class ] with map ;
 292
 293 : node-output-classes ( node -- seq )
 294     dup out-d>> [ node-class ] with map ;
 295
 296 : node-input-intervals ( node -- seq )
 297     dup in-d>> [ node-interval ] with map ;
 298
 299 : node-class-first ( node -- class )
 300     dup in-d>> first node-class ;
 301
 302 : active-children ( node -- seq )
 303     children>> [ last-node ] map [ #terminate? not ] filter ;
 304
 305 DEFER: #tail?
 306
 307 PREDICATE: #tail-merge < #merge node-successor #tail? ;
 308
 309 PREDICATE: #tail-values < #values node-successor #tail? ;
 310
 311 UNION: #tail
 312     POSTPONE: f #return #tail-values #tail-merge #terminate ;
 313
 314 : tail-call? ( -- ? )
 315     #! We don't consider calls which do non-local exits to be
 316     #! tail calls, because this gives better error traces.
 317     node-stack get [
 318         successor>> [ #tail? ] [ #terminate? not ] bi and
 319     ] all? ;