1 ! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry accessors alien alien.accessors arrays byte-arrays classes
4 continuations.private effects generic hashtables
5 hashtables.private io io.backend io.files io.files.private
6 io.streams.c kernel kernel.private math math.private
7 math.parser.private memory memory.private namespaces
8 namespaces.private parser quotations quotations.private sbufs
9 sbufs.private sequences sequences.private slots.private strings
10 strings.private system threads.private classes.tuple
11 classes.tuple.private vectors vectors.private words definitions assocs
12 summary compiler.units system.private combinators
13 combinators.short-circuit locals locals.backend locals.types
14 combinators.private stack-checker.values
15 generic.single generic.single.private
22 stack-checker.branches
23 stack-checker.transforms
24 stack-checker.recursive-state ;
25 IN: stack-checker.known-words
27 : infer-primitive ( word -- )
29 [ "input-classes" word-prop ]
30 [ "default-output-classes" word-prop ] bi <effect>
35 { 2drop (( x y -- )) }
36 { 3drop (( x y z -- )) }
37 { dup (( x -- x x )) }
38 { 2dup (( x y -- x y x y )) }
39 { 3dup (( x y z -- x y z x y z )) }
40 { rot (( x y z -- y z x )) }
41 { -rot (( x y z -- z x y )) }
42 { dupd (( x y -- x x y )) }
43 { swapd (( x y z -- y x z )) }
44 { nip (( x y -- y )) }
45 { 2nip (( x y z -- z )) }
46 { tuck (( x y -- y x y )) }
47 { over (( x y -- x y x )) }
48 { pick (( x y z -- x y z x )) }
49 { swap (( x y -- y x )) }
50 } [ "shuffle" set-word-prop ] assoc-each
52 : infer-shuffle ( shuffle -- )
53 [ in>> length consume-d ] keep ! inputs shuffle
54 [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
55 [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
58 : infer-shuffle-word ( word -- )
59 "shuffle" word-prop infer-shuffle ;
61 : check-declaration ( declaration -- declaration )
62 dup { [ array? ] [ [ class? ] all? ] } 1&&
63 [ bad-declaration-error ] unless ;
65 : infer-declare ( -- )
66 pop-literal nip check-declaration
67 [ length ensure-d ] keep zip
70 \ declare [ infer-declare ] "special" set-word-prop
72 GENERIC: infer-call* ( value known -- )
74 : (infer-call) ( value -- ) dup known infer-call* ;
76 : infer-call ( -- ) pop-d (infer-call) ;
78 \ call [ infer-call ] "special" set-word-prop
80 \ (call) [ infer-call ] "special" set-word-prop
82 M: literal infer-call*
83 [ 1array #drop, ] [ infer-literal-quot ] bi* ;
85 M: curried infer-call*
87 [ uncurry ] infer-quot-here
88 [ quot>> known pop-d [ set-known ] keep ]
89 [ obj>> known pop-d [ set-known ] keep ] bi
92 M: composed infer-call*
94 [ uncompose ] infer-quot-here
95 [ quot2>> known pop-d [ set-known ] keep ]
96 [ quot1>> known pop-d [ set-known ] keep ] bi
99 terminated? get [ 1 infer-r> infer-call ] unless ;
101 M: object infer-call*
102 "literal quotation" literal-expected ;
104 : infer-ndip ( word n -- )
105 [ literals get ] 2dip
106 [ '[ _ def>> infer-quot-here ] ]
107 [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi*
110 : infer-dip ( -- ) \ dip 1 infer-ndip ;
112 \ dip [ infer-dip ] "special" set-word-prop
114 : infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
116 \ 2dip [ infer-2dip ] "special" set-word-prop
118 : infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
120 \ 3dip [ infer-3dip ] "special" set-word-prop
122 : infer-builder ( quot word -- )
125 [ dup first2 ] dip call make-known
126 [ push-d ] [ 1array ] bi
127 ] dip #call, ; inline
129 : infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
131 \ curry [ infer-curry ] "special" set-word-prop
133 : infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
135 \ compose [ infer-compose ] "special" set-word-prop
137 ERROR: bad-executable obj ;
139 M: bad-executable summary
140 drop "execute must be given a word" ;
142 : infer-execute ( -- )
147 \ bad-executable boa time-bomb
150 \ execute [ infer-execute ] "special" set-word-prop
152 \ (execute) [ infer-execute ] "special" set-word-prop
154 : infer-<tuple-boa> ( -- )
156 peek-d literal value>> second 1 + { tuple } <effect>
159 \ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
161 \ <tuple-boa> t "flushable" set-word-prop
163 : infer-effect-unsafe ( word -- )
168 : infer-execute-effect-unsafe ( -- )
169 \ (execute) infer-effect-unsafe ;
171 \ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
173 : infer-call-effect-unsafe ( -- )
174 \ call infer-effect-unsafe ;
176 \ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
179 \ exit (( n -- * )) apply-word/effect ;
181 \ exit [ infer-exit ] "special" set-word-prop
183 : infer-load-locals ( -- )
185 consume-d dup copy-values dup output-r
186 [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
188 \ load-locals [ infer-load-locals ] "special" set-word-prop
190 : infer-load-local ( -- )
193 \ load-local [ infer-load-local ] "special" set-word-prop
195 : infer-get-local ( -- )
196 [let* | n [ pop-literal nip 1 swap - ]
198 out-d [ in-r first copy-value 1array ]
199 out-r [ in-r copy-values ] |
203 out-r in-r zip out-d first in-r first 2array suffix
207 \ get-local [ infer-get-local ] "special" set-word-prop
209 : infer-drop-locals ( -- )
210 f f pop-literal nip consume-r f f #shuffle, ;
212 \ drop-locals [ infer-drop-locals ] "special" set-word-prop
214 : infer-call-effect ( word -- )
215 1 ensure-d first literal value>>
216 add-effect-input add-effect-input
219 { call-effect execute-effect } [
220 dup t "no-compile" set-word-prop
221 dup '[ _ infer-call-effect ] "special" set-word-prop
224 \ do-primitive [ unknown-primitive-error ] "special" set-word-prop
226 \ if [ infer-if ] "special" set-word-prop
227 \ dispatch [ infer-dispatch ] "special" set-word-prop
229 \ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
230 \ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
231 \ alien-callback [ infer-alien-callback ] "special" set-word-prop
233 : infer-special ( word -- )
234 "special" word-prop call( -- ) ;
236 : infer-local-reader ( word -- )
237 (( -- value )) apply-word/effect ;
239 : infer-local-writer ( word -- )
240 (( value -- )) apply-word/effect ;
242 : infer-local-word ( word -- )
243 "local-word-def" word-prop infer-quot-here ;
246 declare call (call) dip 2dip 3dip curry compose
247 execute (execute) call-effect-unsafe execute-effect-unsafe if
248 dispatch <tuple-boa> exit load-local load-locals get-local
249 drop-locals do-primitive alien-invoke alien-indirect
251 } [ t "no-compile" set-word-prop ] each
253 ! Exceptions to the above
254 \ curry f "no-compile" set-word-prop
255 \ compose f "no-compile" set-word-prop
257 ! More words not to compile
258 \ clear t "no-compile" set-word-prop
260 : non-inline-word ( word -- )
261 dup called-dependency depends-on
263 { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
264 { [ dup "special" word-prop ] [ infer-special ] }
265 { [ dup "primitive" word-prop ] [ infer-primitive ] }
266 { [ dup "transform-quot" word-prop ] [ apply-transform ] }
267 { [ dup "macro" word-prop ] [ apply-macro ] }
268 { [ dup local? ] [ infer-local-reader ] }
269 { [ dup local-reader? ] [ infer-local-reader ] }
270 { [ dup local-writer? ] [ infer-local-writer ] }
271 { [ dup local-word? ] [ infer-local-word ] }
275 : define-primitive ( word inputs outputs -- )
276 [ 2drop t "primitive" set-word-prop ]
277 [ drop "input-classes" set-word-prop ]
278 [ nip "default-output-classes" set-word-prop ]
281 ! Stack effects for all primitives
282 \ fixnum< { fixnum fixnum } { object } define-primitive
283 \ fixnum< make-foldable
285 \ fixnum<= { fixnum fixnum } { object } define-primitive
286 \ fixnum<= make-foldable
288 \ fixnum> { fixnum fixnum } { object } define-primitive
289 \ fixnum> make-foldable
291 \ fixnum>= { fixnum fixnum } { object } define-primitive
292 \ fixnum>= make-foldable
294 \ eq? { object object } { object } define-primitive
297 \ bignum>fixnum { bignum } { fixnum } define-primitive
298 \ bignum>fixnum make-foldable
300 \ float>fixnum { float } { fixnum } define-primitive
301 \ bignum>fixnum make-foldable
303 \ fixnum>bignum { fixnum } { bignum } define-primitive
304 \ fixnum>bignum make-foldable
306 \ float>bignum { float } { bignum } define-primitive
307 \ float>bignum make-foldable
309 \ fixnum>float { fixnum } { float } define-primitive
310 \ fixnum>float make-foldable
312 \ bignum>float { bignum } { float } define-primitive
313 \ bignum>float make-foldable
315 \ (string>float) { byte-array } { float } define-primitive
316 \ (string>float) make-foldable
318 \ (float>string) { float } { byte-array } define-primitive
319 \ (float>string) make-foldable
321 \ float>bits { real } { integer } define-primitive
322 \ float>bits make-foldable
324 \ double>bits { real } { integer } define-primitive
325 \ double>bits make-foldable
327 \ bits>float { integer } { float } define-primitive
328 \ bits>float make-foldable
330 \ bits>double { integer } { float } define-primitive
331 \ bits>double make-foldable
333 \ both-fixnums? { object object } { object } define-primitive
335 \ fixnum+ { fixnum fixnum } { integer } define-primitive
336 \ fixnum+ make-foldable
338 \ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
339 \ fixnum+fast make-foldable
341 \ fixnum- { fixnum fixnum } { integer } define-primitive
342 \ fixnum- make-foldable
344 \ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
345 \ fixnum-fast make-foldable
347 \ fixnum* { fixnum fixnum } { integer } define-primitive
348 \ fixnum* make-foldable
350 \ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
351 \ fixnum*fast make-foldable
353 \ fixnum/i { fixnum fixnum } { integer } define-primitive
354 \ fixnum/i make-foldable
356 \ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive
357 \ fixnum/i-fast make-foldable
359 \ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
360 \ fixnum-mod make-foldable
362 \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
363 \ fixnum/mod make-foldable
365 \ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive
366 \ fixnum/mod-fast make-foldable
368 \ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
369 \ fixnum-bitand make-foldable
371 \ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
372 \ fixnum-bitor make-foldable
374 \ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
375 \ fixnum-bitxor make-foldable
377 \ fixnum-bitnot { fixnum } { fixnum } define-primitive
378 \ fixnum-bitnot make-foldable
380 \ fixnum-shift { fixnum fixnum } { integer } define-primitive
381 \ fixnum-shift make-foldable
383 \ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
384 \ fixnum-shift-fast make-foldable
386 \ bignum= { bignum bignum } { object } define-primitive
387 \ bignum= make-foldable
389 \ bignum+ { bignum bignum } { bignum } define-primitive
390 \ bignum+ make-foldable
392 \ bignum- { bignum bignum } { bignum } define-primitive
393 \ bignum- make-foldable
395 \ bignum* { bignum bignum } { bignum } define-primitive
396 \ bignum* make-foldable
398 \ bignum/i { bignum bignum } { bignum } define-primitive
399 \ bignum/i make-foldable
401 \ bignum-mod { bignum bignum } { bignum } define-primitive
402 \ bignum-mod make-foldable
404 \ bignum/mod { bignum bignum } { bignum bignum } define-primitive
405 \ bignum/mod make-foldable
407 \ bignum-bitand { bignum bignum } { bignum } define-primitive
408 \ bignum-bitand make-foldable
410 \ bignum-bitor { bignum bignum } { bignum } define-primitive
411 \ bignum-bitor make-foldable
413 \ bignum-bitxor { bignum bignum } { bignum } define-primitive
414 \ bignum-bitxor make-foldable
416 \ bignum-bitnot { bignum } { bignum } define-primitive
417 \ bignum-bitnot make-foldable
419 \ bignum-shift { bignum fixnum } { bignum } define-primitive
420 \ bignum-shift make-foldable
422 \ bignum< { bignum bignum } { object } define-primitive
423 \ bignum< make-foldable
425 \ bignum<= { bignum bignum } { object } define-primitive
426 \ bignum<= make-foldable
428 \ bignum> { bignum bignum } { object } define-primitive
429 \ bignum> make-foldable
431 \ bignum>= { bignum bignum } { object } define-primitive
432 \ bignum>= make-foldable
434 \ bignum-bit? { bignum integer } { object } define-primitive
435 \ bignum-bit? make-foldable
437 \ bignum-log2 { bignum } { bignum } define-primitive
438 \ bignum-log2 make-foldable
440 \ byte-array>bignum { byte-array } { bignum } define-primitive
441 \ byte-array>bignum make-foldable
443 \ float= { float float } { object } define-primitive
444 \ float= make-foldable
446 \ float+ { float float } { float } define-primitive
447 \ float+ make-foldable
449 \ float- { float float } { float } define-primitive
450 \ float- make-foldable
452 \ float* { float float } { float } define-primitive
453 \ float* make-foldable
455 \ float/f { float float } { float } define-primitive
456 \ float/f make-foldable
458 \ float< { float float } { object } define-primitive
459 \ float< make-foldable
461 \ float-mod { float float } { float } define-primitive
462 \ float-mod make-foldable
464 \ float<= { float float } { object } define-primitive
465 \ float<= make-foldable
467 \ float> { float float } { object } define-primitive
468 \ float> make-foldable
470 \ float>= { float float } { object } define-primitive
471 \ float>= make-foldable
473 \ <word> { object object } { word } define-primitive
474 \ <word> make-flushable
476 \ word-xt { word } { integer integer } define-primitive
477 \ word-xt make-flushable
479 \ getenv { fixnum } { object } define-primitive
480 \ getenv make-flushable
482 \ setenv { object fixnum } { } define-primitive
484 \ (exists?) { string } { object } define-primitive
486 \ gc { } { } define-primitive
488 \ gc-stats { } { array } define-primitive
490 \ (save-image) { byte-array } { } define-primitive
492 \ (save-image-and-exit) { byte-array } { } define-primitive
494 \ data-room { } { integer integer array } define-primitive
495 \ data-room make-flushable
497 \ code-room { } { integer integer integer integer } define-primitive
498 \ code-room make-flushable
500 \ micros { } { integer } define-primitive
501 \ micros make-flushable
503 \ tag { object } { fixnum } define-primitive
506 \ (dlopen) { byte-array } { dll } define-primitive
508 \ (dlsym) { byte-array object } { c-ptr } define-primitive
510 \ dlclose { dll } { } define-primitive
512 \ <byte-array> { integer } { byte-array } define-primitive
513 \ <byte-array> make-flushable
515 \ (byte-array) { integer } { byte-array } define-primitive
516 \ (byte-array) make-flushable
518 \ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
519 \ <displaced-alien> make-flushable
521 \ alien-signed-cell { c-ptr integer } { integer } define-primitive
522 \ alien-signed-cell make-flushable
524 \ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
526 \ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
527 \ alien-unsigned-cell make-flushable
529 \ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
531 \ alien-signed-8 { c-ptr integer } { integer } define-primitive
532 \ alien-signed-8 make-flushable
534 \ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
536 \ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
537 \ alien-unsigned-8 make-flushable
539 \ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
541 \ alien-signed-4 { c-ptr integer } { integer } define-primitive
542 \ alien-signed-4 make-flushable
544 \ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
546 \ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
547 \ alien-unsigned-4 make-flushable
549 \ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
551 \ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
552 \ alien-signed-2 make-flushable
554 \ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
556 \ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
557 \ alien-unsigned-2 make-flushable
559 \ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
561 \ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
562 \ alien-signed-1 make-flushable
564 \ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
566 \ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
567 \ alien-unsigned-1 make-flushable
569 \ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
571 \ alien-float { c-ptr integer } { float } define-primitive
572 \ alien-float make-flushable
574 \ set-alien-float { float c-ptr integer } { } define-primitive
576 \ alien-double { c-ptr integer } { float } define-primitive
577 \ alien-double make-flushable
579 \ set-alien-double { float c-ptr integer } { } define-primitive
581 \ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
582 \ alien-cell make-flushable
584 \ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
586 \ alien-address { alien } { integer } define-primitive
587 \ alien-address make-flushable
589 \ slot { object fixnum } { object } define-primitive
590 \ slot make-flushable
592 \ set-slot { object object fixnum } { } define-primitive
594 \ string-nth { fixnum string } { fixnum } define-primitive
595 \ string-nth make-flushable
597 \ set-string-nth-slow { fixnum fixnum string } { } define-primitive
598 \ set-string-nth-fast { fixnum fixnum string } { } define-primitive
600 \ resize-array { integer array } { array } define-primitive
601 \ resize-array make-flushable
603 \ resize-byte-array { integer byte-array } { byte-array } define-primitive
604 \ resize-byte-array make-flushable
606 \ resize-string { integer string } { string } define-primitive
607 \ resize-string make-flushable
609 \ <array> { integer object } { array } define-primitive
610 \ <array> make-flushable
612 \ begin-scan { } { } define-primitive
614 \ next-object { } { object } define-primitive
616 \ end-scan { } { } define-primitive
618 \ size { object } { fixnum } define-primitive
619 \ size make-flushable
621 \ die { } { } define-primitive
623 \ (fopen) { byte-array byte-array } { alien } define-primitive
625 \ fgetc { alien } { object } define-primitive
627 \ fwrite { string alien } { } define-primitive
629 \ fputc { object alien } { } define-primitive
631 \ fread { integer string } { object } define-primitive
633 \ fflush { alien } { } define-primitive
635 \ fseek { alien integer integer } { } define-primitive
637 \ fclose { alien } { } define-primitive
639 \ <wrapper> { object } { wrapper } define-primitive
640 \ <wrapper> make-foldable
642 \ (clone) { object } { object } define-primitive
643 \ (clone) make-flushable
645 \ <string> { integer integer } { string } define-primitive
646 \ <string> make-flushable
648 \ array>quotation { array } { quotation } define-primitive
649 \ array>quotation make-flushable
651 \ quotation-xt { quotation } { integer } define-primitive
652 \ quotation-xt make-flushable
654 \ <tuple> { tuple-layout } { tuple } define-primitive
655 \ <tuple> make-flushable
657 \ datastack { } { array } define-primitive
658 \ datastack make-flushable
660 \ check-datastack { array integer integer } { object } define-primitive
661 \ check-datastack make-flushable
663 \ retainstack { } { array } define-primitive
664 \ retainstack make-flushable
666 \ callstack { } { callstack } define-primitive
667 \ callstack make-flushable
669 \ callstack>array { callstack } { array } define-primitive
670 \ callstack>array make-flushable
672 \ (sleep) { integer } { } define-primitive
674 \ become { array array } { } define-primitive
676 \ innermost-frame-executing { callstack } { object } define-primitive
678 \ innermost-frame-scan { callstack } { fixnum } define-primitive
680 \ set-innermost-frame-quot { quotation callstack } { } define-primitive
682 \ dll-valid? { object } { object } define-primitive
684 \ modify-code-heap { array } { } define-primitive
686 \ unimplemented { } { } define-primitive
688 \ gc-reset { } { } define-primitive
690 \ gc-stats { } { array } define-primitive
692 \ jit-compile { quotation } { } define-primitive
694 \ lookup-method { object array } { word } define-primitive
696 \ reset-dispatch-stats { } { } define-primitive
697 \ dispatch-stats { } { array } define-primitive
698 \ reset-inline-cache-stats { } { } define-primitive
699 \ inline-cache-stats { } { array } define-primitive
701 \ optimized? { word } { object } define-primitive