-IN: compiler.tree.cleanup.tests
USING: tools.test kernel.private kernel arrays sequences
math.private math generic words quotations alien alien.c-types
-strings sbufs sequences.private slots.private combinators
-definitions system layouts vectors math.partial-dispatch
-math.order math.functions accessors hashtables classes assocs
-io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private combinators.short-circuit grouping prettyprint
+alien.data strings sbufs sequences.private slots.private
+combinators definitions system layouts vectors
+math.partial-dispatch math.order math.functions accessors
+hashtables classes assocs io.encodings.utf8 io.encodings.ascii
+io.encodings fry slots sorting.private combinators.short-circuit
+grouping prettyprint generalizations
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
+FROM: math => float ;
+QUALIFIED-WITH: alien.c-types c
+IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
GENERIC: mynot ( x -- y )
-M: f mynot drop t ;
+M: f mynot drop t ; inline
-M: object mynot drop f ;
+M: object mynot drop f ; inline
GENERIC: detect-f ( x -- y )
-M: f detect-f ;
+M: f detect-f ; inline
[ t ] [
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
GENERIC: xyz ( n -- n )
-M: integer xyz ;
+M: integer xyz ; inline
-M: object xyz ;
+M: object xyz ; inline
[ t ] [
[ { integer } declare xyz ] \ xyz inlined?
2over dup xyz drop >= [
3drop
] [
- [ swap [ call 1+ ] dip ] keep (i-repeat)
+ [ swap [ call 1 + ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ { fixnum } declare [ ] times ] \ >= inlined?
] unit-test
-[ t ] [
- [ { fixnum } declare [ ] times ] \ 1+ inlined?
-] unit-test
-
[ t ] [
[ { fixnum } declare [ ] times ] \ + inlined?
] unit-test
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
] unit-test
-[ t ] [
- [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 [ [ ] times ] each ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
- \ 1+ inlined?
-] unit-test
-
GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
2dup >= [
2drop
] [
- [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
+ [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
{ fixnum-shift-fast } inlined?
] unit-test
+[ t ] [
+ [ 1 swap 7 bitand shift ]
+ { shift fixnum-shift } inlined?
+] unit-test
+
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
] when
[ t ] [
- [ B{ 1 0 } *short 0 number= ]
+ [ B{ 1 0 } c:short deref 0 number= ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short 0 { number number } declare number= ]
+ [ B{ 1 0 } c:short deref 0 { number number } declare number= ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short 0 = ]
+ [ B{ 1 0 } c:short deref 0 = ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+ [ B{ 1 0 } c:short deref dup number? [ 0 number= ] [ drop f ] if ]
\ number= inlined?
] unit-test
[ t ] [
- [ HEX: ff bitand 0 HEX: ff between? ]
+ [ 0xff bitand 0 0xff between? ]
\ >= inlined?
] unit-test
[ t ] [
- [ HEX: ff swap HEX: ff bitand >= ]
+ [ 0xff swap 0xff bitand >= ]
\ >= inlined?
] unit-test
] \ + inlined?
] unit-test
-[ t ] [
- [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
-] unit-test
-
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline recursive
] unit-test
[ t ] [
- [ { fixnum } declare length [ drop ] each-integer ]
- { < <-integer-fixnum +-integer-fixnum + } inlined?
-] unit-test
-
-[ t ] [
- [ { fixnum } declare [ drop ] each ]
+ [ { fixnum } declare iota [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
- [ { fixnum } declare 0 [ + ] reduce ]
+ [ { fixnum } declare iota 0 [ + ] reduce ]
{ < <-integer-fixnum nth-unsafe } inlined?
] unit-test
[ f ] [
- [ { fixnum } declare 0 [ + ] reduce ]
+ [ { fixnum } declare iota 0 [ + ] reduce ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [
[
- { integer } declare [ ] map
+ { integer } declare iota [ ] map
] \ >fixnum inlined?
] unit-test
[ t ] [
[
- { integer } declare [ 0 >= ] map
+ { integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
- [ 1+ ] dip buffalo-wings
+ [ 1 + ] dip buffalo-wings
] [
2drop
] if ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
- [ 1+ ] dip ribs
+ [ 1 + ] dip ribs
] [
2drop
] if ; inline recursive
] unit-test
[ t ] [
- [ { array } declare 2 <groups> [ . . ] assoc-each ]
+ [ { array } declare 2 <sliced-groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test
+
+[ [ ] ] [
+ [
+ 20 f <array>
+ [ 0 swap nth ] keep
+ [ 1 swap nth ] keep
+ [ 2 swap nth ] keep
+ [ 3 swap nth ] keep
+ [ 4 swap nth ] keep
+ [ 5 swap nth ] keep
+ [ 6 swap nth ] keep
+ [ 7 swap nth ] keep
+ [ 8 swap nth ] keep
+ [ 9 swap nth ] keep
+ [ 10 swap nth ] keep
+ [ 11 swap nth ] keep
+ [ 12 swap nth ] keep
+ 14 ndrop
+ ] cleaned-up-tree nodes>quot
+] unit-test
+
+[ t ] [
+ [ int { } cdecl [ 2 2 + ] alien-callback ]
+ { + } inlined?
+] unit-test
+
+[ t ] [
+ [ double { double double } cdecl [ + ] alien-callback ]
+ \ + inlined?
+] unit-test
+
+[ f ] [
+ [ double { double double } cdecl [ + ] alien-callback ]
+ \ float+ inlined?
+] unit-test
+
+[ f ] [
+ [ char { char char } cdecl [ + ] alien-callback ]
+ \ fixnum+fast inlined?
+] unit-test
+
+[ t ] [
+ [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
+ \ >c-ptr inlined?
+] unit-test