1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors alien.data.private arrays
4 assocs byte-arrays byte-vectors classes classes.algebra classes.tuple
5 classes.tuple.private combinators compiler.tree.comparisons
6 compiler.tree.propagation.constraints compiler.tree.propagation.info
7 compiler.tree.propagation.simple compiler.tree.propagation.slots fry
8 generic.math hashtables kernel kernel.private layouts locals math
9 math.floats.private math.functions math.integers.private
10 math.intervals math.libm math.parser math.partial-dispatch
11 math.private namespaces sbufs sequences slots.private splitting
12 stack-checker.dependencies strings strings.private vectors words ;
13 FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
14 IN: compiler.tree.propagation.known-words
17 [ { number number } "input-classes" set-word-prop ] each
19 { /f /i mod < > <= >= u< u> u<= u>= }
20 [ { real real } "input-classes" set-word-prop ] each
22 \ /mod { rational rational } "input-classes" set-word-prop
24 { bitand bitor bitxor shift }
25 [ { integer integer } "input-classes" set-word-prop ] each
27 \ bitnot { integer } "input-classes" set-word-prop
29 : math-closure ( class -- newclass )
30 { fixnum bignum integer rational float real number object }
31 [ class<= ] with find nip ;
33 : fits-in-fixnum? ( interval -- ? )
34 fixnum-interval interval-subset? ;
36 : won't-overflow? ( class interval -- ? )
37 [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
39 : may-overflow ( class interval -- class' interval' )
42 [ [ integer math-class-max ] dip ] unless
45 : may-be-rational ( class interval -- class' interval' )
47 [ rational math-class-max ] dip
50 : ensure-math-class ( class must-be -- class' )
53 : number-valued ( class interval -- class' interval' )
54 [ number ensure-math-class ] dip ;
56 : fixnum-valued ( class interval -- class' interval' )
61 : integer-valued ( class interval -- class' interval' )
62 [ integer ensure-math-class ] dip ;
64 : real-valued ( class interval -- class' interval' )
65 [ real ensure-math-class ] dip ;
67 : float-valued ( class interval -- class' interval' )
72 : unary-op-class ( info -- newclass )
73 class>> dup null-class? [ drop null ] [ math-closure ] if ;
75 : unary-op-interval ( info quot -- newinterval )
77 dup class>> real classes-intersect?
78 [ interval>> ] [ drop full-interval ] if
81 : unary-op ( word interval-quot post-proc-quot -- )
83 [ unary-op-class ] [ _ unary-op-interval ] bi
86 ] "outputs" set-word-prop ;
88 { bitnot fixnum-bitnot bignum-bitnot } [
89 [ interval-bitnot ] [ integer-valued ] unary-op
92 \ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
94 \ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
96 : merge-classes ( class1 class2 -- class3 )
97 2dup [ null-class? ] either? [ 2drop null ] [
98 [ math-closure ] bi@ math-class-max
101 : binary-op-class ( info1 info2 -- newclass )
102 [ class>> ] bi@ merge-classes ;
104 : binary-op-interval ( info1 info2 quot -- newinterval )
105 [ [ interval>> ] bi@ ] dip call ; inline
107 : binary-op ( word interval-quot post-proc-quot -- )
109 [ binary-op-class ] [ _ binary-op-interval ] 2bi
111 <class/interval-info>
112 ] "outputs" set-word-prop ;
114 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
115 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
117 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
118 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
120 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
121 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
123 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
124 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
125 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
127 : mod-merge-classes/intervals ( c1 c2 i1 i2 -- c3 i3 )
128 [ merge-classes dup bignum = [ drop integer ] when ]
129 [ interval-mod ] 2bi*
130 over integer class<= [
131 integral-closure dup fixnum-interval interval-subset? [
136 : mod-outputs-info ( info1 info2 fixer-word -- info3 )
138 [ [ class>> ] bi@ ] [ [ interval>> ] bi@ ] 2bi
139 mod-merge-classes/intervals
140 ] dip execute( cls int -- cls' int' ) <class/interval-info> ;
145 { mod-integer-integer integer-valued }
146 { mod-fixnum-integer integer-valued }
147 { mod-integer-fixnum integer-valued }
148 { bignum-mod integer-valued }
149 { fixnum-mod fixnum-valued }
150 } [ '[ _ mod-outputs-info ] "outputs" set-word-prop ] assoc-each
152 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
154 ! /mod is the combination of /i and mod, fixnum/mod of /i and fixnum-mod
156 \ /i \ mod [ "outputs" word-prop ] bi@
157 '[ _ _ 2bi ] "outputs" set-word-prop
160 \ /i \ fixnum-mod [ "outputs" word-prop ] bi@
161 '[ _ _ 2bi ] "outputs" set-word-prop
163 : shift-op-class ( info1 info2 -- newclass )
165 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
167 : shift-op ( word interval-quot post-proc-quot -- )
169 [ shift-op-class ] [ _ binary-op-interval ] 2bi
171 <class/interval-info>
172 ] "outputs" set-word-prop ;
174 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
175 \ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
177 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
178 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
179 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
181 :: (comparison-constraints) ( in1 in2 op -- constraint )
182 in1 value-info interval>> :> i1
183 in2 value-info interval>> :> i2
184 in1 i1 i2 op assumption is-in-interval
185 in2 i2 i1 op swap-comparison assumption is-in-interval
188 :: comparison-constraints ( in1 in2 out op -- constraint )
189 in1 in2 op (comparison-constraints) out t-->
190 in1 in2 op negate-comparison (comparison-constraints) out f--> 2array ;
192 : define-comparison-constraints ( word op -- )
193 '[ _ comparison-constraints ] "constraints" set-word-prop ;
196 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
198 ! Remove redundant comparisons
199 : fold-comparison ( info1 info2 word -- info )
200 [ [ interval>> ] bi@ ] dip interval-comparison {
201 { incomparable [ object-info ] }
202 { t [ t <literal-info> ] }
203 { f [ f <literal-info> ] }
208 [ _ fold-comparison ] "outputs" set-word-prop
212 generic-comparison-ops [
213 dup specific-comparison
214 '[ _ fold-comparison ] "outputs" set-word-prop
217 : maybe-or-never ( ? -- info )
218 [ object-info ] [ f <literal-info> ] if ;
220 : info-intervals-intersect? ( info1 info2 -- ? )
221 2dup [ class>> real class<= ] both?
222 [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
224 { number= bignum= float= } [
226 info-intervals-intersect? maybe-or-never
227 ] "outputs" set-word-prop
230 : info-classes-intersect? ( info1 info2 -- ? )
231 [ class>> ] bi@ classes-intersect? ;
234 over value-info literal>> fixnum? [
235 [ value-info literal>> is-equal-to ] dip t-->
237 ] "constraints" set-word-prop
240 [ info-intervals-intersect? ]
241 [ info-classes-intersect? ]
242 2bi and maybe-or-never
243 ] "outputs" set-word-prop
247 { bignum>fixnum fixnum }
248 { bignum>fixnum-strict fixnum }
249 { integer>fixnum fixnum }
250 { integer>fixnum-strict fixnum }
253 { float>bignum bignum }
256 { bignum>float float }
260 '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
263 ! For these we limit the output interval
265 { fixnum>bignum bignum }
266 { fixnum>float float }
269 _ swap interval>> fixnum-interval interval-intersect
270 <class/interval-info>
271 ] "outputs" set-word-prop
279 { >byte-array byte-array }
280 { >byte-vector byte-vector }
281 { >hashtable hashtable }
283 '[ drop _ <class-info> ] "outputs" set-word-prop
286 { numerator denominator }
287 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
290 drop integer <class-info> dup
291 ] "outputs" set-word-prop
293 { (log2) fixnum-log2 bignum-log2 } [
295 [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
296 ] "outputs" set-word-prop
300 2drop fixnum 0 255 [a,b] <class/interval-info>
301 ] "outputs" set-word-prop
314 { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] }
315 { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] }
317 [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
318 '[ 2drop _ ] "outputs" set-word-prop
322 2drop alien \ f class-or <class-info>
323 ] "outputs" set-word-prop
325 \ <displaced-alien> [
326 [ interval>> 0 swap interval-contains? ] dip
327 class>> alien class-or alien ? <class-info>
328 ] "outputs" set-word-prop
330 { <tuple> <tuple-boa> } [
332 literal>> dup array? [ first ] [ drop tuple ] if <class-info>
334 ] "outputs" set-word-prop
338 literal>> dup tuple-class? [ drop tuple ] unless <class-info>
339 ] "outputs" set-word-prop
341 ! the output of (clone) has the same type as the input
342 : cloned-value-info ( value-info -- value-info' )
343 clone f >>literal f >>literal?
344 [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
346 \ (clone) [ cloned-value-info ] "outputs" set-word-prop
350 [ literal>> swap value-info-slot ] [ 2drop object-info ] if
351 ] "outputs" set-word-prop
354 [ value-info ] dip over literal>> classoid? [
355 [ literal>> ] dip predicate-constraints
357 ] "constraints" set-word-prop
360 ! We need to force the caller word to recompile when the class
361 ! is redefined, since now we're making assumptions about the
362 ! class definition itself.
363 dup literal>> classoid?
366 [ add-depends-on-class ]
367 [ predicate-output-infos ]
369 ] [ 2drop object-info ] if
370 ] "outputs" set-word-prop
372 ! Unlike the other words in math.libm, fsqrt is not inline
373 ! since it has an intrinsic, so we need to give it outputs here.
374 \ fsqrt { float } "default-output-classes" set-word-prop
376 ! Find a less repetitive way of doing this
377 \ float-min { float float } "input-classes" set-word-prop
378 \ float-min [ interval-min ] [ float-valued ] binary-op
380 \ float-max { float float } "input-classes" set-word-prop
381 \ float-max [ interval-max ] [ float-valued ] binary-op
383 \ fixnum-min { fixnum fixnum } "input-classes" set-word-prop
384 \ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op
386 \ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
387 \ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
389 \ local-allot { alien } "default-output-classes" set-word-prop
392 drop fixnum 0 num-types get [a,b) <class/interval-info>
393 ] "outputs" set-word-prop
395 ! Primitive resize operations
397 : propagate-resize-fixed-length-sequence ( n-info in-info class -- out-info )
398 nip <sequence-info> ;
400 { { resize-array array }
401 { resize-byte-array byte-array }
402 { resize-string string } }
404 [ propagate-resize-fixed-length-sequence ] curry
405 "outputs" set-word-prop