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 quotations
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 compiler.tree.propagation.call-effect
18 compiler.tree.propagation.transforms ;
19 IN: compiler.tree.propagation.known-words
22 most-negative-fixnum most-positive-fixnum [a,b]
23 "interval" set-word-prop
26 0 max-array-capacity [a,b]
27 "interval" set-word-prop
30 [ { number number } "input-classes" set-word-prop ] each
33 [ { real real } "input-classes" set-word-prop ] each
36 [ { rational rational } "input-classes" set-word-prop ] each
38 { bitand bitor bitxor bitnot shift }
39 [ { integer integer } "input-classes" set-word-prop ] each
41 \ bitnot { integer } "input-classes" set-word-prop
43 : ?change-interval ( info quot -- quot' )
44 over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
46 { bitnot fixnum-bitnot bignum-bitnot } [
47 [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
50 \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
52 : math-closure ( class -- newclass )
53 { fixnum bignum integer rational float real number object }
54 [ class<= ] with find nip ;
56 : fits? ( interval class -- ? )
57 "interval" word-prop interval-subset? ;
59 : binary-op-class ( info1 info2 -- newclass )
61 2dup [ null-class? ] either? [ 2drop null ] [
62 [ math-closure ] bi@ math-class-max
65 : binary-op-interval ( info1 info2 quot -- newinterval )
66 [ [ interval>> ] bi@ ] dip call ; inline
68 : won't-overflow? ( class interval -- ? )
69 [ fixnum class<= ] [ fixnum fits? ] bi* and ;
71 : may-overflow ( class interval -- class' interval' )
74 [ [ integer math-class-max ] dip ] unless
77 : may-be-rational ( class interval -- class' interval' )
79 [ rational math-class-max ] dip
82 : ensure-math-class ( class must-be -- class' )
85 : number-valued ( class interval -- class' interval' )
86 [ number ensure-math-class ] dip ;
88 : integer-valued ( class interval -- class' interval' )
89 [ integer ensure-math-class ] dip ;
91 : real-valued ( class interval -- class' interval' )
92 [ real ensure-math-class ] dip ;
94 : float-valued ( class interval -- class' interval' )
99 : binary-op ( word interval-quot post-proc-quot -- )
101 [ binary-op-class ] [ _ binary-op-interval ] 2bi
103 <class/interval-info>
104 ] "outputs" set-word-prop ;
106 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
107 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
109 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
110 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
112 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
113 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
115 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
116 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
117 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
119 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
120 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
122 { /mod fixnum/mod } [
124 [ "outputs" word-prop ] bi@
125 '[ _ _ 2bi ] "outputs" set-word-prop
128 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
129 \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
131 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
132 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
133 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
135 :: (comparison-constraints) ( in1 in2 op -- constraint )
136 [let | i1 [ in1 value-info interval>> ]
137 i2 [ in2 value-info interval>> ] |
138 in1 i1 i2 op assumption is-in-interval
139 in2 i2 i1 op swap-comparison assumption is-in-interval
143 :: comparison-constraints ( in1 in2 out op -- constraint )
144 in1 in2 op (comparison-constraints) out t-->
145 in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
147 : define-comparison-constraints ( word op -- )
148 '[ _ comparison-constraints ] "constraints" set-word-prop ;
151 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
153 ! Remove redundant comparisons
154 : fold-comparison ( info1 info2 word -- info )
155 [ [ interval>> ] bi@ ] dip interval-comparison {
156 { incomparable [ object-info ] }
157 { t [ t <literal-info> ] }
158 { f [ f <literal-info> ] }
163 [ _ fold-comparison ] "outputs" set-word-prop
167 generic-comparison-ops [
168 dup specific-comparison
169 '[ _ fold-comparison ] "outputs" set-word-prop
172 : maybe-or-never ( ? -- info )
173 [ object-info ] [ f <literal-info> ] if ;
175 : info-intervals-intersect? ( info1 info2 -- ? )
176 [ interval>> ] bi@ intervals-intersect? ;
178 { number= bignum= float= } [
180 info-intervals-intersect? maybe-or-never
181 ] "outputs" set-word-prop
184 : info-classes-intersect? ( info1 info2 -- ? )
185 [ class>> ] bi@ classes-intersect? ;
188 over value-info literal>> fixnum? [
189 [ value-info literal>> is-equal-to ] dip t-->
191 ] "constraints" set-word-prop
194 [ info-intervals-intersect? ]
195 [ info-classes-intersect? ]
196 2bi and maybe-or-never
197 ] "outputs" set-word-prop
201 { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
202 { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
205 ] "outputs" set-word-prop
209 { bignum>fixnum fixnum }
212 { fixnum>bignum bignum }
213 { float>bignum bignum }
216 { fixnum>float float }
217 { bignum>float float }
224 [ interval>> ] [ class-interval ] bi*
227 <class/interval-info>
228 ] "outputs" set-word-prop
231 { numerator denominator }
232 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
234 { (log2) fixnum-log2 bignum-log2 } [
236 [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
237 ] "outputs" set-word-prop
241 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
242 ] "outputs" set-word-prop
256 [ "alien-signed-" ?head ]
257 [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
260 [ "alien-unsigned-" ?head ]
261 [ string>number 8 * 2^ 1- 0 swap [a,b] ]
264 [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
265 '[ 2drop _ ] "outputs" set-word-prop
268 { <tuple> <tuple-boa> } [
270 literal>> dup array? [ first ] [ drop tuple ] if <class-info>
272 ] "outputs" set-word-prop
276 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
277 ] "outputs" set-word-prop
279 ! the output of clone has the same type as the input
281 [ clone f >>literal f >>literal? ]
282 "outputs" set-word-prop
287 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
288 ] "outputs" set-word-prop
291 [ value-info ] dip over literal>> class? [
292 [ literal>> ] dip predicate-constraints
294 ] "constraints" set-word-prop
297 ! We need to force the caller word to recompile when the class
298 ! is redefined, since now we're making assumptions but the
299 ! class definition itself.
303 [ inlined-dependency depends-on ]
304 [ predicate-output-infos ]
306 ] [ 2drop object-info ] if
307 ] "outputs" set-word-prop