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