1 ! Copyright (C) 2008, 2009 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.floats.private math.partial-dispatch
5 math.intervals math.parser math.order math.functions math.libm
6 layouts words sequences sequences.private arrays assocs classes
7 classes.algebra combinators generic.math splitting fry locals
8 classes.tuple alien.accessors classes.tuple.private
9 slots.private definitions strings.private vectors hashtables
10 generic quotations alien
12 compiler.tree.comparisons
13 compiler.tree.propagation.info
14 compiler.tree.propagation.nodes
15 compiler.tree.propagation.slots
16 compiler.tree.propagation.simple
17 compiler.tree.propagation.constraints
18 compiler.tree.propagation.call-effect
19 compiler.tree.propagation.transforms
20 compiler.tree.propagation.simd ;
21 IN: compiler.tree.propagation.known-words
24 [ { number number } "input-classes" set-word-prop ] each
26 { /f < > <= >= u< u> u<= u>= }
27 [ { real real } "input-classes" set-word-prop ] each
30 [ { rational rational } "input-classes" set-word-prop ] each
32 { bitand bitor bitxor bitnot shift }
33 [ { integer integer } "input-classes" set-word-prop ] each
35 \ bitnot { integer } "input-classes" set-word-prop
37 : math-closure ( class -- newclass )
38 { fixnum bignum integer rational float real number object }
39 [ class<= ] with find nip ;
41 : fits-in-fixnum? ( interval -- ? )
42 fixnum-interval interval-subset? ;
44 : won't-overflow? ( class interval -- ? )
45 [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
47 : may-overflow ( class interval -- class' interval' )
50 [ [ integer math-class-max ] dip ] unless
53 : may-be-rational ( class interval -- class' interval' )
55 [ rational math-class-max ] dip
58 : ensure-math-class ( class must-be -- class' )
61 : number-valued ( class interval -- class' interval' )
62 [ number ensure-math-class ] dip ;
64 : fixnum-valued ( class interval -- class' interval' )
69 : integer-valued ( class interval -- class' interval' )
70 [ integer ensure-math-class ] dip ;
72 : real-valued ( class interval -- class' interval' )
73 [ real ensure-math-class ] dip ;
75 : float-valued ( class interval -- class' interval' )
80 : unary-op-class ( info -- newclass )
81 class>> dup null-class? [ drop null ] [ math-closure ] if ;
83 : unary-op-interval ( info quot -- newinterval )
85 dup class>> real classes-intersect?
86 [ interval>> ] [ drop full-interval ] if
89 : unary-op ( word interval-quot post-proc-quot -- )
91 [ unary-op-class ] [ _ unary-op-interval ] bi
94 ] "outputs" set-word-prop ;
96 { bitnot fixnum-bitnot bignum-bitnot } [
97 [ interval-bitnot ] [ integer-valued ] unary-op
100 \ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
102 \ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
104 : binary-op-class ( info1 info2 -- newclass )
106 2dup [ null-class? ] either? [ 2drop null ] [
107 [ math-closure ] bi@ math-class-max
110 : binary-op-interval ( info1 info2 quot -- newinterval )
111 [ [ interval>> ] bi@ ] dip call ; inline
113 : binary-op ( word interval-quot post-proc-quot -- )
115 [ binary-op-class ] [ _ binary-op-interval ] 2bi
117 <class/interval-info>
118 ] "outputs" set-word-prop ;
120 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
121 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
123 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
124 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
126 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
127 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
129 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
130 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
131 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
133 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
134 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
136 { /mod fixnum/mod } [
138 [ "outputs" word-prop ] bi@
139 '[ _ _ 2bi ] "outputs" set-word-prop
142 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
143 \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
145 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
146 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
147 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
149 :: (comparison-constraints) ( in1 in2 op -- constraint )
150 [let | i1 [ in1 value-info interval>> ]
151 i2 [ in2 value-info interval>> ] |
152 in1 i1 i2 op assumption is-in-interval
153 in2 i2 i1 op swap-comparison assumption is-in-interval
157 :: comparison-constraints ( in1 in2 out op -- constraint )
158 in1 in2 op (comparison-constraints) out t-->
159 in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
161 : define-comparison-constraints ( word op -- )
162 '[ _ comparison-constraints ] "constraints" set-word-prop ;
165 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
167 ! Remove redundant comparisons
168 : fold-comparison ( info1 info2 word -- info )
169 [ [ interval>> ] bi@ ] dip interval-comparison {
170 { incomparable [ object-info ] }
171 { t [ t <literal-info> ] }
172 { f [ f <literal-info> ] }
177 [ _ fold-comparison ] "outputs" set-word-prop
181 generic-comparison-ops [
182 dup specific-comparison
183 '[ _ fold-comparison ] "outputs" set-word-prop
186 : maybe-or-never ( ? -- info )
187 [ object-info ] [ f <literal-info> ] if ;
189 : info-intervals-intersect? ( info1 info2 -- ? )
190 2dup [ class>> real class<= ] both?
191 [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
193 { number= bignum= float= } [
195 info-intervals-intersect? maybe-or-never
196 ] "outputs" set-word-prop
199 : info-classes-intersect? ( info1 info2 -- ? )
200 [ class>> ] bi@ classes-intersect? ;
203 over value-info literal>> fixnum? [
204 [ value-info literal>> is-equal-to ] dip t-->
206 ] "constraints" set-word-prop
209 [ info-intervals-intersect? ]
210 [ info-classes-intersect? ]
211 2bi and maybe-or-never
212 ] "outputs" set-word-prop
216 { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
217 { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
220 ] "outputs" set-word-prop
224 { bignum>fixnum fixnum }
227 { fixnum>bignum bignum }
228 { float>bignum bignum }
231 { fixnum>float float }
232 { bignum>float float }
236 '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
239 { numerator denominator }
240 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
242 { (log2) fixnum-log2 bignum-log2 } [
244 [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
245 ] "outputs" set-word-prop
249 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
250 ] "outputs" set-word-prop
264 [ "alien-signed-" ?head ]
265 [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
268 [ "alien-unsigned-" ?head ]
269 [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
272 [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
273 '[ 2drop _ ] "outputs" set-word-prop
277 2drop simple-alien \ f class-or <class-info>
278 ] "outputs" set-word-prop
280 { <tuple> <tuple-boa> } [
282 literal>> dup array? [ first ] [ drop tuple ] if <class-info>
284 ] "outputs" set-word-prop
288 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
289 ] "outputs" set-word-prop
291 ! the output of clone has the same type as the input
292 : cloned-value-info ( value-info -- value-info' )
293 clone f >>literal f >>literal?
294 [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
297 [ cloned-value-info ] "outputs" set-word-prop
302 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
303 ] "outputs" set-word-prop
306 [ value-info ] dip over literal>> class? [
307 [ literal>> ] dip predicate-constraints
309 ] "constraints" set-word-prop
312 ! We need to force the caller word to recompile when the class
313 ! is redefined, since now we're making assumptions but the
314 ! class definition itself.
318 [ inlined-dependency depends-on ]
319 [ predicate-output-infos ]
321 ] [ 2drop object-info ] if
322 ] "outputs" set-word-prop
324 { facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp
325 flog fpow fsqrt facosh fasinh fatanh } [
326 { float } "default-output-classes" set-word-prop
329 ! Find a less repetitive way of doing this
330 \ float-min { float float } "input-classes" set-word-prop
331 \ float-min [ interval-min ] [ float-valued ] binary-op
333 \ float-max { float float } "input-classes" set-word-prop
334 \ float-max [ interval-max ] [ float-valued ] binary-op
336 \ fixnum-min { fixnum fixnum } "input-classes" set-word-prop
337 \ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op
339 \ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
340 \ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op