core/inference/backend/backend.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: inference.dataflow inference.state arrays generic io
   4 io.streams.string kernel math namespaces parser prettyprint
   5 sequences strings vectors words quotations effects classes
   6 continuations debugger assocs combinators compiler.errors
   7 generic.standard.engines.tuple accessors math.order definitions
   8 sets ;
   9 IN: inference.backend
  10
  11 : recursive-label ( word -- label/f )
  12     recursive-state get at ;
  13
  14 GENERIC: inline? ( word -- ? )
  15
  16 M: method-body inline?
  17     "method-generic" word-prop inline? ;
  18
  19 M: engine-word inline?
  20     "tuple-dispatch-generic" word-prop inline? ;
  21
  22 M: word inline?
  23     "inline" word-prop ;
  24
  25 SYMBOL: visited
  26
  27 : reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
  28
  29 : (redefined) ( word -- )
  30     dup visited get key? [ drop ] [
  31         [ reset-on-redefine reset-props ]
  32         [ visited get conjoin ]
  33         [
  34             crossref get at keys
  35             [ word? ] filter
  36             [
  37                 [ reset-on-redefine [ word-prop ] with contains? ]
  38                 [ inline? ]
  39                 bi or
  40             ] filter
  41             [ (redefined) ] each
  42         ] tri
  43     ] if ;
  44
  45 M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
  46
  47 : local-recursive-state ( -- assoc )
  48     recursive-state get dup keys
  49     [ dup word? [ inline? ] when not ] find drop
  50     [ head-slice ] when* ;
  51
  52 : inline-recursive-label ( word -- label/f )
  53     local-recursive-state at ;
  54
  55 : recursive-quotation? ( quot -- ? )
  56     local-recursive-state [ first eq? ] with contains? ;
  57
  58 TUPLE: inference-error error type rstate ;
  59
  60 M: inference-error compiler-error-type type>> ;
  61
  62 M: inference-error error-help error>> error-help ;
  63
  64 : (inference-error) ( ... class type -- * )
  65     >r boa r>
  66     recursive-state get
  67     \ inference-error boa throw ; inline
  68
  69 : inference-error ( ... class -- * )
  70     +error+ (inference-error) ; inline
  71
  72 : inference-warning ( ... class -- * )
  73     +warning+ (inference-error) ; inline
  74
  75 TUPLE: literal-expected ;
  76
  77 M: object value-literal \ literal-expected inference-warning ;
  78
  79 : pop-literal ( -- rstate obj )
  80     1 #drop node,
  81     pop-d dup value-literal >r value-recursion r> ;
  82
  83 : value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
  84
  85 : add-inputs ( seq stack -- n stack )
  86     tuck [ length ] bi@ - dup 0 >
  87     [ dup value-vector [ swapd push-all ] keep ]
  88     [ drop 0 swap ] if ;
  89
  90 : ensure-values ( seq -- )
  91     meta-d [ add-inputs ] change d-in [ + ] change ;
  92
  93 : current-effect ( -- effect )
  94     d-in get
  95     meta-d get length <effect>
  96     terminated? get >>terminated? ;
  97
  98 : init-inference ( -- )
  99     terminated? off
 100     V{ } clone meta-d set
 101     V{ } clone meta-r set
 102     0 d-in set
 103     dataflow-graph off
 104     current-node off ;
 105
 106 GENERIC: apply-object ( obj -- )
 107
 108 : apply-literal ( obj -- )
 109     <value> push-d #push 1 0 pick node-outputs node, ;
 110
 111 M: object apply-object apply-literal ;
 112
 113 M: wrapper apply-object
 114     wrapped>> dup +called+ depends-on apply-literal ;
 115
 116 : terminate ( -- )
 117     terminated? on #terminate node, ;
 118
 119 : infer-quot ( quot rstate -- )
 120     recursive-state get [
 121         recursive-state set
 122         [ apply-object terminated? get not ] all? drop
 123     ] dip recursive-state set ;
 124
 125 : infer-quot-recursive ( quot word label -- )
 126     2array recursive-state get swap prefix infer-quot ;
 127
 128 : time-bomb ( error -- )
 129     [ throw ] curry recursive-state get infer-quot ;
 130
 131 : bad-call ( -- )
 132     "call must be given a callable" time-bomb ;
 133
 134 TUPLE: recursive-quotation-error quot ;
 135
 136 : infer-quot-value ( value -- )
 137     dup recursive-quotation? [
 138         value-literal recursive-quotation-error inference-error
 139     ] [
 140         dup value-literal callable? [
 141             [ value-literal ]
 142             [ [ value-recursion ] keep f 2array prefix ]
 143             bi infer-quot
 144         ] [
 145             drop bad-call
 146         ] if
 147     ] if ;
 148
 149 TUPLE: too-many->r ;
 150
 151 : check->r ( -- )
 152     meta-r get empty? terminated? get or
 153     [ \ too-many->r inference-error ] unless ;
 154
 155 TUPLE: too-many-r> ;
 156
 157 : check-r> ( n -- )
 158     meta-r get length >
 159     [ \ too-many-r> inference-error ] when ;
 160
 161 : infer->r ( n -- )
 162     dup ensure-values
 163     #>r
 164     over 0 pick node-inputs
 165     over [ pop-d ] replicate reverse [ push-r ] each
 166     0 pick pick node-outputs
 167     node,
 168     drop ;
 169
 170 : infer-r> ( n -- )
 171     dup check-r>
 172     #r>
 173     0 pick pick node-inputs
 174     over [ pop-r ] replicate reverse [ push-d ] each
 175     over 0 pick node-outputs
 176     node,
 177     drop ;
 178
 179 : undo-infer ( -- )
 180     recorded get [ f "inferred-effect" set-word-prop ] each ;
 181
 182 : (consume-values) ( n -- )
 183     meta-d get [ length swap - ] keep set-length ;
 184
 185 : consume-values ( seq node -- )
 186     >r length r>
 187     over ensure-values
 188     over 0 rot node-inputs
 189     (consume-values) ;
 190
 191 : produce-values ( seq node -- )
 192     >r value-vector dup r> set-node-out-d
 193     meta-d get push-all ;
 194
 195 : if-inline ( word true false -- )
 196     [ dup inline? ] 2dip if ; inline
 197
 198 : consume/produce ( effect node -- )
 199     [ [ in>> ] dip consume-values ]
 200     [ [ out>> ] dip produce-values ]
 201     [ node, terminated?>> [ terminate ] when ]
 202     2tri ;
 203
 204 GENERIC: constructor ( value -- word/f )
 205
 206 GENERIC: infer-uncurry ( value -- )
 207
 208 M: curried infer-uncurry
 209     drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
 210
 211 M: curried constructor
 212     drop \ curry ;
 213
 214 M: composed infer-uncurry
 215     drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
 216
 217 M: composed constructor
 218     drop \ compose ;
 219
 220 M: object infer-uncurry drop ;
 221
 222 M: object constructor drop f ;
 223
 224 : reify-curry ( value -- )
 225     dup infer-uncurry
 226     constructor [
 227         peek-d reify-curry
 228         1 infer->r
 229         peek-d reify-curry
 230         1 infer-r>
 231         (( obj quot -- curry )) swap #call consume/produce
 232     ] when* ;
 233
 234 : reify-curries ( n -- )
 235     meta-d get reverse [
 236         dup special? [
 237             over infer->r
 238             dup reify-curry
 239             over infer-r>
 240         ] when 2drop
 241     ] 2each ;
 242
 243 : reify-all ( -- )
 244     meta-d get length reify-curries ;
 245
 246 : end-infer ( -- )
 247     check->r
 248     reify-all
 249     f #return node, ;
 250
 251 : unify-lengths ( seq -- newseq )
 252     dup empty? [
 253         dup [ length ] map supremum
 254         [ swap add-inputs nip ] curry map
 255     ] unless ;
 256
 257 DEFER: unify-values
 258
 259 : unify-curries ( seq -- value )
 260     [ [ obj>> ] map unify-values ]
 261     [ [ quot>> ] map unify-values ] bi
 262     <curried> ;
 263
 264 : unify-composed ( seq -- value )
 265     [ [ quot1>> ] map unify-values ]
 266     [ [ quot2>> ] map unify-values ] bi
 267     <composed> ;
 268
 269 TUPLE: cannot-unify-specials ;
 270
 271 : cannot-unify-specials ( -- * )
 272     \ cannot-unify-specials inference-warning ;
 273
 274 : unify-values ( seq -- value )
 275     {
 276         { [ dup all-eq? ] [ first ] }
 277         { [ dup [ curried? ] all? ] [ unify-curries ] }
 278         { [ dup [ composed? ] all? ] [ unify-composed ] }
 279         { [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
 280         [ drop <computed> ]
 281     } cond ;
 282
 283 : unify-stacks ( seq -- stack )
 284     flip [ unify-values ] V{ } map-as ;
 285
 286 : balanced? ( in out -- ? )
 287     [ dup [ length - ] [ 2drop f ] if ] 2map
 288     sift all-equal? ;
 289
 290 TUPLE: unbalanced-branches-error quots in out ;
 291
 292 : unbalanced-branches-error ( quots in out -- * )
 293     \ unbalanced-branches-error inference-error ;
 294
 295 : unify-inputs ( max-d-in d-in meta-d -- meta-d )
 296     dup [
 297         [ [ - ] dip length + ] keep add-inputs nip
 298     ] [
 299         2nip
 300     ] if ;
 301
 302 : unify-effect ( quots in out -- newin newout )
 303     #! in is a sequence of integers, out is a sequence of
 304     #! stacks.
 305     2dup balanced? [
 306         over supremum -rot
 307         [ >r dupd r> unify-inputs ] 2map
 308         sift unify-stacks
 309         rot drop
 310     ] [
 311         unbalanced-branches-error
 312     ] if ;
 313
 314 : active-variable ( seq symbol -- seq )
 315     [
 316         swap terminated? over at [ 2drop f ] [ at ] if
 317     ] curry map ;
 318
 319 : branch-variable ( seq symbol -- seq )
 320     [ swap at ] curry map ;
 321
 322 : datastack-effect ( seq -- )
 323     [ quotation branch-variable ]
 324     [ d-in branch-variable ]
 325     [ meta-d active-variable ] tri
 326     unify-effect
 327     [ d-in set ] [ meta-d set ] bi* ;
 328
 329 : retainstack-effect ( seq -- )
 330     [ quotation branch-variable ]
 331     [ length 0 <repetition> ]
 332     [ meta-r active-variable ] tri
 333     unify-effect
 334     [ drop ] [ meta-r set ] bi* ;
 335
 336 : unify-effects ( seq -- )
 337     [ datastack-effect ]
 338     [ retainstack-effect ]
 339     [ [ terminated? swap at ] all? terminated? set ]
 340     tri ;
 341
 342 : unify-dataflow ( effects -- nodes )
 343     dataflow-graph branch-variable ;
 344
 345 : copy-inference ( -- )
 346     meta-d [ clone ] change
 347     meta-r [ clone ] change
 348     d-in [ ] change
 349     dataflow-graph off
 350     current-node off ;
 351
 352 : infer-branch ( last value -- namespace )
 353     [
 354         copy-inference
 355
 356         [ value-literal quotation set ]
 357         [ infer-quot-value ]
 358         bi
 359
 360         terminated? get [ drop ] [ call node, ] if
 361     ] H{ } make-assoc ; inline
 362
 363 : (infer-branches) ( last branches -- list )
 364     [ infer-branch ] with map
 365     [ unify-effects ] [ unify-dataflow ] bi ; inline
 366
 367 : infer-branches ( last branches node -- )
 368     #! last is a quotation which provides a #return or a #values
 369     1 reify-curries
 370     call dup node,
 371     pop-d drop
 372     >r (infer-branches) r> set-node-children
 373     #merge node, ; inline
 374
 375 : make-call-node ( word effect -- )
 376     swap dup inline?
 377     over dup recursive-label eq? not and [
 378         meta-d get clone -rot
 379         recursive-label #call-label [ consume/produce ] keep
 380         set-node-in-d
 381     ] [
 382         over effect-in length reify-curries
 383         #call consume/produce
 384     ] if ;
 385
 386 TUPLE: cannot-infer-effect word ;
 387
 388 : cannot-infer-effect ( word -- * )
 389     \ cannot-infer-effect inference-warning ;
 390
 391 TUPLE: effect-error word inferred declared ;
 392
 393 : effect-error ( word inferred declared -- * )
 394     \ effect-error inference-error ;
 395
 396 TUPLE: missing-effect word ;
 397
 398 : effect-required? ( word -- ? )
 399     {
 400         { [ dup inline? ] [ drop f ] }
 401         { [ dup deferred? ] [ drop f ] }
 402         { [ dup crossref? not ] [ drop f ] }
 403         [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
 404     } cond ;
 405
 406 : ?missing-effect ( word -- )
 407     dup effect-required?
 408     [ missing-effect inference-error ] [ drop ] if ;
 409
 410 : check-effect ( word effect -- )
 411     over stack-effect {
 412         { [ dup not ] [ 2drop ?missing-effect ] }
 413         { [ 2dup effect<= ] [ 3drop ] }
 414         [ effect-error ]
 415     } cond ;
 416
 417 : finish-word ( word -- )
 418     current-effect
 419     [ check-effect ]
 420     [ drop recorded get push ]
 421     [ "inferred-effect" set-word-prop ]
 422     2tri ;
 423
 424 : maybe-cannot-infer ( word quot -- )
 425     [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
 426
 427 : infer-word ( word -- effect )
 428     [
 429         [
 430             init-inference
 431             dependencies off
 432             dup def>> over dup infer-quot-recursive
 433             end-infer
 434             finish-word
 435             current-effect
 436         ] with-scope
 437     ] maybe-cannot-infer ;
 438
 439 : custom-infer ( word -- )
 440     #! Customized inference behavior
 441     [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
 442
 443 : cached-infer ( word -- )
 444     dup "inferred-effect" word-prop make-call-node ;
 445
 446 : apply-word ( word -- )
 447     {
 448         { [ dup "infer" word-prop ] [ custom-infer ] }
 449         { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
 450         { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
 451         [ dup infer-word make-call-node ]
 452     } cond ;
 453
 454 : declared-infer ( word -- )
 455     dup stack-effect [
 456         make-call-node
 457     ] [
 458         \ missing-effect inference-error
 459     ] if* ;
 460
 461 GENERIC: collect-label-info* ( label node -- )
 462
 463 M: node collect-label-info* 2drop ;
 464
 465 : (collect-label-info) ( label node vector -- )
 466     >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
 467     inline
 468
 469 M: #call-label collect-label-info*
 470     over calls>> (collect-label-info) ;
 471
 472 M: #return collect-label-info*
 473     over returns>> (collect-label-info) ;
 474
 475 : collect-label-info ( #label -- )
 476     V{ } clone >>calls
 477     V{ } clone >>returns
 478     dup [ collect-label-info* ] with each-node ;
 479
 480 : nest-node ( -- ) #entry node, ;
 481
 482 : unnest-node ( new-node -- new-node )
 483     dup node-param #return node,
 484     dataflow-graph get 1array over set-node-children ;
 485
 486 : inlined-block? ( word -- ? )
 487     "inlined-block" word-prop ;
 488
 489 : <inlined-block> ( -- word )
 490     gensym dup t "inlined-block" set-word-prop ;
 491
 492 : inline-block ( word -- #label data )
 493     [
 494         copy-inference nest-node
 495         [ def>> ] [ <inlined-block> ] bi
 496         [ infer-quot-recursive ] 2keep
 497         #label unnest-node
 498         dup collect-label-info
 499     ] H{ } make-assoc ;
 500
 501 : join-values ( #label -- )
 502     calls>> [ in-d>> ] map meta-d get suffix
 503     unify-lengths unify-stacks
 504     meta-d [ length tail* ] change ;
 505
 506 : splice-node ( node -- )
 507     dup successor>> [
 508         [ node, ] [ penultimate-node ] bi
 509         f >>successor
 510         current-node set
 511     ] [ drop ] if ;
 512
 513 : apply-infer ( data -- )
 514     { meta-d meta-r d-in terminated? } swap extract-keys
 515     namespace swap update ;
 516
 517 : current-stack-height ( -- n )
 518     d-in get meta-d get length - ;
 519
 520 : word-stack-height ( word -- n )
 521     stack-effect effect-height ;
 522
 523 : bad-recursive-declaration ( word inferred -- )
 524     dup 0 < [ 0 swap ] [ 0 ] if <effect>
 525     over stack-effect
 526     effect-error ;
 527
 528 : check-stack-height ( word height -- )
 529     over word-stack-height over =
 530     [ 2drop ] [ bad-recursive-declaration ] if ;
 531
 532 : inline-recursive-word ( word #label -- )
 533     current-stack-height [
 534         flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
 535         [ node, ]
 536         [ calls>> [ [ flatten-curries ] modify-values ] each ]
 537         [ word>> ]
 538         tri
 539     ] dip
 540     current-stack-height -
 541     check-stack-height ;
 542
 543 : inline-word ( word -- )
 544     dup inline-block over recursive-label?
 545     [ drop inline-recursive-word ]
 546     [ apply-infer node-child successor>> splice-node drop ] if ;
 547
 548 M: word apply-object
 549     [
 550         dup +inlined+ depends-on
 551         dup inline-recursive-label
 552         [ declared-infer ] [ inline-word ] if
 553     ] [
 554         dup +called+ depends-on
 555         dup recursive-label
 556         [ declared-infer ] [ apply-word ] if
 557     ] if-inline ;
 558
 559 : with-infer ( quot -- effect dataflow )
 560     [
 561         [
 562             V{ } clone recorded set
 563             init-inference
 564             call
 565             end-infer
 566             current-effect
 567             dataflow-graph get
 568         ] [ ] [ undo-infer ] cleanup
 569     ] with-scope ;