1 USING: tools.test kernel.private kernel arrays sequences
2 math.private math generic words quotations alien alien.c-types
3 strings sbufs sequences.private slots.private combinators
4 definitions system layouts vectors math.partial-dispatch
5 math.order math.functions accessors hashtables classes assocs
6 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
7 sorting.private combinators.short-circuit grouping prettyprint
10 compiler.tree.combinators
13 compiler.tree.recursive
14 compiler.tree.normalization
15 compiler.tree.propagation
16 compiler.tree.propagation.info
18 compiler.tree.debugger ;
19 IN: compiler.tree.cleanup.tests
21 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
23 [ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
25 [ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
27 [ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
29 : recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
31 [ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
33 [ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
35 [ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
38 [ { integer } declare >fixnum ]
42 GENERIC: mynot ( x -- y )
46 M: object mynot drop f ;
48 GENERIC: detect-f ( x -- y )
53 [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
56 GENERIC: xyz ( n -- n )
63 [ { integer } declare xyz ] \ xyz inlined?
67 [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
71 : (fx-repeat) ( i n quot: ( i -- i ) -- )
75 [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
76 ] if ; inline recursive
78 : fx-repeat ( n quot -- )
79 0 -rot (fx-repeat) ; inline
81 ! The + should be optimized into fixnum+, if it was not, then
82 ! the type of the loop index was not inferred correctly
84 [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
87 : (i-repeat) ( i n quot: ( i -- i ) -- )
88 2over dup xyz drop >= [
91 [ swap [ call 1 + ] dip ] keep (i-repeat)
92 ] if ; inline recursive
94 : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
97 [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
101 [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
105 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
110 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
115 [ { fixnum } declare [ ] times ] \ >= inlined?
119 [ { fixnum } declare [ ] times ] \ 1+ inlined?
123 [ { fixnum } declare [ ] times ] \ + inlined?
127 [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
131 [ { integer fixnum } declare dupd < [ 1 + ] when ]
136 [ { integer fixnum } declare dupd < [ 1 + ] when ]
137 \ +-integer-fixnum inlined?
143 [ 1array dup quotation? [ >quotation ] unless ] times
144 ] \ quotation? inlined?
149 1000000000000000000000000000000000 [ ] times
154 1000000000000000000000000000000000 [ ] times
155 ] \ +-integer-fixnum inlined?
159 [ { bignum } declare [ ] times ]
160 \ +-integer-fixnum inlined?
164 [ { array-capacity } declare 0 < ] \ < inlined?
168 [ { array-capacity } declare 0 < ] \ fixnum< inlined?
172 [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
176 [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
180 [ 5000 [ [ ] times ] each ] \ 1+ inlined?
184 [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
188 GENERIC: annotate-entry-test-1 ( x -- )
190 M: fixnum annotate-entry-test-1 drop ;
192 : (annotate-entry-test-2) ( from to -- )
196 [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
197 ] if ; inline recursive
199 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
202 [ { bignum } declare annotate-entry-test-2 ]
203 \ annotate-entry-test-1 inlined?
207 [ { float } declare 10 [ 2.3 * ] times >float ]
211 GENERIC: detect-float ( a -- b )
213 M: float detect-float ;
216 [ { real float } declare + detect-float ]
217 \ detect-float inlined?
221 [ { float real } declare + detect-float ]
222 \ detect-float inlined?
226 [ { fixnum fixnum } declare 7 bitand neg shift ]
227 \ fixnum-shift-fast inlined?
231 [ { fixnum fixnum } declare 7 bitand neg shift ]
232 { shift fixnum-shift } inlined?
236 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
237 { shift fixnum-shift } inlined?
241 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
242 { fixnum-shift-fast } inlined?
246 [ 1 swap 7 bitand shift ]
247 { shift fixnum-shift } inlined?
252 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
257 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
258 \ fixnum-shift inlined?
263 [ B{ 1 0 } *short 0 number= ]
268 [ B{ 1 0 } *short 0 { number number } declare number= ]
273 [ B{ 1 0 } *short 0 = ]
278 [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
283 [ HEX: ff bitand 0 HEX: ff between? ]
288 [ HEX: ff swap HEX: ff bitand >= ]
293 [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
309 [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
313 dup 0 > [ 1 - rec ] when ; inline recursive
316 [ { fixnum } declare rec 1 + ]
321 dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
324 [ 27.0 fib ] { < - + } inlined?
328 [ 27.0 fib ] { +-integer-integer } inlined?
332 [ 27 fib ] { < - + } inlined?
336 [ 27 >bignum fib ] { < - + } inlined?
340 [ 27/2 fib ] { < - } inlined?
344 [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
348 [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
352 [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
353 \ fixnum-bitand inlined?
357 [ { fixnum } declare [ drop ] each-integer ]
358 { < <-integer-fixnum +-integer-fixnum + } inlined?
362 [ { fixnum } declare length [ drop ] each-integer ]
363 { < <-integer-fixnum +-integer-fixnum + } inlined?
367 [ { fixnum } declare [ drop ] each ]
368 { < <-integer-fixnum +-integer-fixnum + } inlined?
372 [ { fixnum } declare 0 [ + ] reduce ]
373 { < <-integer-fixnum nth-unsafe } inlined?
377 [ { fixnum } declare 0 [ + ] reduce ]
378 \ +-integer-fixnum inlined?
383 { integer } declare [ ] map
389 { integer } declare { } set-nth-unsafe
395 { integer } declare 1 + { } set-nth-unsafe
401 { array } declare length
402 1 + dup 100 fixnum> [ 1 fixnum+ ] when
407 [ [ resize-array ] keep length ] \ length inlined?
411 [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
415 [ { utf8 } declare decode-char ] \ decode-char inlined?
419 [ { ascii } declare decode-char ] \ decode-char inlined?
422 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
426 { integer } declare [ 0 >= ] map
427 ] { >= fixnum>= } inlined?
432 4 pick array-capacity?
433 [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
434 ] cleaned-up-tree drop
438 [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
444 [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
446 ] cleaned-up-tree drop
450 [ [ 2array ] [ 0 3array ] if first ]
451 { nth-unsafe < <= > >= } inlined?
455 [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
459 ! Regression from benchmark.nsieve
460 : chicken-fingers ( i seq -- )
465 ] if ; inline recursive
467 : buffalo-wings ( i seq -- )
470 [ 1+ ] dip buffalo-wings
473 ] if ; inline recursive
476 [ 2 swap >fixnum buffalo-wings ]
477 { <-integer-fixnum +-integer-fixnum } inlined?
481 : buffalo-sauce ( -- value ) f ;
484 buffalo-sauce [ steak ] when ; inline recursive
492 ] if ; inline recursive
495 [ 2 swap >fixnum ribs ]
496 { <-integer-fixnum +-integer-fixnum } inlined?
500 [ hashtable new ] \ new inlined?
504 [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
505 [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
509 [ { null } declare [ 1 ] [ 2 ] if ]
510 build-tree normalize propagate cleanup check-nodes
514 [ { array } declare 2 <groups> [ . . ] assoc-each ]
515 \ nth-unsafe inlined?
519 [ { fixnum fixnum } declare = ]
520 \ both-fixnums? inlined?
524 [ { integer integer } declare + drop ]
525 { + +-integer-integer } inlined?
545 ] cleaned-up-tree nodes>quot