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