1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: effects alien alien.accessors arrays generic hashtables
4 kernel assocs math math.libm math.private kernel.private
5 sequences words parser vectors strings sbufs io namespaces
6 assocs quotations math.intervals sequences.private combinators
7 splitting layouts math.parser classes classes.algebra
8 generic.math inference.class inference.dataflow
9 optimizer.pattern-match optimizer.backend optimizer.def-use
10 optimizer.inlining optimizer.math.partial generic.standard
14 : define-math-identities ( word identities -- )
15 >r all-derived-ops r> define-identities ;
18 { { @ @ } [ 2drop t ] }
19 } define-math-identities
22 { { number 0 } [ drop ] }
23 { { 0 number } [ nip ] }
24 } define-math-identities
27 { { number 0 } [ drop ] }
28 { { @ @ } [ 2drop 0 ] }
29 } define-math-identities
32 { { @ @ } [ 2drop f ] }
33 } define-math-identities
36 { { @ @ } [ 2drop t ] }
37 } define-math-identities
40 { { @ @ } [ 2drop f ] }
41 } define-math-identities
44 { { @ @ } [ 2drop t ] }
45 } define-math-identities
48 { { number 1 } [ drop ] }
49 { { 1 number } [ nip ] }
50 { { number 0 } [ nip ] }
51 { { 0 number } [ drop ] }
52 { { number -1 } [ drop 0 swap - ] }
53 { { -1 number } [ nip 0 swap - ] }
54 } define-math-identities
57 { { number 1 } [ drop ] }
58 { { number -1 } [ drop 0 swap - ] }
59 } define-math-identities
62 { { integer 1 } [ 2drop 0 ] }
63 } define-math-identities
66 { { integer 1 } [ 2drop 0 ] }
67 } define-math-identities
70 { { number -1 } [ drop ] }
71 { { -1 number } [ nip ] }
73 { { number 0 } [ nip ] }
74 { { 0 number } [ drop ] }
75 } define-math-identities
78 { { number 0 } [ drop ] }
79 { { 0 number } [ nip ] }
81 { { number -1 } [ nip ] }
82 { { -1 number } [ drop ] }
83 } define-math-identities
86 { { number 0 } [ drop ] }
87 { { 0 number } [ nip ] }
88 { { number -1 } [ drop bitnot ] }
89 { { -1 number } [ nip bitnot ] }
90 { { @ @ } [ 2drop 0 ] }
91 } define-math-identities
94 { { 0 number } [ drop ] }
95 { { number 0 } [ drop ] }
96 } define-math-identities
98 : math-closure ( class -- newclass )
99 { null fixnum bignum integer rational float real number }
100 [ class<= ] with find nip number or ;
102 : fits? ( interval class -- ? )
103 "interval" word-prop dup
104 [ interval-subset? ] [ 2drop t ] if ;
106 : math-output-class ( node upgrades -- newclass )
108 in-d>> null [ value-class* math-closure math-class-max ] reduce
111 : won't-overflow? ( interval node -- ? )
112 node-in-d [ value-class* fixnum class<= ] all?
113 swap fixnum fits? and ;
115 : post-process ( class interval node -- classes intervals )
117 [ >r dup { f integer } member? [ drop fixnum ] when r> ] when
118 [ dup [ 1array ] when ] bi@ ;
120 : math-output-interval-1 ( node word -- interval )
122 >r node-in-d first value-interval* dup
123 [ r> execute ] [ r> 2drop f ] if
128 : math-output-class/interval-1 ( node word -- classes intervals )
129 [ drop { } math-output-class 1array ]
130 [ math-output-interval-1 1array ] 2bi ;
133 { bitnot interval-bitnot }
134 { fixnum-bitnot interval-bitnot }
135 { bignum-bitnot interval-bitnot }
137 [ math-output-class/interval-1 ] curry
138 "output-classes" set-word-prop
141 : intervals ( node -- i1 i2 )
142 node-in-d first2 [ value-interval* ] bi@ ;
144 : math-output-interval-2 ( node word -- interval )
146 >r intervals 2dup and [ r> execute ] [ r> 3drop f ] if
151 : math-output-class/interval-2 ( node upgrades word -- classes intervals )
154 math-output-interval-2
155 >r math-output-class r>
156 r> post-process ; inline
159 { + { { fixnum integer } } interval+ }
160 { - { { fixnum integer } } interval- }
161 { * { { fixnum integer } } interval* }
162 { / { { fixnum rational } { integer rational } } interval/-safe }
163 { /i { { fixnum integer } } interval/i }
164 { shift { { fixnum integer } } interval-shift-safe }
168 math-output-class/interval-2
169 ] 2curry "output-classes" set-word-prop
170 ] 2curry each-derived-op
173 : math-output-class/interval-2-fast ( node word -- classes intervals )
174 math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
180 { shift interval-shift-safe }
184 math-output-class/interval-2-fast
185 ] curry "output-classes" set-word-prop
186 ] curry each-fast-derived-op
189 : real-value? ( value -- n ? )
190 dup value? [ value-literal dup real? ] [ drop f f ] if ;
192 : mod-range ( n -- interval )
195 : rem-range ( n -- interval )
198 : bitand-range ( n -- interval )
199 dup 0 < [ drop f ] [ 0 swap [a,b] ] if ;
201 : math-output-interval-special ( node word -- interval )
203 >r node-in-d second real-value?
204 [ r> execute ] [ r> 2drop f ] if
209 : math-output-class/interval-special ( node min word -- classes intervals )
212 math-output-interval-special
213 >r math-output-class r>
214 r> post-process ; inline
217 { mod { } mod-range }
218 { rem { { fixnum integer } } rem-range }
220 { bitand { } bitand-range }
226 math-output-class/interval-special
227 ] 2curry "output-classes" set-word-prop
228 ] 2curry each-derived-op
231 : twiddle-interval ( i1 -- i2 )
234 [ value-class* integer class<= ] all?
235 [ integral-closure ] when
238 : (comparison-constraints) ( i1 i2 word class -- )
240 >r execute twiddle-interval 0 `input interval,
242 ] set-constraints ; inline
244 : comparison-constraints ( node true false -- )
245 >r >r dup node set intervals dup [
247 r> \ f class-not (comparison-constraints)
248 r> \ f (comparison-constraints)
254 { < assume< assume>= }
255 { <= assume<= assume> }
256 { > assume> assume<= }
257 { >= assume>= assume< }
261 [ comparison-constraints ] with-scope
262 ] 2curry "constraints" set-word-prop
263 ] 2curry each-derived-op
278 [ "alien-signed-" ?head ]
279 [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
282 [ "alien-unsigned-" ?head ]
283 [ string>number 8 * 2^ 1- 0 swap [a,b] ]
286 [ nip f swap ] curry "output-classes" set-word-prop
289 ! Associate intervals to classes
291 most-negative-fixnum most-positive-fixnum [a,b]
292 "interval" set-word-prop
295 0 max-array-capacity [a,b]
296 "interval" set-word-prop
304 over node-in-d first value-interval*
305 dup pick fits? [ drop f ] unless
307 ] curry "output-classes" set-word-prop
310 ! Removing overflow checks
311 : remove-overflow-check? ( #call -- ? )
312 dup out-d>> first node-class
313 [ fixnum class<= ] [ null eq? not ] bi and ;
316 { + [ fixnum+fast ] }
317 { +-integer-fixnum [ fixnum+fast ] }
318 { - [ fixnum-fast ] }
319 { * [ fixnum*fast ] }
320 { *-integer-fixnum [ fixnum*fast ] }
321 { shift [ fixnum-shift-fast ] }
322 { fixnum+ [ fixnum+fast ] }
323 { fixnum- [ fixnum-fast ] }
324 { fixnum* [ fixnum*fast ] }
325 { fixnum-shift [ fixnum-shift-fast ] }
328 [ dup remove-overflow-check? ] ,
329 [ f splice-quot ] curry ,
330 ] { } make 1array define-optimizers
333 ! Remove redundant comparisons
334 : intervals-first2 ( #call -- first second )
335 dup dup node-in-d first node-interval
336 swap dup node-in-d second node-interval ;
338 : known-comparison? ( #call -- ? )
339 intervals-first2 and ;
341 : perform-comparison ( #call word -- result )
342 >r intervals-first2 r> execute ; inline
344 : foldable-comparison? ( #call word -- ? )
345 >r dup known-comparison? [
346 r> perform-comparison incomparable eq? not
351 : fold-comparison ( #call word -- node )
352 dupd perform-comparison 1array inline-literals ;
362 dup [ dupd foldable-comparison? ] curry ,
363 [ fold-comparison ] curry ,
364 ] { } make 1array define-optimizers
365 ] curry each-derived-op
368 ! The following words are handled in a similar way except if
369 ! the only consumer is a >fixnum we remove the overflow check
371 : consumed-by? ( node word -- ? )
373 dup #call? [ node-param eq? ] [ 2drop f ] if ;
375 : coerced-to-fixnum? ( #call -- ? )
376 dup dup node-in-d [ node-class integer class<= ] with all?
377 [ \ >fixnum consumed-by? ] [ drop f ] if ;
380 { + [ [ >fixnum ] bi@ fixnum+fast ] }
381 { - [ [ >fixnum ] bi@ fixnum-fast ] }
382 { * [ [ >fixnum ] bi@ fixnum*fast ] }
387 dup remove-overflow-check?
388 over coerced-to-fixnum? or
390 [ f splice-quot ] curry ,
391 ] { } make 1array define-optimizers
395 : convert-rem-to-and? ( #call -- ? )
397 { [ 2dup first node-class integer class<= not ] [ f ] }
398 { [ 2dup second node-literal integer? not ] [ f ] }
399 { [ 2dup second node-literal power-of-2? not ] [ f ] }
403 : convert-mod-to-and? ( #call -- ? )
404 dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
405 [ convert-rem-to-and? ] [ drop f ] if ;
407 : convert-mod-to-and ( #call -- node )
409 dup in-d>> second node-literal 1-
410 [ nip bitand ] curry f splice-quot ;
415 [ dup convert-mod-to-and? ]
416 [ convert-mod-to-and ]
423 [ dup convert-rem-to-and? ]
424 [ convert-mod-to-and ]
428 : fixnumify-bitand? ( #call -- ? )
429 dup node-in-d second node-interval fixnum fits? ;
431 : fixnumify-bitand ( #call -- node )
432 [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
436 [ dup fixnumify-bitand? ]
441 : convert-*-to-shift? ( #call -- ? )
442 dup in-d>> second node-literal
443 dup integer? [ power-of-2? ] [ drop f ] if ;
445 : convert-*-to-shift ( #call -- ? )
446 dup dup in-d>> second node-literal log2
447 [ nip fixnum-shift-fast ] curry
451 { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
455 [ { number number } "input-classes" set-word-prop ] each
458 [ { real real } "input-classes" set-word-prop ] each
461 [ { rational rational } "input-classes" set-word-prop ] each
463 { bitand bitor bitxor bitnot shift }
464 [ { integer integer } "input-classes" set-word-prop ] each
486 [ in>> length real <repetition> "input-classes" set-word-prop ]
487 [ out>> length float <repetition> "default-output-classes" set-word-prop ]