basis/stack-checker/known-words/known-words.factor

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