1 USING: accessors alien alien.c-types alien.data arrays assocs
2 combinators combinators.short-circuit compiler.tree
3 compiler.tree.builder compiler.tree.checker compiler.tree.cleanup
4 compiler.tree.combinators compiler.tree.debugger
5 compiler.tree.normalization compiler.tree.propagation
6 compiler.tree.propagation.info generalizations grouping hashtables
7 io.encodings io.encodings.ascii io.encodings.utf8 kernel
8 kernel.private layouts math math.functions math.intervals math.order
9 math.partial-dispatch math.private prettyprint quotations sequences
10 sequences.private slots slots.private sorting.private tools.test
13 QUALIFIED-WITH: alien.c-types c
14 IN: compiler.tree.cleanup.tests
16 { t } [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
18 { f } [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
20 { f } [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
22 { t } [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
24 : recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
26 { t } [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
28 { f } [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
30 { t } [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
33 [ { integer } declare >fixnum ]
37 GENERIC: mynot ( x -- y )
39 M: f mynot drop t ; inline
41 M: object mynot drop f ; inline
43 GENERIC: detect-f ( x -- y )
45 M: f detect-f ; inline
48 [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
51 GENERIC: xyz ( n -- n )
53 M: integer xyz ; inline
55 M: object xyz ; inline
58 [ { integer } declare xyz ] \ xyz inlined?
62 [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
66 : (fx-repeat) ( i n quot: ( i -- i ) -- )
70 [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
71 ] if ; inline recursive
73 : fx-repeat ( n quot -- )
74 0 -rot (fx-repeat) ; inline
76 ! The + should be optimized into fixnum+, if it was not, then
77 ! the type of the loop index was not inferred correctly
79 [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
82 : (i-repeat) ( i n quot: ( i -- i ) -- )
83 2over dup xyz drop >= [
86 [ swap [ call 1 + ] dip ] keep (i-repeat)
87 ] if ; inline recursive
89 : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
92 [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
96 [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
100 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
105 [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
110 [ { fixnum } declare [ ] times ] \ >= inlined?
114 [ { fixnum } declare [ ] times ] \ + inlined?
118 [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
122 [ { integer fixnum } declare dupd < [ 1 + ] when ]
127 [ { integer fixnum } declare dupd < [ 1 + ] when ]
128 \ +-integer-fixnum inlined?
134 [ 1array dup quotation? [ >quotation ] unless ] times
135 ] \ quotation? inlined?
140 1000000000000000000000000000000000 [ ] times
145 1000000000000000000000000000000000 [ ] times
146 ] \ +-integer-fixnum inlined?
150 [ { bignum } declare [ ] times ]
151 \ +-integer-fixnum inlined?
155 [ { array-capacity } declare 0 < ] \ < inlined?
159 [ { array-capacity } declare 0 < ] \ fixnum< inlined?
163 [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
166 GENERIC: annotate-entry-test-1 ( x -- )
168 M: fixnum annotate-entry-test-1 drop ;
170 : (annotate-entry-test-2) ( from to -- )
174 [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
175 ] if ; inline recursive
177 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
180 [ { bignum } declare annotate-entry-test-2 ]
181 \ annotate-entry-test-1 inlined?
185 [ { float } declare 10 [ 2.3 * ] times >float ]
189 GENERIC: detect-float ( a -- b )
191 M: float detect-float ;
194 [ { real float } declare + detect-float ]
195 \ detect-float inlined?
199 [ { float real } declare + detect-float ]
200 \ detect-float inlined?
204 [ { fixnum fixnum } declare 7 bitand neg shift ]
205 \ fixnum-shift-fast inlined?
209 [ { fixnum fixnum } declare 7 bitand neg shift ]
210 { shift fixnum-shift } inlined?
214 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
215 { shift fixnum-shift } inlined?
219 [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
220 { fixnum-shift-fast } inlined?
224 [ 1 swap 7 bitand shift ]
225 { shift fixnum-shift } inlined?
230 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
235 [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
236 \ fixnum-shift inlined?
241 [ B{ 1 0 } c:short deref 0 number= ]
246 [ B{ 1 0 } c:short deref 0 { number number } declare number= ]
251 [ B{ 1 0 } c:short deref 0 = ]
256 [ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
261 [ 0xff bitand 0 0xff between? ]
266 [ 0xff swap 0xff bitand >= ]
271 [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
287 dup 0 > [ 1 - rec ] when ; inline recursive
290 [ { fixnum } declare rec 1 + ]
295 dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
298 [ 27.0 fib ] { < - + } inlined?
302 [ 27.0 fib ] { +-integer-integer } inlined?
306 [ 27 fib ] { < - + } inlined?
310 [ 27 >bignum fib ] { < - + } inlined?
314 [ 27/2 fib ] { < - } inlined?
318 [ 10 [ -1 shift ] times ] \ shift inlined?
322 [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
323 \ fixnum-bitand inlined?
327 [ { fixnum } declare [ drop ] each-integer ]
328 { < <-integer-fixnum +-integer-fixnum + } inlined?
332 [ { fixnum } declare iota [ drop ] each ]
333 { < <-integer-fixnum +-integer-fixnum + } inlined?
337 [ { fixnum } declare iota 0 [ + ] reduce ]
338 { < <-integer-fixnum nth-unsafe } inlined?
342 [ { fixnum } declare iota 0 [ + ] reduce ]
343 \ +-integer-fixnum inlined?
348 { integer } declare iota [ ] map
349 ] \ integer>fixnum inlined?
354 { integer } declare { } set-nth-unsafe
355 ] \ integer>fixnum inlined?
360 { integer } declare 1 + { } set-nth-unsafe
366 { array } declare length
367 1 + dup 100 fixnum> [ 1 fixnum+ ] when
372 [ [ resize-array ] keep length ] \ length inlined?
376 [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
380 [ { utf8 } declare decode-char ] \ decode-char inlined?
384 [ { ascii } declare decode-char ] \ decode-char inlined?
387 { t } [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
391 { integer } declare iota [ 0 >= ] map
392 ] { >= fixnum>= } inlined?
397 4 pick array-capacity?
398 [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
399 ] cleaned-up-tree drop
403 [ { merge-state } declare accum>> 0 >>length ] cleaned-up-tree drop
409 [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
411 ] cleaned-up-tree drop
415 [ [ 2array ] [ 0 3array ] if first ]
416 { nth-unsafe < <= > >= } inlined?
420 [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
424 ! Regression from benchmark.nsieve
425 : chicken-fingers ( i seq -- )
430 ] if ; inline recursive
432 : buffalo-wings ( i seq -- )
435 [ 1 + ] dip buffalo-wings
438 ] if ; inline recursive
441 [ 2 swap >fixnum buffalo-wings ]
442 { <-integer-fixnum +-integer-fixnum } inlined?
446 : buffalo-sauce ( -- value ) f ;
449 buffalo-sauce [ steak ] when ; inline recursive
457 ] if ; inline recursive
460 [ 2 swap >fixnum ribs ]
461 { <-integer-fixnum +-integer-fixnum } inlined?
465 [ hashtable new ] \ new inlined?
469 [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
470 [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
474 [ { null } declare [ 1 ] [ 2 ] if ]
475 build-tree normalize propagate cleanup-tree check-nodes
479 [ { array } declare 2 <groups> [ . . ] assoc-each ]
480 \ nth-unsafe inlined?
484 [ { fixnum fixnum } declare = ]
485 \ both-fixnums? inlined?
489 [ { integer integer } declare + drop ]
490 { + +-integer-integer } inlined?
510 ] cleaned-up-tree nodes>quot
514 [ int { } cdecl [ 2 2 + ] alien-callback ]
519 [ double { double double } cdecl [ + ] alien-callback ]
524 [ double { double double } cdecl [ + ] alien-callback ]
529 [ char { char char } cdecl [ + ] alien-callback ]
530 \ fixnum+fast inlined?
534 [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
541 : call-node-foldable2 ( -- node )
544 { in-d V{ 8815401 } }
545 { out-d { 8815405 } }
567 { class POSTPONE: f }
579 call-node-foldable2 cleanup-folding?
584 : call-node-foldable ( -- node )
620 call-node-foldable cleanup-folding
621 [ length 2 = ] [ last literal>> 5 = ] bi