1 ! Black box testing of templating optimization
2 USING: accessors arrays compiler kernel kernel.private math
3 hashtables.private math.private namespaces sequences
4 sequences.private tools.test namespaces.private slots.private
5 sequences.private byte-arrays alien alien.accessors layouts
6 words definitions compiler.units io combinators vectors ;
10 [ 5000 ] [ [ 5000 ] compile-call ] unit-test
11 [ "hi" ] [ [ "hi" ] compile-call ] unit-test
13 [ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
15 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
16 [ 0 ] [ 3 [ tag ] compile-call ] unit-test
17 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
19 [ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
21 [ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
23 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
25 [ { 1 2 3 } { 1 4 3 } 3 3 ]
26 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
29 ! Test literals in either side of a shuffle
30 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
32 [ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
37 [ 1.2 [ tag [ foo ] keep ] compile-call ]
41 [ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
46 global [ 3 \ foo set ] bind
47 \ foo [ global >n get ndrop ] compile-call
54 global [ 3 \ foo set ] bind
55 \ foo [ global [ get ] swap blech call ] compile-call
60 global [ 3 \ foo set ] bind
61 \ foo [ global [ get ] swap >n call ndrop ] compile-call
66 global [ 3 \ foo set ] bind
67 \ foo [ global [ get ] bind ] compile-call
71 -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
74 [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
77 -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
81 SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
85 [ 3 1 2 3 4 5 6 7 8 9 ] [
87 [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
91 [ 2 2 2 2 2 2 2 2 2 2 1 ] [
93 [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
96 [ ] [ [ 9 [ ] times ] compile-call ] unit-test
100 [ 200 dup [ 200 3array ] curry map drop ] times
101 ] [ define-temp ] with-compilation-unit drop
105 ! Test how dispatch handles the end of a basic block
106 : try-breaking-dispatch ( n a b -- a b str )
107 float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
109 : try-breaking-dispatch-2 ( -- ? )
110 1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
113 10000000 [ drop try-breaking-dispatch-2 ] all?
117 : (broken) ( x -- y ) ;
119 [ 2.0 { 2.0 0.0 } ] [
121 [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
125 : hellish-bug-1 2drop ;
127 : hellish-bug-2 ( i array x -- x )
128 2dup 1 slot eq? [ 2drop ] [
129 2dup array-nth tombstone? [
131 [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
132 pick 2dup hellish-bug-1 3drop
134 ] unless >r 2 fixnum+fast r> hellish-bug-2
137 : hellish-bug-3 ( hash array -- )
138 0 swap hellish-bug-2 drop ;
141 H{ { 1 2 } { 3 4 } } dup array>>
142 [ 0 swap hellish-bug-2 drop ] compile-call
146 : foox ( obj -- obj )
148 [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
150 [ 3 ] [ f foox ] unit-test
154 [ 4 ] [ T{ my-tuple } foox ] unit-test
156 [ 5 ] [ "hi" foox ] unit-test
158 ! Making sure we don't needlessly unbox/rebox
159 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
161 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
163 [ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
167 { byte-array } declare
168 [ 0 alien-unsigned-1 ] keep
175 [ 0 alien-unsigned-1 ] keep hi-tag
176 ] compile-call byte-array type-number =
183 ] compile-call alien type-number =
188 [ 2dup fixnum< [ >r die r> ] when ] compile-call
192 : a-dummy ( -- ) drop "hi" print ;
196 dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
202 ] [ 2drop no-case ] if
206 : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
248 [ t ] [ \ float-spill-bug compiled>> ] unit-test
251 : dispatch-alignment-regression ( -- c )
252 { tuple vector } 3 slot { word } declare
253 dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
255 [ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
257 [ vector ] [ dispatch-alignment-regression ] unit-test