diff options
author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
---|---|---|
committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/cps | |
parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/cps')
31 files changed, 413 insertions, 0 deletions
diff --git a/testsuite/tests/cps/all.T b/testsuite/tests/cps/all.T new file mode 100644 index 0000000000..0bfc49254c --- /dev/null +++ b/testsuite/tests/cps/all.T @@ -0,0 +1,35 @@ +# Leave these off until the CPS pass is finished and integrated. +# +# These tests are not in their final format yet, but they provide +# a starting point. + +test('cmm001', skip, compile, ['-O -fasm -ddump-cps-cmm']) +test('cmm002', skip, compile, ['-fasm -ddump-cps-cmm']) + +test('cps001', skip, compile, ['-ddump-cps-cmm']) +test('cps002', skip, compile, ['-ddump-cps-cmm']) +test('cps003', skip, compile, ['-ddump-cps-cmm']) +test('cps004', skip, compile, ['-ddump-cps-cmm']) +test('cps005', skip, compile, ['-ddump-cps-cmm']) +test('cps006', skip, compile, ['-ddump-cps-cmm']) +test('cps007', skip, compile, ['-ddump-cps-cmm']) +test('cps008', skip, compile, ['-ddump-cps-cmm']) +test('cps009', skip, compile, ['-ddump-cps-cmm']) +test('cps010', skip, compile, ['-ddump-cps-cmm']) +test('cps011', skip, compile, ['-ddump-cps-cmm']) +test('cps012', skip, compile, ['-ddump-cps-cmm']) +test('cps013', skip, compile, ['-ddump-cps-cmm']) +test('cps014', skip, compile, ['-ddump-cps-cmm']) +test('cps015', skip, compile, ['-ddump-cps-cmm']) +test('cps016', skip, compile, ['-ddump-cps-cmm']) +test('cps017', skip, compile, ['-ddump-cps-cmm']) +test('cps018', skip, compile, ['-ddump-cps-cmm']) +test('cps019', skip, compile, ['-ddump-cps-cmm']) +test('cps020', skip, compile, ['-ddump-cps-cmm']) +test('cps021', skip, compile, ['-ddump-cps-cmm']) +test('cps022', skip, compile, ['-ddump-cps-cmm']) +test('cps023', skip, compile, ['-ddump-cps-cmm']) +test('cps024', skip, compile, ['-ddump-cps-cmm']) +test('cps025', skip, compile, ['-ddump-cps-cmm']) +test('cps026', skip, compile, ['-ddump-cps-cmm']) + diff --git a/testsuite/tests/cps/cmm001.cmm b/testsuite/tests/cps/cmm001.cmm new file mode 100644 index 0000000000..490a3c938d --- /dev/null +++ b/testsuite/tests/cps/cmm001.cmm @@ -0,0 +1,5 @@ +// This puts GHC into an infinite loop(!) when -O is on + +foo { + L: goto L; +} diff --git a/testsuite/tests/cps/cmm002.cmm b/testsuite/tests/cps/cmm002.cmm new file mode 100644 index 0000000000..bf3e0d4c6e --- /dev/null +++ b/testsuite/tests/cps/cmm002.cmm @@ -0,0 +1,8 @@ +// Reduced cps012.cmm to the key part that makes it crash +// in RegisterAlloc.joinToTargets + +stg_ap_0_fast { + bits32 y, x; + c7: y = bits32[x]; + goto c7; +} diff --git a/testsuite/tests/cps/cps001.cmm b/testsuite/tests/cps/cps001.cmm new file mode 100644 index 0000000000..72ab24b631 --- /dev/null +++ b/testsuite/tests/cps/cps001.cmm @@ -0,0 +1,9 @@ +// Basic function with a call + +foo1 { + bits32 x; + B: + foreign "C--" bar() "safe"; + x = 3; + goto B; +} diff --git a/testsuite/tests/cps/cps002.cmm b/testsuite/tests/cps/cps002.cmm new file mode 100644 index 0000000000..8919820c32 --- /dev/null +++ b/testsuite/tests/cps/cps002.cmm @@ -0,0 +1,7 @@ +// Basic function with a call + +foo1 { + B: + foreign "C--" bar() "safe"; + goto B; +} diff --git a/testsuite/tests/cps/cps003.cmm b/testsuite/tests/cps/cps003.cmm new file mode 100644 index 0000000000..dba506f9d3 --- /dev/null +++ b/testsuite/tests/cps/cps003.cmm @@ -0,0 +1,15 @@ +// Basic function with a heap check +// The GC block should only be one instruction +// (or rather it should be after assignment optimizations) + +foo1 { + bits32 r; + B: + (r) = foreign "C--" bar() "safe"; + L: + if (Hp > HpLim) { + (r) = foreign "C--" stg_gc_ret_p(r) "safe"; + goto L; + } + return (r); +} diff --git a/testsuite/tests/cps/cps004.cmm b/testsuite/tests/cps/cps004.cmm new file mode 100644 index 0000000000..e6079a0464 --- /dev/null +++ b/testsuite/tests/cps/cps004.cmm @@ -0,0 +1,17 @@ +// Test basic function parameters and return values + +foo2 (bits16 a, bits16 b, "ptr" bits16 c) { + bits32 x, y; + x = R1; + (y) = foreign "C--" bar(x) "safe"; + goto L; + L: + foreign "C--" baz(x) "safe"; + //jump 12; + goto M; + M: + return (12); + //goto L; + //goto L; +} + diff --git a/testsuite/tests/cps/cps005.cmm b/testsuite/tests/cps/cps005.cmm new file mode 100644 index 0000000000..d40dd93404 --- /dev/null +++ b/testsuite/tests/cps/cps005.cmm @@ -0,0 +1,7 @@ +// Basic test of return + +foo3 { + foreign "C--" glap() "safe"; + return (12); +} + diff --git a/testsuite/tests/cps/cps006.cmm b/testsuite/tests/cps/cps006.cmm new file mode 100644 index 0000000000..c04b4279ad --- /dev/null +++ b/testsuite/tests/cps/cps006.cmm @@ -0,0 +1,7 @@ +// Basic test of return with extra block + +foo4{ +B: + foreign "C--" palg() "safe"; + return (14); +} diff --git a/testsuite/tests/cps/cps007.cmm b/testsuite/tests/cps/cps007.cmm new file mode 100644 index 0000000000..984bb628be --- /dev/null +++ b/testsuite/tests/cps/cps007.cmm @@ -0,0 +1,4 @@ +// Test that empty functions stay empty (and stay alive) + +foo5 { +} diff --git a/testsuite/tests/cps/cps008.cmm b/testsuite/tests/cps/cps008.cmm new file mode 100644 index 0000000000..cdd8ac8a66 --- /dev/null +++ b/testsuite/tests/cps/cps008.cmm @@ -0,0 +1,9 @@ +// Test basic general case for heap check + +foo6_gc_slow { + if (Hp + 5 > HpLim) { + foreign "C--" do_gc_gen() "safe"; + jump foo6_gc_slow(1, 2, 3); + } + return (7); +} diff --git a/testsuite/tests/cps/cps009.cmm b/testsuite/tests/cps/cps009.cmm new file mode 100644 index 0000000000..581356c0bc --- /dev/null +++ b/testsuite/tests/cps/cps009.cmm @@ -0,0 +1,7 @@ +// Test basic stack check + +foo6_gc_slow("ptr" bits32 f) goto GC { + return (7); +GC: + jump stg_gc_fun_v(f); +} diff --git a/testsuite/tests/cps/cps010.cmm b/testsuite/tests/cps/cps010.cmm new file mode 100644 index 0000000000..0b0ec9ebc4 --- /dev/null +++ b/testsuite/tests/cps/cps010.cmm @@ -0,0 +1,9 @@ +// Test general stack check +// Note, the GC block shouldn't trigger the stack limit + +foo6_gc_slow("ptr" bits32 f, bits32 x) goto GC { + return (7); +GC: + foreign "C--" stg_gc_gen() "safe"; + jump foo6_gc_slow(f, x); +} diff --git a/testsuite/tests/cps/cps011.cmm b/testsuite/tests/cps/cps011.cmm new file mode 100644 index 0000000000..9b344d1c76 --- /dev/null +++ b/testsuite/tests/cps/cps011.cmm @@ -0,0 +1,7 @@ +// Yet another basic function + +foo7 { + bits32 x; + (x) = foreign "C--" get_time() "safe"; + return (x); +} diff --git a/testsuite/tests/cps/cps012.cmm b/testsuite/tests/cps/cps012.cmm new file mode 100644 index 0000000000..6d828dca27 --- /dev/null +++ b/testsuite/tests/cps/cps012.cmm @@ -0,0 +1,23 @@ +// A real world example from the RTS +// Should be checked later to see if it is right + +stg_ap_0_fast ("ptr" bits32 fun, "ptr" bits32 arg) { + bits32 _c8; + c6: goto c7; + c7: _c8 = bits32[x]; // TODO: allow I32 or print bits32 + switch [0 .. 71] (bits16[_c8 - 4]) { + case 0,1,2,3,4,5,6,7,8 : { goto c9; } + case 9,10,11,12,13,14,15 : { goto ca; } + case 16,17,18,19,20,21,22,23 : { goto c9; } + case 24 : {goto ca;} + case 25 : {goto c9;} + case 26 : {goto ca;} + case 27 : {goto c9;} + case 28,29,30,31,32 : {goto cb;} + case 33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71 : {goto c9;} + } + c9: jump _c8 (); + cb: R1 = bits32[fun + 4 + 0]; + goto c7; + ca: jump (bits32[arg + 0 * 4]) (); +} diff --git a/testsuite/tests/cps/cps013.cmm b/testsuite/tests/cps/cps013.cmm new file mode 100644 index 0000000000..e92daca223 --- /dev/null +++ b/testsuite/tests/cps/cps013.cmm @@ -0,0 +1,21 @@ +// Test the calling conventions + +// Test the default calling convention +// which is "unsafe" but will change soon to "safe" +foo1() { + foreign "C--" bar(x, y); + return (1); +} + +// Test the "unsafe" calling convention +foo2() { + foreign "C--" bar(x, y) "unsafe"; + return (1); +} + +// Test the "safe" calling convention +foo3() { + bits32 x, y, z; + foreign "C--" bar(x, y, z) "safe"; + return (1); +} diff --git a/testsuite/tests/cps/cps014.cmm b/testsuite/tests/cps/cps014.cmm new file mode 100644 index 0000000000..3b8b651c43 --- /dev/null +++ b/testsuite/tests/cps/cps014.cmm @@ -0,0 +1,14 @@ +// Test explicit continuations. + +// Note, we might want to check about suffix on foo2 (i.e. "_entry"). +// I'm not sure that that is right. + +foo1 (bits32 update) jump foo2(update) { + bits32 x; + return (x); +} + +INFO_TABLE_RET (foo2, 0, bits32 update) (bits32 x) { + bits32[update] = x; + return (x); +} diff --git a/testsuite/tests/cps/cps015.cmm b/testsuite/tests/cps/cps015.cmm new file mode 100644 index 0000000000..2068dd80c3 --- /dev/null +++ b/testsuite/tests/cps/cps015.cmm @@ -0,0 +1,17 @@ +// Test whether a stack check is performed even when +// the existing stack due to on-stack arguments is big enough. + +// With space for a return address +foo1 (bits32 x, bits32 y) goto GC { + foreign "C--" bar(x) "safe"; + return (1); +GC: + return (1); +} + +// No space needed for a return address +foo2 (bits32 x, bits32 y) goto GC { + jump bar(x, y); +GC: + return (1); +} diff --git a/testsuite/tests/cps/cps016.cmm b/testsuite/tests/cps/cps016.cmm new file mode 100644 index 0000000000..44d6057b65 --- /dev/null +++ b/testsuite/tests/cps/cps016.cmm @@ -0,0 +1,14 @@ +// Test whether extra proc-points are generated +// by a label after a call such as with a heap check. + +foo1 () { + bits32 p, q; + bits32 x, y, z; + (p, q) = foreign "C--" bar(1, 2) "safe"; +L: + if (Hp < HpLim) { + (p, q) = foreign "C--" do_gc() "safe"; + goto L; + } + return (p+q+x+y+z); +} diff --git a/testsuite/tests/cps/cps017.cmm b/testsuite/tests/cps/cps017.cmm new file mode 100644 index 0000000000..7f12348260 --- /dev/null +++ b/testsuite/tests/cps/cps017.cmm @@ -0,0 +1,16 @@ +// Test whether extra proc-points are generated +// by a label after a call such as with a heap check, +// but where the return signature is different. +// The extra proc-point should be generated in this case. + +foo1 () { + bits32 p, q; + bits32 x, y, z; + (p, q) = foreign "C--" bar(1, 2) "safe"; +L: + if (Hp < HpLim) { + (p) = foreign "C--" do_gc() "safe"; + goto L; + } + return (p+q+x+y+z); +} diff --git a/testsuite/tests/cps/cps018.cmm b/testsuite/tests/cps/cps018.cmm new file mode 100644 index 0000000000..545a895887 --- /dev/null +++ b/testsuite/tests/cps/cps018.cmm @@ -0,0 +1,9 @@ +// Verify continuations get created + +foo() { + bits32 x, y, z; + x = 3; + foreign "C--" bar() "safe"; + y = 4; + return (z); +} diff --git a/testsuite/tests/cps/cps019.cmm b/testsuite/tests/cps/cps019.cmm new file mode 100644 index 0000000000..12c39a98c4 --- /dev/null +++ b/testsuite/tests/cps/cps019.cmm @@ -0,0 +1,12 @@ +// Verify block jumping to continuations works right + +foo() { + bits32 x, y, z; + x = x; + (x) = foreign "C--" bar() "safe"; +L: + y = y; + foreign "C--" baz() "safe"; + if (y) { z = z; goto L; } + else { z = z; goto L; } +} diff --git a/testsuite/tests/cps/cps020.cmm b/testsuite/tests/cps/cps020.cmm new file mode 100644 index 0000000000..2dc7131139 --- /dev/null +++ b/testsuite/tests/cps/cps020.cmm @@ -0,0 +1,15 @@ +// Test for proc points + +foo () { + bits32 x, y, z; + if (x<3) { + y = 1; + foreign "C--" bar() "safe"; + z = 1; + } else { + y = 2; + foreign "C--" baz() "safe"; + z = 2; + } + return (x, y, z); +} diff --git a/testsuite/tests/cps/cps021.cmm b/testsuite/tests/cps/cps021.cmm new file mode 100644 index 0000000000..fa7e809ee0 --- /dev/null +++ b/testsuite/tests/cps/cps021.cmm @@ -0,0 +1,11 @@ +// Verify jumping to the begining of the current continuation +// is done with a branch and not a jump + +foo() { + bits32 x, y, z; + x = x; + (x) = foreign "C--" bar() "safe"; +L: + z = z; + goto L; +} diff --git a/testsuite/tests/cps/cps022.cmm b/testsuite/tests/cps/cps022.cmm new file mode 100644 index 0000000000..64d6c39f19 --- /dev/null +++ b/testsuite/tests/cps/cps022.cmm @@ -0,0 +1,18 @@ +// Test conditional jumps to a proc-point/continuation + +// So far this can't happen, so this test is unneeded +// and would currently fail (it won't even parse). +// But if in future a CmmCondBranch could target +// a proc-point/continuation, then the CPS would need +// to be updated to account for this. + +foo() { + bits32 x, y, z; + x = x; + (x) = foreign "C--" bar() "safe"; +L: + y = y; + foreign "C--" baz() "safe"; + if (y<3) goto L; + goto L; +} diff --git a/testsuite/tests/cps/cps023.cmm b/testsuite/tests/cps/cps023.cmm new file mode 100644 index 0000000000..1a80b9085e --- /dev/null +++ b/testsuite/tests/cps/cps023.cmm @@ -0,0 +1,18 @@ +// Test foreign calls + +// This test won't work until the parser is changes. +// Currently the parser calls emitForeignCall', even +// for safe foreign calls and that function +// creates only unsafe foreign calls. +// This will have to be changed to +// code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety)) +// so the CPS can get a hold of it. + +foo() { + bits32 x, y, z; + x = x; + (x) = foreign "C" bar() "safe"; + y = y; + (y) = foreign "C" baz() "safe"; + return (z); +} diff --git a/testsuite/tests/cps/cps024.cmm b/testsuite/tests/cps/cps024.cmm new file mode 100644 index 0000000000..f24cd5e26e --- /dev/null +++ b/testsuite/tests/cps/cps024.cmm @@ -0,0 +1,12 @@ +// Test update frames + +foo1(bits32 x, bits32 y) jump update (x, y) { + bits32 z; + return (z); +} + +foo2(bits32 x, bits32 y) jump update (x, y) { + bits32 z; + foreign "C--" bar() "safe"; + return (z); +} diff --git a/testsuite/tests/cps/cps025.cmm b/testsuite/tests/cps/cps025.cmm new file mode 100644 index 0000000000..bc87924c89 --- /dev/null +++ b/testsuite/tests/cps/cps025.cmm @@ -0,0 +1,3 @@ +// Another test for empty functions + +INFO_TABLE_RET(foo, 0, bits32 x, bits32 y); diff --git a/testsuite/tests/cps/cps026.cmm b/testsuite/tests/cps/cps026.cmm new file mode 100644 index 0000000000..1bf4160f43 --- /dev/null +++ b/testsuite/tests/cps/cps026.cmm @@ -0,0 +1,18 @@ +// Test stack check targets + +// One with a target +foo1(bits32 x, bits32 y) goto L { + bits32 z; + foreign "C--" bar() "safe"; + return (z+12); +L: + z = 3; + return (z+13); +} + +// And one without a target +foo2(bits32 x, bits32 y) { + bits32 z; + foreign "C--" bar() "safe"; + return (z+14); +} diff --git a/testsuite/tests/cps/cps027.cmm b/testsuite/tests/cps/cps027.cmm new file mode 100644 index 0000000000..953f8fcc53 --- /dev/null +++ b/testsuite/tests/cps/cps027.cmm @@ -0,0 +1,29 @@ +// Test Michael Adams's optimization for code putatively +// generated from nested case expression +// case (case g x of { True -> f x1 ; False -> f x2 }) of +// [] -> return (x, 0) +// _:_ -> return (x, 1) + +test (bits32 x, bits32 x1, bits32 x2) { + bits32 t1, t2; + (t1) = foreign "C--" g(x) "safe"; + if (t1 != 0) { + (t2) = foreign "C--" f(x1) "safe"; + } else { + (t2) = foreign "C--" f(x2) "safe"; + } + R: + if (t2 == 0) { + Hp = Hp + 8; + if (Hp > HpLim) { (t2) = foreign "C--" gc1(l) "safe"; goto R; } + bits32[Hp] = x; + bits32[Hp+4] = 0; + return (Hp-8); + } else { + Hp = Hp + 8; + if (Hp > HpLim) { (t2) = foreign "C--" gc1(l) "safe"; goto R; } + bits32[Hp] = x; + bits32[Hp+4] = 1; + return (Hp-8); + } +} diff --git a/testsuite/tests/cps/cps028.cmm b/testsuite/tests/cps/cps028.cmm new file mode 100644 index 0000000000..57c897ef89 --- /dev/null +++ b/testsuite/tests/cps/cps028.cmm @@ -0,0 +1,17 @@ +// Test classic dead-code elimination + +sum (bits32 a, bits32 n) { + bits32 i, p, lim, sum; + sum = 0; + i = 0; + p = a; + lim = a + 4 * n; + L: + if (p < lim) { + sum = sum + bits32[p]; + i = i + 1; + p = p + 4; + goto L; + } + return (sum); +} |