1 ! Copyright (C) 2008, 2009 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 namespaces
5 sequences sequences.private words combinators memoize
6 combinators.short-circuit byte-arrays strings arrays layouts
7 cpu.architecture compiler.tree.propagation.copy ;
8 IN: compiler.tree.propagation.info
10 : false-class? ( class -- ? ) \ f class<= ;
12 : true-class? ( class -- ? ) \ f class-not class<= ;
14 : null-class? ( class -- ? ) null class<= ;
16 GENERIC: eql? ( obj1 obj2 -- ? )
19 M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
20 M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
21 M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
22 M: complex eql? over complex? [ = ] [ 2drop f ] if ;
24 ! Value info represents a set of objects. Don't mutate value infos
25 ! you receive, always construct new ones. We don't declare the
26 ! slots read-only to allow cloning followed by writing, and to
27 ! simplify constructors.
36 CONSTANT: null-info T{ value-info f null empty-interval }
38 CONSTANT: object-info T{ value-info f object full-interval }
40 : interval>literal ( class interval -- literal literal? )
41 #! If interval has zero length and the class is sufficiently
42 #! precise, we can turn it into a literal
43 dup special-interval? [
47 { [ over interval-length 0 > ] [ 3drop f f ] }
48 { [ pick bignum class<= ] [ 2nip >bignum t ] }
49 { [ pick integer class<= ] [ 2nip >fixnum t ] }
50 { [ pick float class<= ] [
51 2nip dup zero? [ drop f f ] [ >float t ] if
57 : <value-info> ( -- info ) \ value-info new ;
61 : tuple-slot-infos ( tuple -- slots )
62 [ tuple-slots ] [ class all-slots ] bi
63 [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
66 UNION: fixed-length array byte-array string ;
68 : init-literal-info ( info -- info )
69 empty-interval >>interval
70 dup literal>> class >>class
72 { [ dup real? ] [ [a,a] >>interval ] }
73 { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
74 { [ dup fixed-length? ] [ length <literal-info> >>length ] }
78 : empty-set? ( info -- ? )
80 [ class>> null-class? ]
81 [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
84 : min-value ( class -- n )
86 { fixnum [ most-negative-fixnum ] }
87 { array-capacity [ 0 ] }
91 : max-value ( class -- n )
93 { fixnum [ most-positive-fixnum ] }
94 { array-capacity [ max-array-capacity ] }
98 : class-interval ( class -- i )
100 { fixnum [ fixnum-interval ] }
101 { array-capacity [ array-capacity-interval ] }
102 [ drop full-interval ]
105 : wrap-interval ( interval class -- interval' )
107 { [ over empty-interval eq? ] [ drop ] }
108 { [ over full-interval eq? ] [ nip class-interval ] }
109 { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
113 : init-interval ( info -- info )
114 dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
115 dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
117 : init-value-info ( info -- info )
123 empty-interval >>interval
126 dup [ class>> ] [ interval>> ] bi interval>literal
127 [ >>literal ] [ >>literal? ] bi*
131 : <class/interval-info> ( class interval -- info )
135 init-value-info ; foldable
137 : <class-info> ( class -- info )
138 f <class/interval-info> ; foldable
140 : <interval-info> ( interval -- info )
144 init-value-info ; foldable
146 : <literal-info> ( literal -- info )
150 init-value-info ; foldable
152 : <sequence-info> ( value -- info )
155 swap value-info >>length
156 init-value-info ; foldable
158 : <tuple-info> ( slots class -- info )
164 : >literal< ( info -- literal literal? )
165 [ literal>> ] [ literal?>> ] bi ;
167 : intersect-literals ( info1 info2 -- literal literal? )
169 { [ dup literal?>> not ] [ drop >literal< ] }
170 { [ over literal?>> not ] [ nip >literal< ] }
171 { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
175 DEFER: value-info-intersect
177 DEFER: (value-info-intersect)
179 : intersect-lengths ( info1 info2 -- length )
181 { [ dup not ] [ drop ] }
182 { [ over not ] [ nip ] }
183 [ value-info-intersect ]
186 : intersect-slot ( info1 info2 -- info )
188 { [ dup not ] [ nip ] }
189 { [ over not ] [ drop ] }
190 [ (value-info-intersect) ]
193 : intersect-slots ( info1 info2 -- slots )
195 { [ dup not ] [ drop ] }
196 { [ over not ] [ nip ] }
198 2dup [ length ] bi@ =
199 [ [ intersect-slot ] 2map ] [ 2drop f ] if
203 : (value-info-intersect) ( info1 info2 -- info )
204 [ <value-info> ] 2dip
206 [ [ class>> ] bi@ class-and >>class ]
207 [ [ interval>> ] bi@ interval-intersect >>interval ]
208 [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
209 [ intersect-lengths >>length ]
210 [ intersect-slots >>slots ]
214 : value-info-intersect ( info1 info2 -- info )
216 { [ dup class>> null-class? ] [ nip ] }
217 { [ over class>> null-class? ] [ drop ] }
218 [ (value-info-intersect) ]
221 : union-literals ( info1 info2 -- literal literal? )
222 2dup [ literal?>> ] both? [
223 [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
226 DEFER: value-info-union
228 DEFER: (value-info-union)
230 : union-lengths ( info1 info2 -- length )
232 { [ dup not ] [ nip ] }
233 { [ over not ] [ drop ] }
237 : union-slot ( info1 info2 -- info )
239 { [ dup not ] [ nip ] }
240 { [ over not ] [ drop ] }
241 [ (value-info-union) ]
244 : union-slots ( info1 info2 -- slots )
246 2dup [ length ] bi@ =
247 [ [ union-slot ] 2map ] [ 2drop f ] if ;
249 : (value-info-union) ( info1 info2 -- info )
250 [ <value-info> ] 2dip
252 [ [ class>> ] bi@ class-or >>class ]
253 [ [ interval>> ] bi@ interval-union >>interval ]
254 [ union-literals [ >>literal ] [ >>literal? ] bi* ]
255 [ union-lengths >>length ]
256 [ union-slots >>slots ]
260 : value-info-union ( info1 info2 -- info )
262 { [ dup class>> null-class? ] [ drop ] }
263 { [ over class>> null-class? ] [ nip ] }
264 [ (value-info-union) ]
267 : value-infos-union ( infos -- info )
269 [ [ ] [ value-info-union ] map-reduce ] if-empty ;
271 : literals<= ( info1 info2 -- ? )
273 { [ dup literal?>> not ] [ 2drop t ] }
274 { [ over literal?>> not ] [ drop class>> null-class? ] }
275 [ [ literal>> ] bi@ eql? ]
278 : value-info<= ( info1 info2 -- ? )
280 { [ dup not ] [ 2drop t ] }
281 { [ over not ] [ 2drop f ] }
284 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
285 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
286 { [ 2dup literals<= not ] [ f ] }
287 { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
288 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
294 ! Assoc stack of current value --> info mapping
297 : value-info ( value -- info )
298 resolve-copy value-infos get assoc-stack null-info or ;
300 : set-value-info ( info value -- )
301 resolve-copy value-infos get last set-at ;
303 : refine-value-info ( info value -- )
304 resolve-copy value-infos get
305 [ assoc-stack [ value-info-intersect ] when* ] 2keep
308 : value-literal ( value -- obj ? )
309 value-info >literal< ;
311 : possible-boolean-values ( info -- values )
316 { [ dup null-class? ] [ { } ] }
317 { [ dup true-class? ] [ { t } ] }
318 { [ dup false-class? ] [ { f } ] }
323 : node-value-info ( node value -- info )
324 swap info>> at* [ drop null-info ] unless ;
326 : node-input-infos ( node -- seq )
327 dup in-d>> [ node-value-info ] with map ;
329 : node-output-infos ( node -- seq )
330 dup out-d>> [ node-value-info ] with map ;
332 : first-literal ( #call -- obj )
333 dup in-d>> first node-value-info literal>> ;
335 : last-literal ( #call -- obj )
336 dup out-d>> last node-value-info literal>> ;
338 : immutable-tuple-boa? ( #call -- ? )
339 dup word>> \ <tuple-boa> eq? [
340 dup in-d>> last node-value-info
341 literal>> first immutable-tuple-class?