1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel effects accessors math math.private math.libm
4 math.partial-dispatch math.intervals math.parser math.order
5 layouts words sequences sequences.private arrays assocs classes
6 classes.algebra combinators generic.math splitting fry locals
7 classes.tuple alien.accessors classes.tuple.private slots.private
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
61 [ in>> length real <repetition> "input-classes" set-word-prop ]
62 [ out>> length float <repetition> "default-output-classes" set-word-prop ]
66 : ?change-interval ( info quot -- quot' )
67 over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
69 { bitnot fixnum-bitnot bignum-bitnot } [
70 [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
73 \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
75 : math-closure ( class -- newclass )
76 { fixnum bignum integer rational float real number object }
77 [ class<= ] with find nip ;
79 : fits? ( interval class -- ? )
80 "interval" word-prop interval-subset? ;
82 : binary-op-class ( info1 info2 -- newclass )
84 2dup [ null-class? ] either? [ 2drop null ] [
85 [ math-closure ] bi@ math-class-max
88 : binary-op-interval ( info1 info2 quot -- newinterval )
89 [ [ interval>> ] bi@ ] dip call ; inline
91 : won't-overflow? ( class interval -- ? )
92 [ fixnum class<= ] [ fixnum fits? ] bi* and ;
94 : may-overflow ( class interval -- class' interval' )
97 [ [ integer math-class-max ] dip ] unless
100 : may-be-rational ( class interval -- class' interval' )
102 [ rational math-class-max ] dip
105 : number-valued ( class interval -- class' interval' )
106 [ number math-class-min ] dip ;
108 : integer-valued ( class interval -- class' interval' )
109 [ integer math-class-min ] dip ;
111 : real-valued ( class interval -- class' interval' )
112 [ real math-class-min ] dip ;
114 : float-valued ( class interval -- class' interval' )
119 : binary-op ( word interval-quot post-proc-quot -- )
121 [ binary-op-class ] [ _ binary-op-interval ] 2bi
123 <class/interval-info>
124 ] "outputs" set-word-prop ;
126 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
127 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
129 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
130 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
132 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
133 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
135 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
136 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
137 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
139 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
140 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
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 generic-comparison-ops [
168 dup specific-comparison
169 '[ _ _ define-comparison-constraints ] each-derived-op
172 ! Remove redundant comparisons
173 : fold-comparison ( info1 info2 word -- info )
174 [ [ interval>> ] bi@ ] dip interval-comparison {
175 { incomparable [ object-info ] }
176 { t [ t <literal-info> ] }
177 { f [ f <literal-info> ] }
182 [ _ fold-comparison ] "outputs" set-word-prop
186 generic-comparison-ops [
187 dup specific-comparison
188 '[ _ fold-comparison ] "outputs" set-word-prop
191 : maybe-or-never ( ? -- info )
192 [ object-info ] [ f <literal-info> ] if ;
194 : info-intervals-intersect? ( info1 info2 -- ? )
195 [ interval>> ] bi@ intervals-intersect? ;
197 { number= bignum= float= } [
199 info-intervals-intersect? maybe-or-never
200 ] "outputs" set-word-prop
203 : info-classes-intersect? ( info1 info2 -- ? )
204 [ class>> ] bi@ classes-intersect? ;
207 over value-info literal>> fixnum? [
208 [ value-info literal>> is-equal-to ] dip t-->
210 ] "constraints" set-word-prop
213 [ info-intervals-intersect? ]
214 [ info-classes-intersect? ]
215 2bi and maybe-or-never
216 ] "outputs" set-word-prop
226 [ interval>> ] [ class-interval ] bi*
229 <class/interval-info>
230 ] "outputs" set-word-prop
245 [ "alien-signed-" ?head ]
246 [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
249 [ "alien-unsigned-" ?head ]
250 [ string>number 8 * 2^ 1- 0 swap [a,b] ]
253 [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
254 [ 2nip ] curry "outputs" set-word-prop
257 { <tuple> <tuple-boa> (tuple) } [
259 literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
261 ] "outputs" set-word-prop
265 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
266 ] "outputs" set-word-prop
268 ! the output of clone has the same type as the input
270 [ clone f >>literal f >>literal? ]
271 "outputs" set-word-prop
276 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
277 ] "outputs" set-word-prop
280 [ value-info ] dip over literal>> class? [
281 [ literal>> ] dip predicate-constraints
283 ] "constraints" set-word-prop
286 ! We need to force the caller word to recompile when the class
287 ! is redefined, since now we're making assumptions but the
288 ! class definition itself.
292 [ inlined-dependency depends-on ]
293 [ predicate-output-infos ]
295 ] [ 2drop object-info ] if
296 ] "outputs" set-word-prop