1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: inference.dataflow inference.state arrays generic io
4 io.streams.string kernel math namespaces parser prettyprint
5 sequences strings vectors words quotations effects classes
6 continuations debugger assocs combinators compiler.errors
7 generic.standard.engines.tuple accessors math.order definitions
11 : recursive-label ( word -- label/f )
12 recursive-state get at ;
14 GENERIC: inline? ( word -- ? )
16 M: method-body inline?
17 "method-generic" word-prop inline? ;
19 M: engine-word inline?
20 "tuple-dispatch-generic" word-prop inline? ;
27 : reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
29 : (redefined) ( word -- )
30 dup visited get key? [ drop ] [
31 [ reset-on-redefine reset-props ]
32 [ visited get conjoin ]
37 [ reset-on-redefine [ word-prop ] with contains? ]
45 M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
47 : local-recursive-state ( -- assoc )
48 recursive-state get dup keys
49 [ dup word? [ inline? ] when not ] find drop
50 [ head-slice ] when* ;
52 : inline-recursive-label ( word -- label/f )
53 local-recursive-state at ;
55 : recursive-quotation? ( quot -- ? )
56 local-recursive-state [ first eq? ] with contains? ;
58 TUPLE: inference-error error type rstate ;
60 M: inference-error compiler-error-type type>> ;
62 M: inference-error error-help error>> error-help ;
64 : (inference-error) ( ... class type -- * )
67 \ inference-error boa throw ; inline
69 : inference-error ( ... class -- * )
70 +error+ (inference-error) ; inline
72 : inference-warning ( ... class -- * )
73 +warning+ (inference-error) ; inline
75 TUPLE: literal-expected ;
77 M: object value-literal \ literal-expected inference-warning ;
79 : pop-literal ( -- rstate obj )
81 pop-d dup value-literal >r value-recursion r> ;
83 : value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
85 : add-inputs ( seq stack -- n stack )
86 tuck [ length ] bi@ - dup 0 >
87 [ dup value-vector [ swapd push-all ] keep ]
90 : ensure-values ( seq -- )
91 meta-d [ add-inputs ] change d-in [ + ] change ;
93 : current-effect ( -- effect )
95 meta-d get length <effect>
96 terminated? get >>terminated? ;
98 : init-inference ( -- )
100 V{ } clone meta-d set
101 V{ } clone meta-r set
106 GENERIC: apply-object ( obj -- )
108 : apply-literal ( obj -- )
109 <value> push-d #push 1 0 pick node-outputs node, ;
111 M: object apply-object apply-literal ;
113 M: wrapper apply-object
114 wrapped>> dup +called+ depends-on apply-literal ;
117 terminated? on #terminate node, ;
119 : infer-quot ( quot rstate -- )
120 recursive-state get [
122 [ apply-object terminated? get not ] all? drop
123 ] dip recursive-state set ;
125 : infer-quot-recursive ( quot word label -- )
126 2array recursive-state get swap prefix infer-quot ;
128 : time-bomb ( error -- )
129 [ throw ] curry recursive-state get infer-quot ;
132 "call must be given a callable" time-bomb ;
134 TUPLE: recursive-quotation-error quot ;
136 : infer-quot-value ( value -- )
137 dup recursive-quotation? [
138 value-literal recursive-quotation-error inference-error
140 dup value-literal callable? [
142 [ [ value-recursion ] keep f 2array prefix ]
152 meta-r get empty? terminated? get or
153 [ \ too-many->r inference-error ] unless ;
159 [ \ too-many-r> inference-error ] when ;
164 over 0 pick node-inputs
165 over [ pop-d ] replicate reverse [ push-r ] each
166 0 pick pick node-outputs
173 0 pick pick node-inputs
174 over [ pop-r ] replicate reverse [ push-d ] each
175 over 0 pick node-outputs
180 recorded get [ f "inferred-effect" set-word-prop ] each ;
182 : (consume-values) ( n -- )
183 meta-d get [ length swap - ] keep set-length ;
185 : consume-values ( seq node -- )
188 over 0 rot node-inputs
191 : produce-values ( seq node -- )
192 >r value-vector dup r> set-node-out-d
193 meta-d get push-all ;
195 : if-inline ( word true false -- )
196 [ dup inline? ] 2dip if ; inline
198 : consume/produce ( effect node -- )
199 [ [ in>> ] dip consume-values ]
200 [ [ out>> ] dip produce-values ]
201 [ node, terminated?>> [ terminate ] when ]
204 GENERIC: constructor ( value -- word/f )
206 GENERIC: infer-uncurry ( value -- )
208 M: curried infer-uncurry
209 drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
211 M: curried constructor
214 M: composed infer-uncurry
215 drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
217 M: composed constructor
220 M: object infer-uncurry drop ;
222 M: object constructor drop f ;
224 : reify-curry ( value -- )
231 (( obj quot -- curry )) swap #call consume/produce
234 : reify-curries ( n -- )
244 meta-d get length reify-curries ;
251 : unify-lengths ( seq -- newseq )
253 dup [ length ] map supremum
254 [ swap add-inputs nip ] curry map
259 : unify-curries ( seq -- value )
260 [ [ obj>> ] map unify-values ]
261 [ [ quot>> ] map unify-values ] bi
264 : unify-composed ( seq -- value )
265 [ [ quot1>> ] map unify-values ]
266 [ [ quot2>> ] map unify-values ] bi
269 TUPLE: cannot-unify-specials ;
271 : cannot-unify-specials ( -- * )
272 \ cannot-unify-specials inference-warning ;
274 : unify-values ( seq -- value )
276 { [ dup all-eq? ] [ first ] }
277 { [ dup [ curried? ] all? ] [ unify-curries ] }
278 { [ dup [ composed? ] all? ] [ unify-composed ] }
279 { [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
283 : unify-stacks ( seq -- stack )
284 flip [ unify-values ] V{ } map-as ;
286 : balanced? ( in out -- ? )
287 [ dup [ length - ] [ 2drop f ] if ] 2map
290 TUPLE: unbalanced-branches-error quots in out ;
292 : unbalanced-branches-error ( quots in out -- * )
293 \ unbalanced-branches-error inference-error ;
295 : unify-inputs ( max-d-in d-in meta-d -- meta-d )
297 [ [ - ] dip length + ] keep add-inputs nip
302 : unify-effect ( quots in out -- newin newout )
303 #! in is a sequence of integers, out is a sequence of
307 [ >r dupd r> unify-inputs ] 2map
311 unbalanced-branches-error
314 : active-variable ( seq symbol -- seq )
316 swap terminated? over at [ 2drop f ] [ at ] if
319 : branch-variable ( seq symbol -- seq )
320 [ swap at ] curry map ;
322 : datastack-effect ( seq -- )
323 [ quotation branch-variable ]
324 [ d-in branch-variable ]
325 [ meta-d active-variable ] tri
327 [ d-in set ] [ meta-d set ] bi* ;
329 : retainstack-effect ( seq -- )
330 [ quotation branch-variable ]
331 [ length 0 <repetition> ]
332 [ meta-r active-variable ] tri
334 [ drop ] [ meta-r set ] bi* ;
336 : unify-effects ( seq -- )
338 [ retainstack-effect ]
339 [ [ terminated? swap at ] all? terminated? set ]
342 : unify-dataflow ( effects -- nodes )
343 dataflow-graph branch-variable ;
345 : copy-inference ( -- )
346 meta-d [ clone ] change
347 meta-r [ clone ] change
352 : infer-branch ( last value -- namespace )
356 [ value-literal quotation set ]
360 terminated? get [ drop ] [ call node, ] if
361 ] H{ } make-assoc ; inline
363 : (infer-branches) ( last branches -- list )
364 [ infer-branch ] with map
365 [ unify-effects ] [ unify-dataflow ] bi ; inline
367 : infer-branches ( last branches node -- )
368 #! last -> #return or #values
369 #! node -> #if or #dispatch
373 >r (infer-branches) r> set-node-children
374 #merge node, ; inline
376 : make-call-node ( word effect -- )
378 over dup recursive-label eq? not and [
379 meta-d get clone -rot
380 recursive-label #call-label [ consume/produce ] keep
383 over effect-in length reify-curries
384 #call consume/produce
387 TUPLE: cannot-infer-effect word ;
389 : cannot-infer-effect ( word -- * )
390 \ cannot-infer-effect inference-warning ;
392 TUPLE: effect-error word inferred declared ;
394 : effect-error ( word inferred declared -- * )
395 \ effect-error inference-error ;
397 TUPLE: missing-effect word ;
399 : effect-required? ( word -- ? )
401 { [ dup inline? ] [ drop f ] }
402 { [ dup deferred? ] [ drop f ] }
403 { [ dup crossref? not ] [ drop f ] }
404 [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
407 : ?missing-effect ( word -- )
409 [ missing-effect inference-error ] [ drop ] if ;
411 : check-effect ( word effect -- )
413 { [ dup not ] [ 2drop ?missing-effect ] }
414 { [ 2dup effect<= ] [ 3drop ] }
418 : finish-word ( word -- )
421 [ drop recorded get push ]
422 [ "inferred-effect" set-word-prop ]
425 : maybe-cannot-infer ( word quot -- )
426 [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
428 : infer-word ( word -- effect )
433 dup def>> over dup infer-quot-recursive
438 ] maybe-cannot-infer ;
440 : custom-infer ( word -- )
441 #! Customized inference behavior
442 [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
444 : cached-infer ( word -- )
445 dup "inferred-effect" word-prop make-call-node ;
447 : apply-word ( word -- )
449 { [ dup "infer" word-prop ] [ custom-infer ] }
450 { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
451 { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
452 [ dup infer-word make-call-node ]
455 : declared-infer ( word -- )
459 \ missing-effect inference-error
462 GENERIC: collect-label-info* ( label node -- )
464 M: node collect-label-info* 2drop ;
466 : (collect-label-info) ( label node vector -- )
467 >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
470 M: #call-label collect-label-info*
471 over calls>> (collect-label-info) ;
473 M: #return collect-label-info*
474 over returns>> (collect-label-info) ;
476 : collect-label-info ( #label -- )
479 dup [ collect-label-info* ] with each-node ;
481 : nest-node ( -- ) #entry node, ;
483 : unnest-node ( new-node -- new-node )
484 dup node-param #return node,
485 dataflow-graph get 1array over set-node-children ;
487 : inlined-block? ( word -- ? )
488 "inlined-block" word-prop ;
490 : <inlined-block> ( -- word )
491 gensym dup t "inlined-block" set-word-prop ;
493 : inline-block ( word -- #label data )
495 copy-inference nest-node
496 [ def>> ] [ <inlined-block> ] bi
497 [ infer-quot-recursive ] 2keep
499 dup collect-label-info
502 : join-values ( #label -- )
503 calls>> [ in-d>> ] map meta-d get suffix
504 unify-lengths unify-stacks
505 meta-d [ length tail* ] change ;
507 : splice-node ( node -- )
509 [ node, ] [ penultimate-node ] bi
514 : apply-infer ( data -- )
515 { meta-d meta-r d-in terminated? } swap extract-keys
516 namespace swap update ;
518 : current-stack-height ( -- n )
519 d-in get meta-d get length - ;
521 : word-stack-height ( word -- n )
522 stack-effect effect-height ;
524 : bad-recursive-declaration ( word inferred -- )
525 dup 0 < [ 0 swap ] [ 0 ] if <effect>
529 : check-stack-height ( word height -- )
530 over word-stack-height over =
531 [ 2drop ] [ bad-recursive-declaration ] if ;
533 : inline-recursive-word ( word #label -- )
534 current-stack-height [
535 flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
537 [ calls>> [ [ flatten-curries ] modify-values ] each ]
541 current-stack-height -
544 : inline-word ( word -- )
545 dup inline-block over recursive-label?
546 [ drop inline-recursive-word ]
547 [ apply-infer node-child successor>> splice-node drop ] if ;
551 dup +inlined+ depends-on
552 dup inline-recursive-label
553 [ declared-infer ] [ inline-word ] if
555 dup +called+ depends-on
557 [ declared-infer ] [ apply-word ] if
560 : with-infer ( quot -- effect dataflow )
563 V{ } clone recorded set
569 ] [ ] [ undo-infer ] cleanup