1 IN: compiler.tree.cleanup.tests
2 USING: tools.test kernel.private kernel arrays sequences
3 math.private math generic words quotations alien alien.c-types
4 strings sbufs sequences.private slots.private combinators
5 definitions system layouts vectors math.partial-dispatch
6 math.order math.functions accessors hashtables classes assocs
7 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
10 compiler.tree.combinators
13 compiler.tree.normalization
14 compiler.tree.propagation
15 compiler.tree.checker ;
17 : cleaned-up-tree ( quot -- nodes )
18 build-tree normalize propagate cleanup dup check-nodes ;
20 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
22 [ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
24 [ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
26 [ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
28 : recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
30 [ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
32 [ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
34 [ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
36 : inlined? ( quot seq/word -- ? )
37 [ cleaned-up-tree ] dip
38 dup word? [ 1array ] when
39 '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
43 [ { integer } declare >fixnum ]
47 GENERIC: mynot ( x -- y )
51 M: object mynot drop f ;
53 GENERIC: detect-f ( x -- y )
58 [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
61 GENERIC: xyz ( n -- n )
68 [ { integer } declare xyz ] \ xyz inlined?
72 [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
76 : (fx-repeat) ( i n quot: ( i -- i ) -- )
80 [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
81 ] if ; inline recursive
83 : fx-repeat ( n quot -- )
84 0 -rot (fx-repeat) ; inline
86 ! The + should be optimized into fixnum+, if it was not, then
87 ! the type of the loop index was not inferred correctly
89 [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
92 : (i-repeat) ( i n quot: ( i -- i ) -- )
93 2over dup xyz drop >= [
96 [ swap >r call 1+ r> ] keep (i-repeat)
97 ] if ; inline recursive
99 : i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
102 [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
106 [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
110 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
115 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
120 [ { fixnum } declare [ ] times ] \ >= inlined?
124 [ { fixnum } declare [ ] times ] \ 1+ inlined?
128 [ { fixnum } declare [ ] times ] \ + inlined?
132 [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
136 [ { integer fixnum } declare dupd < [ 1 + ] when ]
141 [ { integer fixnum } declare dupd < [ 1 + ] when ]
142 \ +-integer-fixnum inlined?
145 [ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
150 [ 1array dup quotation? [ >quotation ] unless ] times
151 ] \ quotation? inlined?
156 1000000000000000000000000000000000 [ ] times
161 1000000000000000000000000000000000 [ ] times
162 ] \ +-integer-fixnum inlined?
166 [ { bignum } declare [ ] times ]
167 \ +-integer-fixnum inlined?
171 [ { array-capacity } declare 0 < ] \ < inlined?
175 [ { array-capacity } declare 0 < ] \ fixnum< inlined?
179 [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
183 [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
187 [ 5000 [ [ ] times ] each ] \ 1+ inlined?
191 [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
195 GENERIC: annotate-entry-test-1 ( x -- )
197 M: fixnum annotate-entry-test-1 drop ;
199 : (annotate-entry-test-2) ( from to -- )
203 >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
204 ] if ; inline recursive
206 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
209 [ { bignum } declare annotate-entry-test-2 ]
210 \ annotate-entry-test-1 inlined?
214 [ { float } declare 10 [ 2.3 * ] times >float ]
218 GENERIC: detect-float ( a -- b )
220 M: float detect-float ;
223 [ { real float } declare + detect-float ]
224 \ detect-float inlined?
228 [ { float real } declare + detect-float ]
229 \ detect-float inlined?
233 [ { fixnum fixnum } declare 7 bitand neg shift ]
234 \ fixnum-shift-fast inlined?
238 [ { fixnum fixnum } declare 7 bitand neg shift ]
239 { shift fixnum-shift } inlined?
243 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
244 { shift fixnum-shift } inlined?
248 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
249 { fixnum-shift-fast } inlined?
254 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
259 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
260 \ fixnum-shift inlined?
265 [ B{ 1 0 } *short 0 number= ]
270 [ B{ 1 0 } *short 0 { number number } declare number= ]
275 [ B{ 1 0 } *short 0 = ]
280 [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
285 [ HEX: ff bitand 0 HEX: ff between? ]
290 [ HEX: ff swap HEX: ff bitand >= ]
295 [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
311 [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
315 dup 0 > [ 1 - rec ] when ; inline recursive
318 [ { fixnum } declare rec 1 + ]
323 dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
326 [ 27.0 fib ] { < - + } inlined?
330 [ 27.0 fib ] { +-integer-integer } inlined?
334 [ 27 fib ] { < - + } inlined?
338 [ 27 >bignum fib ] { < - + } inlined?
342 [ 27/2 fib ] { < - } inlined?
346 [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
350 [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
354 [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
355 \ fixnum-bitand inlined?
359 [ { fixnum } declare [ drop ] each-integer ]
360 { < <-integer-fixnum +-integer-fixnum + } inlined?
364 [ { fixnum } declare length [ drop ] each-integer ]
365 { < <-integer-fixnum +-integer-fixnum + } inlined?
369 [ { fixnum } declare [ drop ] each ]
370 { < <-integer-fixnum +-integer-fixnum + } inlined?
374 [ { fixnum } declare 0 [ + ] reduce ]
375 { < <-integer-fixnum nth-unsafe } inlined?
379 [ { fixnum } declare 0 [ + ] reduce ]
380 \ +-integer-fixnum inlined?
385 { integer } declare [ ] map
391 { integer } declare { } set-nth-unsafe
397 { integer } declare 1 + { } set-nth-unsafe
403 { array } declare length
404 1 + dup 100 fixnum> [ 1 fixnum+ ] when
409 [ [ resize-array ] keep length ] \ length inlined?
413 [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
417 [ { utf8 } declare decode-char ] \ decode-char inlined?
421 [ { ascii } declare decode-char ] \ decode-char inlined?
424 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
428 { integer } declare [ 0 >= ] map
429 ] { >= fixnum>= } inlined?
434 4 pick array-capacity?
435 [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
436 ] cleaned-up-tree drop
440 [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
446 [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
448 ] cleaned-up-tree drop
452 [ [ 2array ] [ 0 3array ] if first ]
453 { nth-unsafe < <= > >= } inlined?
457 [ [ >r "A" throw r> ] [ "B" throw ] if ]
461 ! Regression from benchmark.nsieve
462 : chicken-fingers ( i seq -- )
467 ] if ; inline recursive
469 : buffalo-wings ( i seq -- )
472 >r 1+ r> buffalo-wings
475 ] if ; inline recursive
478 [ 2 swap >fixnum buffalo-wings ]
479 { <-integer-fixnum +-integer-fixnum } inlined?