1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry arrays generic io io.streams.string kernel math
4 namespaces parser prettyprint sequences strings vectors words
5 quotations effects classes continuations debugger assocs
6 combinators compiler.errors accessors math.order definitions
7 sets generic.standard.engines.tuple stack-checker.state
8 stack-checker.visitor stack-checker.errors ;
9 IN: stack-checker.backend
11 : push-d ( obj -- ) meta-d get push ;
15 <value> dup 1array #introduce, d-in inc
18 : peek-d ( -- obj ) pop-d dup push-d ;
20 : consume-d ( n -- seq ) [ pop-d ] replicate reverse ;
22 : output-d ( values -- ) meta-d get push-all ;
24 : ensure-d ( n -- values ) consume-d dup output-d ;
26 : make-values ( n -- values )
27 [ <value> ] replicate ;
29 : produce-d ( n -- values )
30 make-values dup meta-d get push-all ;
32 : push-r ( obj -- ) meta-r get push ;
36 [ too-many-r> inference-error ] [ pop ] if ;
38 : consume-r ( n -- seq ) [ pop-r ] replicate reverse ;
40 : output-r ( seq -- ) meta-r get push-all ;
42 : pop-literal ( -- rstate obj )
45 [ literal [ recursion>> ] [ value>> ] bi ] bi ;
47 GENERIC: apply-object ( obj -- )
49 : push-literal ( obj -- )
50 dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
52 M: wrapper apply-object
54 [ dup word? [ called-dependency depends-on ] [ drop ] if ]
58 M: object apply-object push-literal ;
61 terminated? on meta-d get clone meta-r get clone #terminate, ;
63 : infer-quot ( quot rstate -- )
66 [ apply-object terminated? get not ] all? drop
67 ] dip recursive-state set ;
69 : infer-quot-recursive ( quot word label -- )
70 2array recursive-state get swap prefix infer-quot ;
72 : time-bomb ( error -- )
73 '[ _ throw ] recursive-state get infer-quot ;
76 "call must be given a callable" time-bomb ;
78 : infer-literal-quot ( literal -- )
79 dup recursive-quotation? [
80 value>> recursive-quotation-error inference-error
82 dup value>> callable? [
84 [ [ recursion>> ] keep f 2array prefix ]
92 consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
95 consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
98 recorded get [ f "inferred-effect" set-word-prop ] each ;
100 : consume/produce ( effect quot -- )
101 #! quot is ( inputs outputs -- )
104 [ in>> length consume-d ]
105 [ out>> length produce-d ]
110 terminated?>> [ terminate ] when
114 meta-r get empty? terminated? get or
115 [ \ too-many->r inference-error ] unless ;
119 meta-d get clone #return, ;
121 : effect-required? ( word -- ? )
123 { [ dup inline? ] [ drop f ] }
124 { [ dup deferred? ] [ drop f ] }
125 { [ dup crossref? not ] [ drop f ] }
126 [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
129 : ?missing-effect ( word -- )
131 [ missing-effect inference-error ] [ drop ] if ;
133 : check-effect ( word effect -- )
135 { [ dup not ] [ 2drop ?missing-effect ] }
136 { [ 2dup effect<= ] [ 3drop ] }
140 : finish-word ( word -- )
143 [ drop recorded get push ]
144 [ "inferred-effect" set-word-prop ]
147 : cannot-infer-effect ( word -- * )
148 "cannot-infer" word-prop throw ;
150 : maybe-cannot-infer ( word quot -- )
151 [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
153 : infer-word ( word -- effect )
160 generic-dependencies off
161 [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
162 [ finish-word current-effect ]
165 ] maybe-cannot-infer ;
167 : apply-word/effect ( word effect -- )
168 swap '[ _ #call, ] consume/produce ;
170 : required-stack-effect ( word -- effect )
171 dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
173 : call-recursive-word ( word -- )
174 dup required-stack-effect apply-word/effect ;
176 : cached-infer ( word -- )
177 dup "inferred-effect" word-prop apply-word/effect ;
179 : with-infer ( quot -- effect visitor )
182 V{ } clone recorded set
190 ] [ ] [ undo-infer ] cleanup
191 ] with-scope ; inline