1 USING: tools.test kernel.private kernel arrays sequences
2 math.private math generic words quotations alien alien.c-types
3 alien.data strings sbufs sequences.private slots.private
4 combinators definitions system layouts vectors
5 math.partial-dispatch math.order math.functions accessors
6 hashtables classes assocs io.encodings.utf8 io.encodings.ascii
7 io.encodings fry slots sorting.private combinators.short-circuit
8 grouping prettyprint generalizations
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 ;
20 QUALIFIED-WITH: alien.c-types c
21 IN: compiler.tree.cleanup.tests
23 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
25 [ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
27 [ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
29 [ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
31 : recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
33 [ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
35 [ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
37 [ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
40 [ { integer } declare >fixnum ]
44 GENERIC: mynot ( x -- y )
46 M: f mynot drop t ; inline
48 M: object mynot drop f ; inline
50 GENERIC: detect-f ( x -- y )
52 M: f detect-f ; inline
55 [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
58 GENERIC: xyz ( n -- n )
60 M: integer xyz ; inline
62 M: object xyz ; inline
65 [ { integer } declare xyz ] \ xyz inlined?
69 [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
73 : (fx-repeat) ( i n quot: ( i -- i ) -- )
77 [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
78 ] if ; inline recursive
80 : fx-repeat ( n quot -- )
81 0 -rot (fx-repeat) ; inline
83 ! The + should be optimized into fixnum+, if it was not, then
84 ! the type of the loop index was not inferred correctly
86 [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
89 : (i-repeat) ( i n quot: ( i -- i ) -- )
90 2over dup xyz drop >= [
93 [ swap [ call 1 + ] dip ] keep (i-repeat)
94 ] if ; inline recursive
96 : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
99 [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
103 [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
107 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
112 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
117 [ { fixnum } declare [ ] times ] \ >= inlined?
121 [ { fixnum } declare [ ] times ] \ + inlined?
125 [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
129 [ { integer fixnum } declare dupd < [ 1 + ] when ]
134 [ { integer fixnum } declare dupd < [ 1 + ] when ]
135 \ +-integer-fixnum inlined?
141 [ 1array dup quotation? [ >quotation ] unless ] times
142 ] \ quotation? inlined?
147 1000000000000000000000000000000000 [ ] times
152 1000000000000000000000000000000000 [ ] times
153 ] \ +-integer-fixnum inlined?
157 [ { bignum } declare [ ] times ]
158 \ +-integer-fixnum inlined?
162 [ { array-capacity } declare 0 < ] \ < inlined?
166 [ { array-capacity } declare 0 < ] \ fixnum< inlined?
170 [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
173 GENERIC: annotate-entry-test-1 ( x -- )
175 M: fixnum annotate-entry-test-1 drop ;
177 : (annotate-entry-test-2) ( from to -- )
181 [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
182 ] if ; inline recursive
184 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
187 [ { bignum } declare annotate-entry-test-2 ]
188 \ annotate-entry-test-1 inlined?
192 [ { float } declare 10 [ 2.3 * ] times >float ]
196 GENERIC: detect-float ( a -- b )
198 M: float detect-float ;
201 [ { real float } declare + detect-float ]
202 \ detect-float inlined?
206 [ { float real } declare + detect-float ]
207 \ detect-float inlined?
211 [ { fixnum fixnum } declare 7 bitand neg shift ]
212 \ fixnum-shift-fast inlined?
216 [ { fixnum fixnum } declare 7 bitand neg shift ]
217 { shift fixnum-shift } inlined?
221 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
222 { shift fixnum-shift } inlined?
226 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
227 { fixnum-shift-fast } inlined?
231 [ 1 swap 7 bitand shift ]
232 { shift fixnum-shift } inlined?
237 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
242 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
243 \ fixnum-shift inlined?
248 [ B{ 1 0 } c:short deref 0 number= ]
253 [ B{ 1 0 } c:short deref 0 { number number } declare number= ]
258 [ B{ 1 0 } c:short deref 0 = ]
263 [ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
268 [ 0xff bitand 0 0xff between? ]
273 [ 0xff swap 0xff bitand >= ]
278 [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
294 dup 0 > [ 1 - rec ] when ; inline recursive
297 [ { fixnum } declare rec 1 + ]
302 dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
305 [ 27.0 fib ] { < - + } inlined?
309 [ 27.0 fib ] { +-integer-integer } inlined?
313 [ 27 fib ] { < - + } inlined?
317 [ 27 >bignum fib ] { < - + } inlined?
321 [ 27/2 fib ] { < - } inlined?
325 [ 10 [ -1 shift ] times ] \ shift inlined?
329 [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
330 \ fixnum-bitand inlined?
334 [ { fixnum } declare [ drop ] each-integer ]
335 { < <-integer-fixnum +-integer-fixnum + } inlined?
339 [ { fixnum } declare iota [ drop ] each ]
340 { < <-integer-fixnum +-integer-fixnum + } inlined?
344 [ { fixnum } declare iota 0 [ + ] reduce ]
345 { < <-integer-fixnum nth-unsafe } inlined?
349 [ { fixnum } declare iota 0 [ + ] reduce ]
350 \ +-integer-fixnum inlined?
355 { integer } declare iota [ ] map
356 ] \ integer>fixnum inlined?
361 { integer } declare { } set-nth-unsafe
362 ] \ integer>fixnum inlined?
367 { integer } declare 1 + { } set-nth-unsafe
373 { array } declare length
374 1 + dup 100 fixnum> [ 1 fixnum+ ] when
379 [ [ resize-array ] keep length ] \ length inlined?
383 [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
387 [ { utf8 } declare decode-char ] \ decode-char inlined?
391 [ { ascii } declare decode-char ] \ decode-char inlined?
394 [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
398 { integer } declare iota [ 0 >= ] map
399 ] { >= fixnum>= } inlined?
404 4 pick array-capacity?
405 [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
406 ] cleaned-up-tree drop
410 [ { merge-state } declare accum>> 0 >>length ] cleaned-up-tree drop
416 [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
418 ] cleaned-up-tree drop
422 [ [ 2array ] [ 0 3array ] if first ]
423 { nth-unsafe < <= > >= } inlined?
427 [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
431 ! Regression from benchmark.nsieve
432 : chicken-fingers ( i seq -- )
437 ] if ; inline recursive
439 : buffalo-wings ( i seq -- )
442 [ 1 + ] dip buffalo-wings
445 ] if ; inline recursive
448 [ 2 swap >fixnum buffalo-wings ]
449 { <-integer-fixnum +-integer-fixnum } inlined?
453 : buffalo-sauce ( -- value ) f ;
456 buffalo-sauce [ steak ] when ; inline recursive
464 ] if ; inline recursive
467 [ 2 swap >fixnum ribs ]
468 { <-integer-fixnum +-integer-fixnum } inlined?
472 [ hashtable new ] \ new inlined?
476 [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
477 [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
481 [ { null } declare [ 1 ] [ 2 ] if ]
482 build-tree normalize propagate cleanup-tree check-nodes
486 [ { array } declare 2 <groups> [ . . ] assoc-each ]
487 \ nth-unsafe inlined?
491 [ { fixnum fixnum } declare = ]
492 \ both-fixnums? inlined?
496 [ { integer integer } declare + drop ]
497 { + +-integer-integer } inlined?
517 ] cleaned-up-tree nodes>quot
521 [ int { } cdecl [ 2 2 + ] alien-callback ]
526 [ double { double double } cdecl [ + ] alien-callback ]
531 [ double { double double } cdecl [ + ] alien-callback ]
536 [ char { char char } cdecl [ + ] alien-callback ]
537 \ fixnum+fast inlined?
541 [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]