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 ! generic-comparison-ops [
152 ! dup specific-comparison define-comparison-constraints
155 ! Remove redundant comparisons
156 : fold-comparison ( info1 info2 word -- info )
157 [ [ interval>> ] bi@ ] dip interval-comparison {
158 { incomparable [ object-info ] }
159 { t [ t <literal-info> ] }
160 { f [ f <literal-info> ] }
165 [ _ fold-comparison ] "outputs" set-word-prop
169 generic-comparison-ops [
170 dup specific-comparison
171 '[ _ fold-comparison ] "outputs" set-word-prop
174 : maybe-or-never ( ? -- info )
175 [ object-info ] [ f <literal-info> ] if ;
177 : info-intervals-intersect? ( info1 info2 -- ? )
178 [ interval>> ] bi@ intervals-intersect? ;
180 { number= bignum= float= } [
182 info-intervals-intersect? maybe-or-never
183 ] "outputs" set-word-prop
186 : info-classes-intersect? ( info1 info2 -- ? )
187 [ class>> ] bi@ classes-intersect? ;
190 over value-info literal>> fixnum? [
191 [ value-info literal>> is-equal-to ] dip t-->
193 ] "constraints" set-word-prop
196 [ info-intervals-intersect? ]
197 [ info-classes-intersect? ]
198 2bi and maybe-or-never
199 ] "outputs" set-word-prop
203 { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
204 { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
207 ] "outputs" set-word-prop
211 { bignum>fixnum fixnum }
214 { fixnum>bignum bignum }
215 { float>bignum bignum }
218 { fixnum>float float }
219 { bignum>float float }
224 [ interval>> ] [ class-interval ] bi*
227 <class/interval-info>
228 ] "outputs" set-word-prop
239 in-d>> second value-info >literal<
240 [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
241 ] "custom-inlining" set-word-prop
245 bitand-integer-integer
246 bitand-integer-fixnum
247 bitand-fixnum-integer
250 in-d>> second value-info >literal< [
251 0 most-positive-fixnum between?
252 [ [ >fixnum ] bi@ fixnum-bitand ] f ?
254 ] "custom-inlining" set-word-prop
257 { numerator denominator }
258 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
260 { (log2) fixnum-log2 bignum-log2 } [
262 [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
263 ] "outputs" set-word-prop
267 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
268 ] "outputs" set-word-prop
282 [ "alien-signed-" ?head ]
283 [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
286 [ "alien-unsigned-" ?head ]
287 [ string>number 8 * 2^ 1- 0 swap [a,b] ]
290 [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
291 '[ 2drop _ ] "outputs" set-word-prop
294 { <tuple> <tuple-boa> } [
296 literal>> dup array? [ first ] [ drop tuple ] if <class-info>
298 ] "outputs" set-word-prop
302 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
303 ] "outputs" set-word-prop
305 ! the output of clone has the same type as the input
307 [ clone f >>literal f >>literal? ]
308 "outputs" set-word-prop
311 ! Generate more efficient code for common idiom
313 in-d>> first value-info literal>> {
314 { V{ } [ [ drop { } 0 vector boa ] ] }
315 { H{ } [ [ drop 0 <hashtable> ] ] }
318 ] "custom-inlining" set-word-prop
322 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
323 ] "outputs" set-word-prop
326 [ value-info ] dip over literal>> class? [
327 [ literal>> ] dip predicate-constraints
329 ] "constraints" set-word-prop
332 ! We need to force the caller word to recompile when the class
333 ! is redefined, since now we're making assumptions but the
334 ! class definition itself.
338 [ inlined-dependency depends-on ]
339 [ predicate-output-infos ]
341 ] [ 2drop object-info ] if
342 ] "outputs" set-word-prop
345 ! If first input has a known type and second input is an
346 ! object, we convert this to [ swap equal? ].
347 in-d>> first2 value-info class>> object class= [
348 value-info class>> \ equal? specific-method
351 ] "custom-inlining" set-word-prop