1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs classes classes.algebra classes.tuple
4 classes.tuple.private kernel accessors math math.intervals
5 namespaces sequences words combinators
6 arrays compiler.tree.propagation.copy ;
7 IN: compiler.tree.propagation.info
9 : false-class? ( class -- ? ) \ f class<= ;
11 : true-class? ( class -- ? ) \ f class-not class<= ;
13 : null-class? ( class -- ? ) null class<= ;
15 GENERIC: eql? ( obj1 obj2 -- ? )
18 M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
19 M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
20 M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
21 M: complex eql? over complex? [ = ] [ 2drop f ] if ;
23 ! Value info represents a set of objects. Don't mutate value infos
24 ! you receive, always construct new ones. We don't declare the
25 ! slots read-only to allow cloning followed by writing, and to
26 ! simplify constructors.
35 CONSTANT: null-info T{ value-info f null empty-interval }
37 CONSTANT: object-info T{ value-info f object full-interval }
39 : class-interval ( class -- interval )
41 [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
43 : interval>literal ( class interval -- literal literal? )
44 #! If interval has zero length and the class is sufficiently
45 #! precise, we can turn it into a literal
46 dup special-interval? [
50 { [ over interval-length 0 > ] [ 3drop f f ] }
51 { [ pick bignum class<= ] [ 2nip >bignum t ] }
52 { [ pick integer class<= ] [ 2nip >fixnum t ] }
53 { [ pick float class<= ] [
54 2nip dup zero? [ drop f f ] [ >float t ] if
60 : <value-info> ( -- info ) \ value-info new ;
64 : tuple-slot-infos ( tuple -- slots )
65 [ tuple-slots ] [ class all-slots ] bi
66 [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
69 : init-literal-info ( info -- info )
70 dup literal>> class >>class
71 dup literal>> dup real? [ [a,a] >>interval ] [
72 [ [-inf,inf] >>interval ] dip
73 dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
76 : init-value-info ( info -- info )
80 dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
82 empty-interval >>interval
84 [ [-inf,inf] or ] change-interval
85 dup class>> integer class<= [ [ integral-closure ] change-interval ] when
86 dup [ class>> ] [ interval>> ] bi interval>literal
87 [ >>literal ] [ >>literal? ] bi*
91 : <class/interval-info> ( class interval -- info )
95 init-value-info ; foldable
97 : <class-info> ( class -- info )
98 dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
99 <class/interval-info> ; foldable
101 : <interval-info> ( interval -- info )
105 init-value-info ; foldable
107 : <literal-info> ( literal -- info )
111 init-value-info ; foldable
113 : <sequence-info> ( value -- info )
116 swap value-info >>length
117 init-value-info ; foldable
119 : <tuple-info> ( slots class -- info )
125 : >literal< ( info -- literal literal? )
126 [ literal>> ] [ literal?>> ] bi ;
128 : intersect-literals ( info1 info2 -- literal literal? )
130 { [ dup literal?>> not ] [ drop >literal< ] }
131 { [ over literal?>> not ] [ nip >literal< ] }
132 { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
136 DEFER: value-info-intersect
138 DEFER: (value-info-intersect)
140 : intersect-lengths ( info1 info2 -- length )
142 { [ dup not ] [ drop ] }
143 { [ over not ] [ nip ] }
144 [ value-info-intersect ]
147 : intersect-slot ( info1 info2 -- info )
149 { [ dup not ] [ nip ] }
150 { [ over not ] [ drop ] }
151 [ (value-info-intersect) ]
154 : intersect-slots ( info1 info2 -- slots )
156 { [ dup not ] [ drop ] }
157 { [ over not ] [ nip ] }
159 2dup [ length ] bi@ =
160 [ [ intersect-slot ] 2map ] [ 2drop f ] if
164 : (value-info-intersect) ( info1 info2 -- info )
165 [ <value-info> ] 2dip
167 [ [ class>> ] bi@ class-and >>class ]
168 [ [ interval>> ] bi@ interval-intersect >>interval ]
169 [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
170 [ intersect-lengths >>length ]
171 [ intersect-slots >>slots ]
175 : value-info-intersect ( info1 info2 -- info )
177 { [ dup class>> null-class? ] [ nip ] }
178 { [ over class>> null-class? ] [ drop ] }
179 [ (value-info-intersect) ]
182 : union-literals ( info1 info2 -- literal literal? )
183 2dup [ literal?>> ] both? [
184 [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
187 DEFER: value-info-union
189 DEFER: (value-info-union)
191 : union-lengths ( info1 info2 -- length )
193 { [ dup not ] [ nip ] }
194 { [ over not ] [ drop ] }
198 : union-slot ( info1 info2 -- info )
200 { [ dup not ] [ nip ] }
201 { [ over not ] [ drop ] }
202 [ (value-info-union) ]
205 : union-slots ( info1 info2 -- slots )
207 2dup [ length ] bi@ =
208 [ [ union-slot ] 2map ] [ 2drop f ] if ;
210 : (value-info-union) ( info1 info2 -- info )
211 [ <value-info> ] 2dip
213 [ [ class>> ] bi@ class-or >>class ]
214 [ [ interval>> ] bi@ interval-union >>interval ]
215 [ union-literals [ >>literal ] [ >>literal? ] bi* ]
216 [ union-lengths >>length ]
217 [ union-slots >>slots ]
221 : value-info-union ( info1 info2 -- info )
223 { [ dup class>> null-class? ] [ drop ] }
224 { [ over class>> null-class? ] [ nip ] }
225 [ (value-info-union) ]
228 : value-infos-union ( infos -- info )
230 [ [ ] [ value-info-union ] map-reduce ] if-empty ;
232 : literals<= ( info1 info2 -- ? )
234 { [ dup literal?>> not ] [ 2drop t ] }
235 { [ over literal?>> not ] [ drop class>> null-class? ] }
236 [ [ literal>> ] bi@ eql? ]
239 : value-info<= ( info1 info2 -- ? )
241 { [ dup not ] [ 2drop t ] }
242 { [ over not ] [ 2drop f ] }
245 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
246 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
247 { [ 2dup literals<= not ] [ f ] }
248 { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
249 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
255 ! Assoc stack of current value --> info mapping
258 : value-info ( value -- info )
259 resolve-copy value-infos get assoc-stack null-info or ;
261 : set-value-info ( info value -- )
262 resolve-copy value-infos get peek set-at ;
264 : refine-value-info ( info value -- )
265 resolve-copy value-infos get
266 [ assoc-stack value-info-intersect ] 2keep
269 : value-literal ( value -- obj ? )
270 value-info >literal< ;
272 : possible-boolean-values ( info -- values )
277 { [ dup null-class? ] [ { } ] }
278 { [ dup true-class? ] [ { t } ] }
279 { [ dup false-class? ] [ { f } ] }
284 : node-value-info ( node value -- info )
285 swap info>> at* [ drop null-info ] unless ;
287 : node-input-infos ( node -- seq )
288 dup in-d>> [ node-value-info ] with map ;
290 : node-output-infos ( node -- seq )
291 dup out-d>> [ node-value-info ] with map ;
293 : first-literal ( #call -- obj )
294 dup in-d>> first node-value-info literal>> ;
296 : last-literal ( #call -- obj )
297 dup out-d>> peek node-value-info literal>> ;
299 : immutable-tuple-boa? ( #call -- ? )
300 dup word>> \ <tuple-boa> eq? [
301 dup in-d>> peek node-value-info
302 literal>> first immutable-tuple-class?