1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel effects accessors math math.private
4 math.integers.private math.partial-dispatch math.intervals
5 math.parser math.order layouts words sequences sequences.private
6 arrays assocs classes classes.algebra combinators generic.math
7 splitting fry locals classes.tuple alien.accessors
8 classes.tuple.private slots.private definitions strings.private
9 vectors hashtables generic
11 compiler.tree.comparisons
12 compiler.tree.propagation.info
13 compiler.tree.propagation.nodes
14 compiler.tree.propagation.slots
15 compiler.tree.propagation.simple
16 compiler.tree.propagation.constraints ;
17 IN: compiler.tree.propagation.known-words
20 most-negative-fixnum most-positive-fixnum [a,b]
21 "interval" set-word-prop
24 0 max-array-capacity [a,b]
25 "interval" set-word-prop
28 [ { number number } "input-classes" set-word-prop ] each
31 [ { real real } "input-classes" set-word-prop ] each
34 [ { rational rational } "input-classes" set-word-prop ] each
36 { bitand bitor bitxor bitnot shift }
37 [ { integer integer } "input-classes" set-word-prop ] each
39 \ bitnot { integer } "input-classes" set-word-prop
41 : ?change-interval ( info quot -- quot' )
42 over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
44 { bitnot fixnum-bitnot bignum-bitnot } [
45 [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
48 \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
50 : math-closure ( class -- newclass )
51 { fixnum bignum integer rational float real number object }
52 [ class<= ] with find nip ;
54 : fits? ( interval class -- ? )
55 "interval" word-prop interval-subset? ;
57 : binary-op-class ( info1 info2 -- newclass )
59 2dup [ null-class? ] either? [ 2drop null ] [
60 [ math-closure ] bi@ math-class-max
63 : binary-op-interval ( info1 info2 quot -- newinterval )
64 [ [ interval>> ] bi@ ] dip call ; inline
66 : won't-overflow? ( class interval -- ? )
67 [ fixnum class<= ] [ fixnum fits? ] bi* and ;
69 : may-overflow ( class interval -- class' interval' )
72 [ [ integer math-class-max ] dip ] unless
75 : may-be-rational ( class interval -- class' interval' )
77 [ rational math-class-max ] dip
80 : ensure-math-class ( class must-be -- class' )
83 : number-valued ( class interval -- class' interval' )
84 [ number ensure-math-class ] dip ;
86 : integer-valued ( class interval -- class' interval' )
87 [ integer ensure-math-class ] dip ;
89 : real-valued ( class interval -- class' interval' )
90 [ real ensure-math-class ] dip ;
92 : float-valued ( class interval -- class' interval' )
97 : binary-op ( word interval-quot post-proc-quot -- )
99 [ binary-op-class ] [ _ binary-op-interval ] 2bi
101 <class/interval-info>
102 ] "outputs" set-word-prop ;
104 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
105 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
107 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
108 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
110 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
111 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
113 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
114 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
115 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
117 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
118 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
120 { /mod fixnum/mod } [
122 [ "outputs" word-prop ] bi@
123 '[ _ _ 2bi ] "outputs" set-word-prop
126 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
127 \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
129 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
130 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
131 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
133 :: (comparison-constraints) ( in1 in2 op -- constraint )
134 [let | i1 [ in1 value-info interval>> ]
135 i2 [ in2 value-info interval>> ] |
136 in1 i1 i2 op assumption is-in-interval
137 in2 i2 i1 op swap-comparison assumption is-in-interval
141 :: comparison-constraints ( in1 in2 out op -- constraint )
142 in1 in2 op (comparison-constraints) out t-->
143 in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
145 : define-comparison-constraints ( word op -- )
146 '[ _ comparison-constraints ] "constraints" set-word-prop ;
149 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
151 ! Remove redundant comparisons
152 : fold-comparison ( info1 info2 word -- info )
153 [ [ interval>> ] bi@ ] dip interval-comparison {
154 { incomparable [ object-info ] }
155 { t [ t <literal-info> ] }
156 { f [ f <literal-info> ] }
161 [ _ fold-comparison ] "outputs" set-word-prop
165 generic-comparison-ops [
166 dup specific-comparison
167 '[ _ fold-comparison ] "outputs" set-word-prop
170 : maybe-or-never ( ? -- info )
171 [ object-info ] [ f <literal-info> ] if ;
173 : info-intervals-intersect? ( info1 info2 -- ? )
174 [ interval>> ] bi@ intervals-intersect? ;
176 { number= bignum= float= } [
178 info-intervals-intersect? maybe-or-never
179 ] "outputs" set-word-prop
182 : info-classes-intersect? ( info1 info2 -- ? )
183 [ class>> ] bi@ classes-intersect? ;
186 over value-info literal>> fixnum? [
187 [ value-info literal>> is-equal-to ] dip t-->
189 ] "constraints" set-word-prop
192 [ info-intervals-intersect? ]
193 [ info-classes-intersect? ]
194 2bi and maybe-or-never
195 ] "outputs" set-word-prop
199 { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
200 { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
203 ] "outputs" set-word-prop
207 { bignum>fixnum fixnum }
210 { fixnum>bignum bignum }
211 { float>bignum bignum }
214 { fixnum>float float }
215 { bignum>float float }
222 [ interval>> ] [ class-interval ] bi*
225 <class/interval-info>
226 ] "outputs" set-word-prop
229 : rem-custom-inlining ( #call -- quot/f )
230 second value-info literal>> dup integer?
231 [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
240 in-d>> dup first value-info interval>> [0,inf] interval-subset?
241 [ rem-custom-inlining ] [ drop f ] if
242 ] "custom-inlining" set-word-prop
246 in-d>> rem-custom-inlining
247 ] "custom-inlining" set-word-prop
250 bitand-integer-integer
251 bitand-integer-fixnum
252 bitand-fixnum-integer
255 in-d>> second value-info >literal< [
256 0 most-positive-fixnum between?
257 [ [ >fixnum ] bi@ fixnum-bitand ] f ?
259 ] "custom-inlining" set-word-prop
262 { numerator denominator }
263 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
265 { (log2) fixnum-log2 bignum-log2 } [
267 [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
268 ] "outputs" set-word-prop
272 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
273 ] "outputs" set-word-prop
287 [ "alien-signed-" ?head ]
288 [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
291 [ "alien-unsigned-" ?head ]
292 [ string>number 8 * 2^ 1- 0 swap [a,b] ]
295 [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
296 '[ 2drop _ ] "outputs" set-word-prop
299 { <tuple> <tuple-boa> } [
301 literal>> dup array? [ first ] [ drop tuple ] if <class-info>
303 ] "outputs" set-word-prop
307 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
308 ] "outputs" set-word-prop
310 ! the output of clone has the same type as the input
312 [ clone f >>literal f >>literal? ]
313 "outputs" set-word-prop
316 ! Generate more efficient code for common idiom
318 in-d>> first value-info literal>> {
319 { V{ } [ [ drop { } 0 vector boa ] ] }
320 { H{ } [ [ drop 0 <hashtable> ] ] }
323 ] "custom-inlining" set-word-prop
327 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
328 ] "outputs" set-word-prop
331 [ value-info ] dip over literal>> class? [
332 [ literal>> ] dip predicate-constraints
334 ] "constraints" set-word-prop
337 ! We need to force the caller word to recompile when the class
338 ! is redefined, since now we're making assumptions but the
339 ! class definition itself.
343 [ inlined-dependency depends-on ]
344 [ predicate-output-infos ]
346 ] [ 2drop object-info ] if
347 ] "outputs" set-word-prop
350 in-d>> second value-info literal>> dup class?
351 [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
352 ] "custom-inlining" set-word-prop
355 ! If first input has a known type and second input is an
356 ! object, we convert this to [ swap equal? ].
357 in-d>> first2 value-info class>> object class= [
358 value-info class>> \ equal? specific-method
361 ] "custom-inlining" set-word-prop