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 ! Phi node: merging is a sequence of sequences of values
 148 TUPLE: #merge < node merging ;
 149
 150 : #merge ( -- node ) \ #merge all-out-node ;
 151
 152 TUPLE: #terminate < node ;
 153
 154 : #terminate ( -- node ) \ #terminate new ;
 155
 156 TUPLE: #declare < node ;
 157
 158 : #declare ( classes -- node ) \ #declare param-node ;
 159
 160 : node-inputs ( d-count r-count node -- )
 161     tuck
 162     [ swap d-tail flatten-curries >>in-d drop ]
 163     [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
 164
 165 : node-outputs ( d-count r-count node -- )
 166     tuck
 167     [ swap d-tail flatten-curries >>out-d drop ]
 168     [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
 169
 170 : node, ( node -- )
 171     dataflow-graph get [
 172         dup current-node [ set-node-successor ] change
 173     ] [
 174         dup dataflow-graph set  current-node set
 175     ] if ;
 176
 177 : node-values ( node -- values )
 178     { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
 179     4array concat ;
 180
 181 : last-node ( node -- last )
 182     dup successor>> [ last-node ] [ ] ?if ;
 183
 184 : penultimate-node ( node -- penultimate )
 185     dup successor>> dup [
 186         dup successor>>
 187         [ nip penultimate-node ] [ drop ] if
 188     ] [
 189         2drop f
 190     ] if ;
 191
 192 : #drop ( n -- #shuffle )
 193     d-tail flatten-curries \ #shuffle in-node ;
 194
 195 : node-exists? ( node quot: ( node -- ? ) -- ? )
 196     over [
 197         2dup 2slip rot [
 198             2drop t
 199         ] [
 200             >r [ children>> ] [ successor>> ] bi suffix r>
 201             [ node-exists? ] curry contains?
 202         ] if
 203     ] [
 204         2drop f
 205     ] if ; inline recursive
 206
 207 GENERIC: calls-label* ( label node -- ? )
 208
 209 M: node calls-label* 2drop f ;
 210
 211 M: #call-label calls-label* param>> eq? ;
 212
 213 : calls-label? ( label node -- ? )
 214     [ calls-label* ] with node-exists? ;
 215
 216 : recursive-label? ( node -- ? )
 217     [ param>> ] keep calls-label? ;
 218
 219 SYMBOL: node-stack
 220
 221 : >node ( node -- ) node-stack get push ;
 222 : node> ( -- node ) node-stack get pop ;
 223 : node@ ( -- node ) node-stack get peek ;
 224
 225 : iterate-next ( -- node ) node@ successor>> ;
 226
 227 : iterate-nodes ( node quot: ( -- ) -- )
 228     over [
 229         [ swap >node call node> drop ] keep iterate-nodes
 230     ] [
 231         2drop
 232     ] if ; inline recursive
 233
 234 : (each-node) ( quot: ( node -- ) -- next )
 235     node@ [ swap call ] 2keep
 236     node-children [
 237         [
 238             [ (each-node) ] keep swap
 239         ] iterate-nodes
 240     ] each drop
 241     iterate-next ; inline recursive
 242
 243 : with-node-iterator ( quot -- )
 244     >r V{ } clone node-stack r> with-variable ; inline
 245
 246 : each-node ( node quot -- )
 247     [
 248         swap [
 249             [ (each-node) ] keep swap
 250         ] iterate-nodes drop
 251     ] with-node-iterator ; inline
 252
 253 : map-children ( node quot -- )
 254     over [
 255         over children>> [
 256             [ map ] curry change-children drop
 257         ] [
 258             2drop
 259         ] if
 260     ] [
 261         2drop
 262     ] if ; inline
 263
 264 : (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
 265     dup >r call dup [
 266         >>successor
 267         successor>> dup successor>>
 268         r> (transform-nodes)
 269     ] [
 270         r> 2drop f >>successor drop
 271     ] if ; inline recursive
 272
 273 : transform-nodes ( node quot -- new-node )
 274     over [
 275         [ call dup dup successor>> ] keep (transform-nodes)
 276     ] [ drop ] if ; inline
 277
 278 : node-literal? ( node value -- ? )
 279     dup value? >r swap literals>> key? r> or ;
 280
 281 : node-literal ( node value -- obj )
 282     dup value?
 283     [ nip value-literal ] [ swap literals>> at ] if ;
 284
 285 : node-interval ( node value -- interval )
 286     swap intervals>> at ;
 287
 288 : node-class ( node value -- class )
 289     swap classes>> at object or ;
 290
 291 : node-input-classes ( node -- seq )
 292     dup in-d>> [ node-class ] with map ;
 293
 294 : node-output-classes ( node -- seq )
 295     dup out-d>> [ node-class ] with map ;
 296
 297 : node-input-intervals ( node -- seq )
 298     dup in-d>> [ node-interval ] with map ;
 299
 300 : node-class-first ( node -- class )
 301     dup in-d>> first node-class ;
 302
 303 : active-children ( node -- seq )
 304     children>> [ last-node ] map [ #terminate? not ] filter ;
 305
 306 DEFER: #tail?
 307
 308 PREDICATE: #tail-merge < #merge node-successor #tail? ;
 309
 310 PREDICATE: #tail-values < #values node-successor #tail? ;
 311
 312 UNION: #tail
 313     POSTPONE: f #return #tail-values #tail-merge #terminate ;
 314
 315 : tail-call? ( -- ? )
 316     #! We don't consider calls which do non-local exits to be
 317     #! tail calls, because this gives better error traces.
 318     node-stack get [
 319         successor>> [ #tail? ] [ #terminate? not ] bi and
 320     ] all? ;