1 USING: generalizations accessors arrays compiler kernel
2 kernel.private math hashtables.private math.private namespaces
3 sequences tools.test namespaces.private slots.private
4 sequences.private byte-arrays alien alien.accessors layouts
5 words definitions compiler.units io combinators vectors grouping
6 make alien.c-types combinators.short-circuit math.order
7 math.libm math.parser math.functions alien.syntax ;
9 QUALIFIED: namespaces.private
10 IN: compiler.tests.codegen
12 ! Originally, this file did black box testing of templating
13 ! optimization. We now have a different codegen, but the tests
14 ! in here are still useful.
17 [ 5000 ] [ [ 5000 ] compile-call ] unit-test
18 [ "hi" ] [ [ "hi" ] compile-call ] unit-test
20 [ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
22 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
23 [ 0 ] [ 3 [ tag ] compile-call ] unit-test
24 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
26 [ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
28 [ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
30 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
32 [ { 1 2 3 } { 1 4 3 } 2 2 ]
33 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
36 ! Test literals in either side of a shuffle
37 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
39 [ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
44 [ 1.2 [ tag [ foo ] keep ] compile-call ]
48 [ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
53 global [ 3 \ foo set ] bind
54 \ foo [ global >n get namespaces.private:ndrop ] compile-call
57 : blech ( x -- ) drop ;
61 global [ 3 \ foo set ] bind
62 \ foo [ global [ get ] swap blech call ] compile-call
67 global [ 3 \ foo set ] bind
68 \ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
73 global [ 3 \ foo set ] bind
74 \ foo [ global [ get ] bind ] compile-call
78 -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
81 [ -1 2 ] [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
84 -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
88 SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
92 [ 3 1 2 3 4 5 6 7 8 9 ] [
94 [ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
98 [ 2 2 2 2 2 2 2 2 2 2 1 ] [
100 [ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
103 [ ] [ [ 9 [ ] times ] compile-call ] unit-test
107 [ 200 dup [ 200 3array ] curry map drop ] times
108 ] [ (( n -- )) define-temp ] with-compilation-unit drop
111 ! Test how dispatch handles the end of a basic block
112 : try-breaking-dispatch ( n a b -- x str )
113 float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
115 : try-breaking-dispatch-2 ( -- ? )
116 1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
119 10000000 [ drop try-breaking-dispatch-2 ] all?
123 : (broken) ( x -- y ) ;
125 [ 2.0 { 2.0 0.0 } ] [
127 [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
131 : hellish-bug-1 ( a b -- ) 2drop ;
133 : hellish-bug-2 ( i array x -- x )
134 2dup 1 slot eq? [ 2drop ] [
135 2dup array-nth tombstone? [
137 [ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
138 pick 2dup hellish-bug-1 3drop
140 ] unless [ 2 fixnum+fast ] dip hellish-bug-2
141 ] if ; inline recursive
143 : hellish-bug-3 ( hash array -- )
144 0 swap hellish-bug-2 drop ;
147 H{ { 1 2 } { 3 4 } } dup array>>
148 [ 0 swap hellish-bug-2 drop ] compile-call
152 : foox ( obj -- obj )
154 [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
156 [ 3 ] [ f foox ] unit-test
160 [ 4 ] [ T{ my-tuple } foox ] unit-test
162 [ 5 ] [ "hi" foox ] unit-test
164 ! Making sure we don't needlessly unbox/rebox
165 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
167 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
169 [ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
173 { byte-array } declare
174 [ 0 alien-unsigned-1 ] keep
181 [ 0 alien-unsigned-1 ] keep hi-tag
182 ] compile-call byte-array type-number =
189 ] compile-call alien type-number =
194 [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
198 : a-dummy ( a -- ) drop "hi" print ;
202 dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
208 ] [ 2drop no-case ] if
213 : dispatch-alignment-regression ( -- c )
214 { tuple vector } 3 slot { word } declare
215 dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
217 [ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
219 [ vector ] [ dispatch-alignment-regression ] unit-test
222 : bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
224 [ { f f f } ] [ t bad-value-bug ] unit-test
229 : (gc-check-bug) ( a b -- c )
230 { [ id boa ] [ id boa ] } dispatch ;
232 : gc-check-bug ( -- )
233 10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
235 [ ] [ gc-check-bug ] unit-test
238 : test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
240 [ "a" ] [ 8 test-1 ] unit-test
241 [ "b" ] [ 9 test-1 ] unit-test
243 : test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
245 [ "a" ] [ 1 test-2 ] unit-test
246 [ "b" ] [ 2 test-2 ] unit-test
248 ! I accidentally fixnum/i-fast on PowerPC
249 [ { { 1 2 } { 3 4 } } ] [
252 [ { array } declare 2 <groups> [ , ] each ] compile-call
258 [ { array } declare 2 <groups> length ] compile-call
261 ! Oops with new intrinsics
262 : fixnum-overflow-control-flow-test ( a b -- c )
263 [ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
265 [ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
266 [ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
270 { float } declare dup 0 =
273 [ 2 double "libm" "pow" { double double } alien-invoke ]
274 [ -0.5 double "libm" "pow" { double double } alien-invoke ]
278 [ 4.0 ] [ 2.0 blah ] unit-test
280 [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
281 [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
285 M: cucumber equal? "The cucumber has no equal" throw ;
287 [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
289 [ 4294967295 B{ 255 255 255 255 } -1 ]
292 [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
296 ! Regression found while working on global register allocation
298 : linear-scan-regression-1 ( a b c -- ) 3array , ;
299 : linear-scan-regression-2 ( a b -- ) 2array , ;
301 : linear-scan-regression ( a b c -- )
302 [ linear-scan-regression-2 ]
303 [ linear-scan-regression-1 ]
304 bi-curry bi-curry interleave ;
315 [ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
318 ! Regression from Doug's value numbering changes
319 [ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
320 [ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
323 [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
326 ! Regression from Slava's value numbering changes
327 [ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
329 ! Bug with ##return node construction
330 : return-recursive-bug ( nodes -- ? )
332 dup 3 bitand 1 = [ drop t ] [
337 ] any? ; inline recursive
339 [ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test
341 ! Coalescing reductions
342 [ f ] [ V{ } 0 [ [ vector? ] both? ] compile-call ] unit-test
343 [ f ] [ 0 V{ } [ [ vector? ] both? ] compile-call ] unit-test
347 [ dup [ \ vector eq? ] [ drop f ] if ] dip
348 dup [ \ vector eq? ] [ drop f ] if
349 over rot [ drop ] [ nip ] if
353 ! Coalesing bug reduced from sequence-parser:take-sequence
354 : coalescing-bug-1 ( a b c d -- a b c d )
357 [ [ drop ] 2dip length > ]
359 } 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ;
361 [ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
362 [ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test
363 [ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
364 [ 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test
366 ! Another one, found by Dan
367 : coalescing-bug-2 ( a -- b )
368 dup dup 10 fixnum< [ 1 fixnum+fast ] when
369 fixnum+fast 2 fixnum*fast 2 fixnum-fast 2 fixnum*fast 2 fixnum+fast ;
371 [ 10 ] [ 1 coalescing-bug-2 ] unit-test
372 [ 86 ] [ 11 coalescing-bug-2 ] unit-test
374 ! Regression in suffix-arrays code
375 : coalescing-bug-3 ( from/f to/f seq -- slice )
377 [ drop 0 or ] [ length or ] bi-curry bi*
381 [ T{ slice f 0 5 "hello" } ] [ f f "hello" coalescing-bug-3 ] unit-test
382 [ T{ slice f 1 5 "hello" } ] [ 1 f "hello" coalescing-bug-3 ] unit-test
383 [ T{ slice f 0 3 "hello" } ] [ f 3 "hello" coalescing-bug-3 ] unit-test
384 [ T{ slice f 1 3 "hello" } ] [ 1 3 "hello" coalescing-bug-3 ] unit-test
385 [ T{ slice f 3 3 "hello" } ] [ 4 3 "hello" coalescing-bug-3 ] unit-test
386 [ T{ slice f 5 5 "hello" } ] [ 6 f "hello" coalescing-bug-3 ] unit-test
389 : coalescing-bug-4 ( a b c -- a b c )
390 [ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
392 [ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
393 [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
394 [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
395 [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
396 [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
397 [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
399 ! Global stack analysis dataflow equations are wrong
400 : some-word ( a -- b ) 2 + ;
401 : global-dcn-bug-1 ( a b -- c d )
402 dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if
403 dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
405 [ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
406 [ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test
409 : missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
410 : missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
412 [ ] [ missing-gc-check-2 ] unit-test
414 [ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
415 [ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
416 [ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
417 [ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
419 [ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
421 ! Bug in linearization
422 [ 283686952174081 ] [
424 { byte-array } declare
429 swap 1 < [ [ ] dip ] [ [ ] dip ] if
436 ! Bug in CSSA construction
437 TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
441 T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } }
442 T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ?
448 over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if
449 swap 4 * >fixnum alien-signed-4
451 ] 2curry each-integer
455 ! Bug in linear scan's partial sync point logic
457 [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
458 1.168852488727981 1.e-9 ~
462 [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
465 ! ##box-displaced-alien is a def-is-use instruction
469 100 [ 10 swap <displaced-alien> ] times
470 1 swap <displaced-alien>
474 ! Forgot to two-operand shifts
477 [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call