basis/inference/known-words/known-words.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors arrays byte-arrays
   4 classes sequences.private continuations.private effects generic
   5 hashtables hashtables.private inference.state inference.backend
   6 inference.dataflow io io.backend io.files io.files.private
   7 io.streams.c kernel kernel.private math math.private memory
   8 namespaces namespaces.private parser prettyprint quotations
   9 quotations.private sbufs sbufs.private sequences
  10 sequences.private slots.private strings strings.private system
  11 threads.private classes.tuple classes.tuple.private vectors
  12 vectors.private words words.private assocs summary
  13 compiler.units system.private ;
  14 IN: inference.known-words
  15
  16 ! Shuffle words
  17 : infer-shuffle-inputs ( shuffle node -- )
  18     >r effect-in length 0 r> node-inputs ;
  19
  20 : shuffle-stacks ( shuffle -- )
  21     meta-d [ swap shuffle ] change ;
  22
  23 : infer-shuffle-outputs ( shuffle node -- )
  24     >r effect-out length 0 r> node-outputs ;
  25
  26 : infer-shuffle ( shuffle -- )
  27     dup effect-in ensure-values
  28     #shuffle
  29     2dup infer-shuffle-inputs
  30     over shuffle-stacks
  31     2dup infer-shuffle-outputs
  32     node, drop ;
  33
  34 : define-shuffle ( word shuffle -- )
  35     [ infer-shuffle ] curry "infer" set-word-prop ;
  36
  37 {
  38     { drop  T{ effect f 1 {             } } }
  39     { 2drop T{ effect f 2 {             } } }
  40     { 3drop T{ effect f 3 {             } } }
  41     { dup   T{ effect f 1 { 0 0         } } }
  42     { 2dup  T{ effect f 2 { 0 1 0 1     } } }
  43     { 3dup  T{ effect f 3 { 0 1 2 0 1 2 } } }
  44     { rot   T{ effect f 3 { 1 2 0       } } }
  45     { -rot  T{ effect f 3 { 2 0 1       } } }
  46     { dupd  T{ effect f 2 { 0 0 1       } } }
  47     { swapd T{ effect f 3 { 1 0 2       } } }
  48     { nip   T{ effect f 2 { 1           } } }
  49     { 2nip  T{ effect f 3 { 2           } } }
  50     { tuck  T{ effect f 2 { 1 0 1       } } }
  51     { over  T{ effect f 2 { 0 1 0       } } }
  52     { pick  T{ effect f 3 { 0 1 2 0     } } }
  53     { swap  T{ effect f 2 { 1 0         } } }
  54 } [ define-shuffle ] assoc-each
  55
  56 \ >r [ 1 infer->r ] "infer" set-word-prop
  57
  58 \ r> [ 1 infer-r> ] "infer" set-word-prop
  59
  60 \ declare [
  61     1 ensure-values
  62     pop-literal nip
  63     dup ensure-values
  64     dup length d-tail
  65     swap #declare
  66     [ 2dup set-node-in-d set-node-out-d ] keep
  67     node,
  68 ] "infer" set-word-prop
  69
  70 ! Primitive combinators
  71 GENERIC: infer-call ( value -- )
  72
  73 M: value infer-call
  74     drop
  75     1 #drop node,
  76     pop-d infer-quot-value ;
  77
  78 M: curried infer-call
  79     infer-uncurry peek-d infer-call ;
  80
  81 M: composed infer-call
  82     infer-uncurry
  83     1 infer->r peek-d infer-call
  84     terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
  85
  86 M: object infer-call
  87     \ literal-expected inference-warning ;
  88
  89 \ call [
  90     1 ensure-values
  91     peek-d infer-call
  92 ] "infer" set-word-prop
  93
  94 \ call t "no-compile" set-word-prop
  95
  96 \ execute [
  97     1 ensure-values
  98     pop-literal nip
  99     dup word? [
 100         apply-object
 101     ] [
 102         drop
 103         "execute must be given a word" time-bomb
 104     ] if
 105 ] "infer" set-word-prop
 106
 107 \ execute t "no-compile" set-word-prop
 108
 109 \ if [
 110     3 ensure-values
 111     2 d-tail [ special? ] contains? [
 112         [ rot [ drop call ] [ nip call ] if ]
 113         recursive-state get infer-quot
 114     ] [
 115         [ #values ]
 116         2 #drop node, pop-d pop-d swap 2array
 117         [ #if ] infer-branches
 118     ] if
 119 ] "infer" set-word-prop
 120
 121 \ dispatch [
 122     2 ensure-values
 123     [ gensym #return ]
 124     pop-literal nip [ <value> ] map
 125     [ #dispatch ] infer-branches
 126 ] "infer" set-word-prop
 127
 128 \ dispatch t "no-compile" set-word-prop
 129
 130 \ curry [
 131     2 ensure-values
 132     pop-d pop-d swap <curried> push-d
 133 ] "infer" set-word-prop
 134
 135 \ compose [
 136     2 ensure-values
 137     pop-d pop-d swap <composed> push-d
 138 ] "infer" set-word-prop
 139
 140 ! Variadic tuple constructor
 141 \ <tuple-boa> [
 142     \ <tuple-boa>
 143     peek-d value-literal size>> { tuple } <effect>
 144     make-call-node
 145 ] "infer" set-word-prop
 146
 147 ! Non-standard control flow
 148 \ (throw) [
 149     \ (throw)
 150     peek-d value-literal 2 + { } <effect>
 151     t over set-effect-terminated?
 152     make-call-node
 153 ] "infer" set-word-prop
 154
 155 :  set-primitive-effect ( word effect -- )
 156     [ in>> "input-classes" set-word-prop ]
 157     [ out>> "default-output-classes" set-word-prop ]
 158     [ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
 159     2tri ;
 160
 161 ! Stack effects for all primitives
 162 \ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
 163 \ fixnum< make-foldable
 164
 165 \ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
 166 \ fixnum<= make-foldable
 167
 168 \ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
 169 \ fixnum> make-foldable
 170
 171 \ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
 172 \ fixnum>= make-foldable
 173
 174 \ eq? { object object } { object } <effect> set-primitive-effect
 175 \ eq? make-foldable
 176
 177 \ rehash-string { string } { } <effect> set-primitive-effect
 178
 179 \ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
 180 \ bignum>fixnum make-foldable
 181
 182 \ float>fixnum { float } { fixnum } <effect> set-primitive-effect
 183 \ bignum>fixnum make-foldable
 184
 185 \ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
 186 \ fixnum>bignum make-foldable
 187
 188 \ float>bignum { float } { bignum } <effect> set-primitive-effect
 189 \ float>bignum make-foldable
 190
 191 \ fixnum>float { fixnum } { float } <effect> set-primitive-effect
 192 \ fixnum>float make-foldable
 193
 194 \ bignum>float { bignum } { float } <effect> set-primitive-effect
 195 \ bignum>float make-foldable
 196
 197 \ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
 198 \ <ratio> make-foldable
 199
 200 \ string>float { string } { float } <effect> set-primitive-effect
 201 \ string>float make-foldable
 202
 203 \ float>string { float } { string } <effect> set-primitive-effect
 204 \ float>string make-foldable
 205
 206 \ float>bits { real } { integer } <effect> set-primitive-effect
 207 \ float>bits make-foldable
 208
 209 \ double>bits { real } { integer } <effect> set-primitive-effect
 210 \ double>bits make-foldable
 211
 212 \ bits>float { integer } { float } <effect> set-primitive-effect
 213 \ bits>float make-foldable
 214
 215 \ bits>double { integer } { float } <effect> set-primitive-effect
 216 \ bits>double make-foldable
 217
 218 \ <complex> { real real } { complex } <effect> set-primitive-effect
 219 \ <complex> make-foldable
 220
 221 \ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
 222 \ fixnum+ make-foldable
 223
 224 \ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 225 \ fixnum+fast make-foldable
 226
 227 \ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
 228 \ fixnum- make-foldable
 229
 230 \ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 231 \ fixnum-fast make-foldable
 232
 233 \ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
 234 \ fixnum* make-foldable
 235
 236 \ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 237 \ fixnum*fast make-foldable
 238
 239 \ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
 240 \ fixnum/i make-foldable
 241
 242 \ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 243 \ fixnum-mod make-foldable
 244
 245 \ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
 246 \ fixnum/mod make-foldable
 247
 248 \ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 249 \ fixnum-bitand make-foldable
 250
 251 \ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 252 \ fixnum-bitor make-foldable
 253
 254 \ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 255 \ fixnum-bitxor make-foldable
 256
 257 \ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
 258 \ fixnum-bitnot make-foldable
 259
 260 \ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
 261 \ fixnum-shift make-foldable
 262
 263 \ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
 264 \ fixnum-shift-fast make-foldable
 265
 266 \ bignum= { bignum bignum } { object } <effect> set-primitive-effect
 267 \ bignum= make-foldable
 268
 269 \ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
 270 \ bignum+ make-foldable
 271
 272 \ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
 273 \ bignum- make-foldable
 274
 275 \ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
 276 \ bignum* make-foldable
 277
 278 \ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
 279 \ bignum/i make-foldable
 280
 281 \ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
 282 \ bignum-mod make-foldable
 283
 284 \ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
 285 \ bignum/mod make-foldable
 286
 287 \ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
 288 \ bignum-bitand make-foldable
 289
 290 \ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
 291 \ bignum-bitor make-foldable
 292
 293 \ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
 294 \ bignum-bitxor make-foldable
 295
 296 \ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
 297 \ bignum-bitnot make-foldable
 298
 299 \ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
 300 \ bignum-shift make-foldable
 301
 302 \ bignum< { bignum bignum } { object } <effect> set-primitive-effect
 303 \ bignum< make-foldable
 304
 305 \ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
 306 \ bignum<= make-foldable
 307
 308 \ bignum> { bignum bignum } { object } <effect> set-primitive-effect
 309 \ bignum> make-foldable
 310
 311 \ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
 312 \ bignum>= make-foldable
 313
 314 \ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
 315 \ bignum-bit? make-foldable
 316
 317 \ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
 318 \ bignum-log2 make-foldable
 319
 320 \ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
 321 \ byte-array>bignum make-foldable
 322
 323 \ float= { float float } { object } <effect> set-primitive-effect
 324 \ float= make-foldable
 325
 326 \ float+ { float float } { float } <effect> set-primitive-effect
 327 \ float+ make-foldable
 328
 329 \ float- { float float } { float } <effect> set-primitive-effect
 330 \ float- make-foldable
 331
 332 \ float* { float float } { float } <effect> set-primitive-effect
 333 \ float* make-foldable
 334
 335 \ float/f { float float } { float } <effect> set-primitive-effect
 336 \ float/f make-foldable
 337
 338 \ float< { float float } { object } <effect> set-primitive-effect
 339 \ float< make-foldable
 340
 341 \ float-mod { float float } { float } <effect> set-primitive-effect
 342 \ float-mod make-foldable
 343
 344 \ float<= { float float } { object } <effect> set-primitive-effect
 345 \ float<= make-foldable
 346
 347 \ float> { float float } { object } <effect> set-primitive-effect
 348 \ float> make-foldable
 349
 350 \ float>= { float float } { object } <effect> set-primitive-effect
 351 \ float>= make-foldable
 352
 353 \ <word> { object object } { word } <effect> set-primitive-effect
 354 \ <word> make-flushable
 355
 356 \ word-xt { word } { integer integer } <effect> set-primitive-effect
 357 \ word-xt make-flushable
 358
 359 \ getenv { fixnum } { object } <effect> set-primitive-effect
 360 \ getenv make-flushable
 361
 362 \ setenv { object fixnum } { } <effect> set-primitive-effect
 363
 364 \ (exists?) { string } { object } <effect> set-primitive-effect
 365
 366 \ (directory) { string } { array } <effect> set-primitive-effect
 367
 368 \ gc { } { } <effect> set-primitive-effect
 369
 370 \ gc-stats { } { array } <effect> set-primitive-effect
 371
 372 \ save-image { string } { } <effect> set-primitive-effect
 373
 374 \ save-image-and-exit { string } { } <effect> set-primitive-effect
 375
 376 \ exit { integer } { } <effect>
 377 t over set-effect-terminated?
 378 set-primitive-effect
 379
 380 \ data-room { } { integer integer array } <effect> set-primitive-effect
 381 \ data-room make-flushable
 382
 383 \ code-room { } { integer integer integer integer } <effect> set-primitive-effect
 384 \ code-room  make-flushable
 385
 386 \ os-env { string } { object } <effect> set-primitive-effect
 387
 388 \ millis { } { integer } <effect> set-primitive-effect
 389 \ millis make-flushable
 390
 391 \ tag { object } { fixnum } <effect> set-primitive-effect
 392 \ tag make-foldable
 393
 394 \ cwd { } { string } <effect> set-primitive-effect
 395
 396 \ cd { string } { } <effect> set-primitive-effect
 397
 398 \ dlopen { string } { dll } <effect> set-primitive-effect
 399
 400 \ dlsym { string object } { c-ptr } <effect> set-primitive-effect
 401
 402 \ dlclose { dll } { } <effect> set-primitive-effect
 403
 404 \ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
 405 \ <byte-array> make-flushable
 406
 407 \ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
 408 \ <displaced-alien> make-flushable
 409
 410 \ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
 411 \ alien-signed-cell make-flushable
 412
 413 \ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 414
 415 \ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
 416 \ alien-unsigned-cell make-flushable
 417
 418 \ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
 419
 420 \ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
 421 \ alien-signed-8 make-flushable
 422
 423 \ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 424
 425 \ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
 426 \ alien-unsigned-8 make-flushable
 427
 428 \ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
 429
 430 \ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
 431 \ alien-signed-4 make-flushable
 432
 433 \ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 434
 435 \ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
 436 \ alien-unsigned-4 make-flushable
 437
 438 \ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
 439
 440 \ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 441 \ alien-signed-2 make-flushable
 442
 443 \ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 444
 445 \ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 446 \ alien-unsigned-2 make-flushable
 447
 448 \ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
 449
 450 \ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 451 \ alien-signed-1 make-flushable
 452
 453 \ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 454
 455 \ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
 456 \ alien-unsigned-1 make-flushable
 457
 458 \ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
 459
 460 \ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
 461 \ alien-float make-flushable
 462
 463 \ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
 464
 465 \ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
 466 \ alien-double make-flushable
 467
 468 \ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
 469
 470 \ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
 471 \ alien-cell make-flushable
 472
 473 \ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
 474
 475 \ alien-address { alien } { integer } <effect> set-primitive-effect
 476 \ alien-address make-flushable
 477
 478 \ slot { object fixnum } { object } <effect> set-primitive-effect
 479 \ slot make-flushable
 480
 481 \ set-slot { object object fixnum } { } <effect> set-primitive-effect
 482
 483 \ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
 484 \ string-nth make-flushable
 485
 486 \ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
 487
 488 \ resize-array { integer array } { array } <effect> set-primitive-effect
 489 \ resize-array make-flushable
 490
 491 \ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
 492 \ resize-byte-array make-flushable
 493
 494 \ resize-string { integer string } { string } <effect> set-primitive-effect
 495 \ resize-string make-flushable
 496
 497 \ <array> { integer object } { array } <effect> set-primitive-effect
 498 \ <array> make-flushable
 499
 500 \ begin-scan { } { } <effect> set-primitive-effect
 501
 502 \ next-object { } { object } <effect> set-primitive-effect
 503
 504 \ end-scan { } { } <effect> set-primitive-effect
 505
 506 \ size { object } { fixnum } <effect> set-primitive-effect
 507 \ size make-flushable
 508
 509 \ die { } { } <effect> set-primitive-effect
 510
 511 \ fopen { string string } { alien } <effect> set-primitive-effect
 512
 513 \ fgetc { alien } { object } <effect> set-primitive-effect
 514
 515 \ fwrite { string alien } { } <effect> set-primitive-effect
 516
 517 \ fputc { object alien } { } <effect> set-primitive-effect
 518
 519 \ fread { integer string } { object } <effect> set-primitive-effect
 520
 521 \ fflush { alien } { } <effect> set-primitive-effect
 522
 523 \ fclose { alien } { } <effect> set-primitive-effect
 524
 525 \ <wrapper> { object } { wrapper } <effect> set-primitive-effect
 526 \ <wrapper> make-foldable
 527
 528 \ (clone) { object } { object } <effect> set-primitive-effect
 529 \ (clone) make-flushable
 530
 531 \ <string> { integer integer } { string } <effect> set-primitive-effect
 532 \ <string> make-flushable
 533
 534 \ array>quotation { array } { quotation } <effect> set-primitive-effect
 535 \ array>quotation make-flushable
 536
 537 \ quotation-xt { quotation } { integer } <effect> set-primitive-effect
 538 \ quotation-xt make-flushable
 539
 540 \ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
 541 \ <tuple> make-flushable
 542
 543 \ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
 544 \ <tuple-layout> make-foldable
 545
 546 \ datastack { } { array } <effect> set-primitive-effect
 547 \ datastack make-flushable
 548
 549 \ retainstack { } { array } <effect> set-primitive-effect
 550 \ retainstack make-flushable
 551
 552 \ callstack { } { callstack } <effect> set-primitive-effect
 553 \ callstack make-flushable
 554
 555 \ callstack>array { callstack } { array } <effect> set-primitive-effect
 556 \ callstack>array make-flushable
 557
 558 \ (sleep) { integer } { } <effect> set-primitive-effect
 559
 560 \ become { array array } { } <effect> set-primitive-effect
 561
 562 \ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
 563
 564 \ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
 565
 566 \ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
 567
 568 \ (os-envs) { } { array } <effect> set-primitive-effect
 569
 570 \ set-os-env { string string } { } <effect> set-primitive-effect
 571
 572 \ unset-os-env { string } { } <effect> set-primitive-effect
 573
 574 \ (set-os-envs) { array } { } <effect> set-primitive-effect
 575
 576 \ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
 577
 578 \ dll-valid? { object } { object } <effect> set-primitive-effect
 579
 580 \ modify-code-heap { array object } { } <effect> set-primitive-effect
 581
 582 \ unimplemented { } { } <effect> set-primitive-effect