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 locals.backend locals.private words.private
14 quotations.private stack-checker.values
20 stack-checker.branches
21 stack-checker.transforms
22 stack-checker.recursive-state ;
23 IN: stack-checker.known-words
25 : infer-primitive ( word -- )
27 [ "input-classes" word-prop ]
28 [ "default-output-classes" word-prop ] bi <effect>
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
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
56 : infer-shuffle-word ( word -- )
57 "shuffle" word-prop infer-shuffle ;
59 : infer-declare ( -- )
61 [ length ensure-d ] keep zip
64 GENERIC: infer-call* ( value known -- )
66 : infer-call ( value -- ) dup known infer-call* ;
68 M: literal infer-call*
69 [ 1array #drop, ] [ infer-literal-quot ] bi* ;
71 M: curried infer-call*
73 [ uncurry ] infer-quot-here
74 [ quot>> known pop-d [ set-known ] keep ]
75 [ obj>> known pop-d [ set-known ] keep ] bi
78 M: composed infer-call*
80 [ uncompose ] infer-quot-here
81 [ quot2>> known pop-d [ set-known ] keep ]
82 [ quot1>> known pop-d [ set-known ] keep ] bi
84 1 infer->r pop-d infer-call
85 terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
88 \ literal-expected inference-warning ;
91 1 infer->r pop-d infer-call 1 infer-r> ;
94 2 infer->r pop-d infer-call 2 infer-r> ;
97 3 infer->r pop-d infer-call 3 infer-r> ;
101 dup first2 <curried> make-known
102 [ push-d ] [ 1array ] bi
105 : infer-compose ( -- )
107 dup first2 <composed> make-known
108 [ push-d ] [ 1array ] bi
111 : infer-execute ( -- )
117 "execute must be given a word" time-bomb
120 : infer-<tuple-boa> ( -- )
122 peek-d literal value>> second 1+ { tuple } <effect>
125 : infer-(throw) ( -- )
127 peek-d literal value>> 2 + f <effect> t >>terminated?
132 { integer } { } t >>terminated? <effect>
135 : infer-load-locals ( -- )
137 consume-d dup reverse copy-values dup output-r
138 [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
140 : infer-get-local ( -- )
141 [let* | n [ pop-literal nip ]
143 out-d [ in-r first copy-value 1array ]
144 out-r [ in-r copy-values ] |
148 out-r in-r zip out-d first in-r first 2array suffix
152 : infer-drop-locals ( -- )
153 f f pop-literal nip consume-r f f #shuffle, ;
155 : infer-special ( word -- )
157 { \ >r [ 1 infer->r ] }
158 { \ r> [ 1 infer-r> ] }
159 { \ declare [ infer-declare ] }
160 { \ call [ pop-d infer-call ] }
161 { \ (call) [ pop-d infer-call ] }
162 { \ slip [ infer-slip ] }
163 { \ 2slip [ infer-2slip ] }
164 { \ 3slip [ infer-3slip ] }
165 { \ curry [ infer-curry ] }
166 { \ compose [ infer-compose ] }
167 { \ execute [ infer-execute ] }
168 { \ (execute) [ infer-execute ] }
169 { \ if [ infer-if ] }
170 { \ dispatch [ infer-dispatch ] }
171 { \ <tuple-boa> [ infer-<tuple-boa> ] }
172 { \ (throw) [ infer-(throw) ] }
173 { \ exit [ infer-exit ] }
174 { \ load-locals [ infer-load-locals ] }
175 { \ get-local [ infer-get-local ] }
176 { \ drop-locals [ infer-drop-locals ] }
177 { \ do-primitive [ unknown-primitive-error inference-warning ] }
178 { \ alien-invoke [ infer-alien-invoke ] }
179 { \ alien-indirect [ infer-alien-indirect ] }
180 { \ alien-callback [ infer-alien-callback ] }
183 : infer-local-reader ( word -- )
184 (( -- value )) apply-word/effect ;
186 : infer-local-writer ( word -- )
187 (( value -- )) apply-word/effect ;
190 >r r> declare call (call) slip 2slip 3slip curry compose
191 execute (execute) if dispatch <tuple-boa> (throw)
192 load-locals get-local drop-locals do-primitive alien-invoke
193 alien-indirect alien-callback
194 } [ t "special" set-word-prop ] each
196 { call execute dispatch load-locals get-local drop-locals }
197 [ t "no-compile" set-word-prop ] each
199 : non-inline-word ( word -- )
200 dup called-dependency depends-on
202 { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
203 { [ dup "special" word-prop ] [ infer-special ] }
204 { [ dup "primitive" word-prop ] [ infer-primitive ] }
205 { [ dup "transform-quot" word-prop ] [ apply-transform ] }
206 { [ dup "macro" word-prop ] [ apply-macro ] }
207 { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
208 { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
209 { [ dup local? ] [ infer-local-reader ] }
210 { [ dup local-reader? ] [ infer-local-reader ] }
211 { [ dup local-writer? ] [ infer-local-writer ] }
212 { [ dup recursive-word? ] [ call-recursive-word ] }
213 [ dup infer-word apply-word/effect ]
216 : define-primitive ( word inputs outputs -- )
217 [ 2drop t "primitive" set-word-prop ]
218 [ drop "input-classes" set-word-prop ]
219 [ nip "default-output-classes" set-word-prop ]
222 ! Stack effects for all primitives
223 \ fixnum< { fixnum fixnum } { object } define-primitive
224 \ fixnum< make-foldable
226 \ fixnum<= { fixnum fixnum } { object } define-primitive
227 \ fixnum<= make-foldable
229 \ fixnum> { fixnum fixnum } { object } define-primitive
230 \ fixnum> make-foldable
232 \ fixnum>= { fixnum fixnum } { object } define-primitive
233 \ fixnum>= make-foldable
235 \ eq? { object object } { object } define-primitive
238 \ bignum>fixnum { bignum } { fixnum } define-primitive
239 \ bignum>fixnum make-foldable
241 \ float>fixnum { float } { fixnum } define-primitive
242 \ bignum>fixnum make-foldable
244 \ fixnum>bignum { fixnum } { bignum } define-primitive
245 \ fixnum>bignum make-foldable
247 \ float>bignum { float } { bignum } define-primitive
248 \ float>bignum make-foldable
250 \ fixnum>float { fixnum } { float } define-primitive
251 \ fixnum>float make-foldable
253 \ bignum>float { bignum } { float } define-primitive
254 \ bignum>float make-foldable
256 \ <ratio> { integer integer } { ratio } define-primitive
257 \ <ratio> make-foldable
259 \ string>float { string } { float } define-primitive
260 \ string>float make-foldable
262 \ float>string { float } { string } define-primitive
263 \ float>string make-foldable
265 \ float>bits { real } { integer } define-primitive
266 \ float>bits make-foldable
268 \ double>bits { real } { integer } define-primitive
269 \ double>bits make-foldable
271 \ bits>float { integer } { float } define-primitive
272 \ bits>float make-foldable
274 \ bits>double { integer } { float } define-primitive
275 \ bits>double make-foldable
277 \ <complex> { real real } { complex } define-primitive
278 \ <complex> make-foldable
280 \ fixnum+ { fixnum fixnum } { integer } define-primitive
281 \ fixnum+ make-foldable
283 \ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
284 \ fixnum+fast make-foldable
286 \ fixnum- { fixnum fixnum } { integer } define-primitive
287 \ fixnum- make-foldable
289 \ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
290 \ fixnum-fast make-foldable
292 \ fixnum* { fixnum fixnum } { integer } define-primitive
293 \ fixnum* make-foldable
295 \ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
296 \ fixnum*fast make-foldable
298 \ fixnum/i { fixnum fixnum } { integer } define-primitive
299 \ fixnum/i make-foldable
301 \ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
302 \ fixnum-mod make-foldable
304 \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
305 \ fixnum/mod make-foldable
307 \ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
308 \ fixnum-bitand make-foldable
310 \ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
311 \ fixnum-bitor make-foldable
313 \ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
314 \ fixnum-bitxor make-foldable
316 \ fixnum-bitnot { fixnum } { fixnum } define-primitive
317 \ fixnum-bitnot make-foldable
319 \ fixnum-shift { fixnum fixnum } { integer } define-primitive
320 \ fixnum-shift make-foldable
322 \ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
323 \ fixnum-shift-fast make-foldable
325 \ bignum= { bignum bignum } { object } define-primitive
326 \ bignum= make-foldable
328 \ bignum+ { bignum bignum } { bignum } define-primitive
329 \ bignum+ make-foldable
331 \ bignum- { bignum bignum } { bignum } define-primitive
332 \ bignum- make-foldable
334 \ bignum* { bignum bignum } { bignum } define-primitive
335 \ bignum* make-foldable
337 \ bignum/i { bignum bignum } { bignum } define-primitive
338 \ bignum/i make-foldable
340 \ bignum-mod { bignum bignum } { bignum } define-primitive
341 \ bignum-mod make-foldable
343 \ bignum/mod { bignum bignum } { bignum bignum } define-primitive
344 \ bignum/mod make-foldable
346 \ bignum-bitand { bignum bignum } { bignum } define-primitive
347 \ bignum-bitand make-foldable
349 \ bignum-bitor { bignum bignum } { bignum } define-primitive
350 \ bignum-bitor make-foldable
352 \ bignum-bitxor { bignum bignum } { bignum } define-primitive
353 \ bignum-bitxor make-foldable
355 \ bignum-bitnot { bignum } { bignum } define-primitive
356 \ bignum-bitnot make-foldable
358 \ bignum-shift { bignum fixnum } { bignum } define-primitive
359 \ bignum-shift make-foldable
361 \ bignum< { bignum bignum } { object } define-primitive
362 \ bignum< make-foldable
364 \ bignum<= { bignum bignum } { object } define-primitive
365 \ bignum<= make-foldable
367 \ bignum> { bignum bignum } { object } define-primitive
368 \ bignum> make-foldable
370 \ bignum>= { bignum bignum } { object } define-primitive
371 \ bignum>= make-foldable
373 \ bignum-bit? { bignum integer } { object } define-primitive
374 \ bignum-bit? make-foldable
376 \ bignum-log2 { bignum } { bignum } define-primitive
377 \ bignum-log2 make-foldable
379 \ byte-array>bignum { byte-array } { bignum } define-primitive
380 \ byte-array>bignum make-foldable
382 \ float= { float float } { object } define-primitive
383 \ float= make-foldable
385 \ float+ { float float } { float } define-primitive
386 \ float+ make-foldable
388 \ float- { float float } { float } define-primitive
389 \ float- make-foldable
391 \ float* { float float } { float } define-primitive
392 \ float* make-foldable
394 \ float/f { float float } { float } define-primitive
395 \ float/f make-foldable
397 \ float< { float float } { object } define-primitive
398 \ float< make-foldable
400 \ float-mod { float float } { float } define-primitive
401 \ float-mod make-foldable
403 \ float<= { float float } { object } define-primitive
404 \ float<= make-foldable
406 \ float> { float float } { object } define-primitive
407 \ float> make-foldable
409 \ float>= { float float } { object } define-primitive
410 \ float>= make-foldable
412 \ <word> { object object } { word } define-primitive
413 \ <word> make-flushable
415 \ word-xt { word } { integer integer } define-primitive
416 \ word-xt make-flushable
418 \ getenv { fixnum } { object } define-primitive
419 \ getenv make-flushable
421 \ setenv { object fixnum } { } define-primitive
423 \ (exists?) { string } { object } define-primitive
425 \ gc { } { } define-primitive
427 \ gc-stats { } { array } define-primitive
429 \ save-image { string } { } define-primitive
431 \ save-image-and-exit { string } { } define-primitive
433 \ data-room { } { integer integer array } define-primitive
434 \ data-room make-flushable
436 \ code-room { } { integer integer integer integer } define-primitive
437 \ code-room make-flushable
439 \ micros { } { integer } define-primitive
440 \ micros make-flushable
442 \ tag { object } { fixnum } define-primitive
445 \ dlopen { string } { dll } define-primitive
447 \ dlsym { string object } { c-ptr } define-primitive
449 \ dlclose { dll } { } define-primitive
451 \ <byte-array> { integer } { byte-array } define-primitive
452 \ <byte-array> make-flushable
454 \ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
455 \ <displaced-alien> make-flushable
457 \ alien-signed-cell { c-ptr integer } { integer } define-primitive
458 \ alien-signed-cell make-flushable
460 \ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
462 \ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
463 \ alien-unsigned-cell make-flushable
465 \ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
467 \ alien-signed-8 { c-ptr integer } { integer } define-primitive
468 \ alien-signed-8 make-flushable
470 \ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
472 \ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
473 \ alien-unsigned-8 make-flushable
475 \ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
477 \ alien-signed-4 { c-ptr integer } { integer } define-primitive
478 \ alien-signed-4 make-flushable
480 \ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
482 \ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
483 \ alien-unsigned-4 make-flushable
485 \ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
487 \ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
488 \ alien-signed-2 make-flushable
490 \ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
492 \ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
493 \ alien-unsigned-2 make-flushable
495 \ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
497 \ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
498 \ alien-signed-1 make-flushable
500 \ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
502 \ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
503 \ alien-unsigned-1 make-flushable
505 \ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
507 \ alien-float { c-ptr integer } { float } define-primitive
508 \ alien-float make-flushable
510 \ set-alien-float { float c-ptr integer } { } define-primitive
512 \ alien-double { c-ptr integer } { float } define-primitive
513 \ alien-double make-flushable
515 \ set-alien-double { float c-ptr integer } { } define-primitive
517 \ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
518 \ alien-cell make-flushable
520 \ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
522 \ alien-address { alien } { integer } define-primitive
523 \ alien-address make-flushable
525 \ slot { object fixnum } { object } define-primitive
526 \ slot make-flushable
528 \ set-slot { object object fixnum } { } define-primitive
530 \ string-nth { fixnum string } { fixnum } define-primitive
531 \ string-nth make-flushable
533 \ set-string-nth { fixnum fixnum string } { } define-primitive
535 \ resize-array { integer array } { array } define-primitive
536 \ resize-array make-flushable
538 \ resize-byte-array { integer byte-array } { byte-array } define-primitive
539 \ resize-byte-array make-flushable
541 \ resize-string { integer string } { string } define-primitive
542 \ resize-string make-flushable
544 \ <array> { integer object } { array } define-primitive
545 \ <array> make-flushable
547 \ begin-scan { } { } define-primitive
549 \ next-object { } { object } define-primitive
551 \ end-scan { } { } define-primitive
553 \ size { object } { fixnum } define-primitive
554 \ size make-flushable
556 \ die { } { } define-primitive
558 \ fopen { string string } { alien } define-primitive
560 \ fgetc { alien } { object } define-primitive
562 \ fwrite { string alien } { } define-primitive
564 \ fputc { object alien } { } define-primitive
566 \ fread { integer string } { object } define-primitive
568 \ fflush { alien } { } define-primitive
570 \ fclose { alien } { } define-primitive
572 \ <wrapper> { object } { wrapper } define-primitive
573 \ <wrapper> make-foldable
575 \ (clone) { object } { object } define-primitive
576 \ (clone) make-flushable
578 \ <string> { integer integer } { string } define-primitive
579 \ <string> make-flushable
581 \ array>quotation { array } { quotation } define-primitive
582 \ array>quotation make-flushable
584 \ quotation-xt { quotation } { integer } define-primitive
585 \ quotation-xt make-flushable
587 \ <tuple> { tuple-layout } { tuple } define-primitive
588 \ <tuple> make-flushable
590 \ datastack { } { array } define-primitive
591 \ datastack make-flushable
593 \ retainstack { } { array } define-primitive
594 \ retainstack make-flushable
596 \ callstack { } { callstack } define-primitive
597 \ callstack make-flushable
599 \ callstack>array { callstack } { array } define-primitive
600 \ callstack>array make-flushable
602 \ (sleep) { integer } { } define-primitive
604 \ become { array array } { } define-primitive
606 \ innermost-frame-quot { callstack } { quotation } define-primitive
608 \ innermost-frame-scan { callstack } { fixnum } define-primitive
610 \ set-innermost-frame-quot { quotation callstack } { } define-primitive
612 \ dll-valid? { object } { object } define-primitive
614 \ modify-code-heap { array object } { } define-primitive
616 \ unimplemented { } { } define-primitive