Move tests from tests/ghc-regress/* to just tests/*

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);
+}