diff --git a/ghc-tests/bronze/CompareAndSwap.out b/ghc-tests/bronze/CompareAndSwap.out
new file mode 100644
index 0000000000000000000000000000000000000000..6572566ea6426a5c74961fde4195bd783b213602
--- /dev/null
+++ b/ghc-tests/bronze/CompareAndSwap.out
@@ -0,0 +1,11 @@
+ret > ExitSuccess
+out > Perform a CAS within an IORef
+out > 1st try should succeed: (True,44)
+out > 2nd should fail: (False,44)
+out > Perform a CAS within a MutableArray#
+out > 1st try should succeed: (True,44)
+out > 2nd should fail: (False,44)
+out > Printing array:
+out > 33 33 33 44 33
+out > Done.
+out >
diff --git a/ghc-tests/bronze/CopySmallArrayStressTest.out b/ghc-tests/bronze/CopySmallArrayStressTest.out
new file mode 100644
index 0000000000000000000000000000000000000000..53b0591fe8e0ed5affd2870faa172aac75b1be8f
--- /dev/null
+++ b/ghc-tests/bronze/CopySmallArrayStressTest.out
@@ -0,0 +1,4 @@
+ret > ExitSuccess
+out > test_copyMutableArray: OK
+out > test_cloneMutableArray: OK
+out >
diff --git a/ghc-tests/bronze/Drvrun022.out b/ghc-tests/bronze/Drvrun022.out
new file mode 100644
index 0000000000000000000000000000000000000000..d0aef3483c1d5d9e003acc3f86c8edcae1aaba14
--- /dev/null
+++ b/ghc-tests/bronze/Drvrun022.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > ["testz"]
+out >
diff --git a/ghc-tests/bronze/FFI009.out b/ghc-tests/bronze/FFI009.out
new file mode 100644
index 0000000000000000000000000000000000000000..af55e201498b179f6fda169c9ade6ebf0a75e2b2
--- /dev/null
+++ b/ghc-tests/bronze/FFI009.out
@@ -0,0 +1,167 @@
+ret > ExitSuccess
+out > Testing 5 Int arguments...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing 11 Double arguments...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing 11 mixed arguments...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 1st argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 2nd argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 3rd argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 4th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 5th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 6th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 7th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 8th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 9th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 10th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 11th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > Testing Double as 12th argument, rest Int...
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out > True
+out >
diff --git a/ghc-tests/bronze/T14768.out b/ghc-tests/bronze/T14768.out
new file mode 100644
index 0000000000000000000000000000000000000000..9cc96eddc83f53695d9e58701cd70b2c9a11be2f
--- /dev/null
+++ b/ghc-tests/bronze/T14768.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > True
+out >
diff --git a/ghc-tests/bronze/T14854.out b/ghc-tests/bronze/T14854.out
new file mode 100644
index 0000000000000000000000000000000000000000..9cc96eddc83f53695d9e58701cd70b2c9a11be2f
--- /dev/null
+++ b/ghc-tests/bronze/T14854.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > True
+out >
diff --git a/ghc-tests/bronze/T15038.out b/ghc-tests/bronze/T15038.out
new file mode 100644
index 0000000000000000000000000000000000000000..139fa17797b282cf67a9eda00b5556aa23fd60c8
--- /dev/null
+++ b/ghc-tests/bronze/T15038.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > 5
+out >
diff --git a/ghc-tests/bronze/T3087.out b/ghc-tests/bronze/T3087.out
new file mode 100644
index 0000000000000000000000000000000000000000..ac3829ed078aa7582a045aaf9bb55799c06e733a
--- /dev/null
+++ b/ghc-tests/bronze/T3087.out
@@ -0,0 +1,6 @@
+ret > ExitSuccess
+out > ()
+out > ()
+out > ()
+out > ()
+out >
diff --git a/ghc-tests/bronze/T367.out b/ghc-tests/bronze/T367.out
new file mode 100644
index 0000000000000000000000000000000000000000..e919a3a9972b881ebb79139fb2f3a9ce7b414131
--- /dev/null
+++ b/ghc-tests/bronze/T367.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > Done
+out >
diff --git a/ghc-tests/bronze/T367A.out b/ghc-tests/bronze/T367A.out
new file mode 100644
index 0000000000000000000000000000000000000000..3a2be73f7720903e2abcc654aa1026fcb014482e
--- /dev/null
+++ b/ghc-tests/bronze/T367A.out
@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > About to fork
+out > Why is this never printed?!
+out > Done
+out >
diff --git a/ghc-tests/bronze/T7953.out b/ghc-tests/bronze/T7953.out
new file mode 100644
index 0000000000000000000000000000000000000000..5e98ef6c1b5a6d73a52b39f9f24d13aba45e8509
--- /dev/null
+++ b/ghc-tests/bronze/T7953.out
@@ -0,0 +1,7 @@
+ret > ExitSuccess
+out > Winner (E {_key = 1, prio = 500.0}) (Fork (E {_key = 2, prio = 400.0}) Start (Fork (E {_key = 3, prio = 300.0}) Start (Fork (E {_key = 4, prio = 200.0}) Start (Fork (E {_key = 5, prio = 100.0}) Start (Fork (E {_key = 6, prio = 0.0}) Start (Fork (E {_key = 7, prio = -100.0}) Start (Fork (E {_key = 8, prio = -200.0}) Start (Fork (E {_key = 9, prio = -300.0}) Start (Fork (E {_key = 10, prio = -400.0}) Start (Fork (E {_key = 11, prio = -500.0}) Start (Fork (E {_key = 12, prio = -600.0}) Start (Fork (E {_key = 13, prio = -700.0}) Start (Fork (E {_key = 14, prio = -800.0}) Start (Fork (E {_key = 15, prio = -900.0}) Start (Fork (E {_key = 16, prio = -1000.0}) Start (Fork (E {_key = 17, prio = -1100.0}) Start (Fork (E {_key = 18, prio = -1200.0}) Start (Fork (E {_key = 19, prio = -1300.0}) Start (Fork (E {_key = 20, prio = -1400.0}) Start (Fork (E {_key = 21, prio = -1500.0}) Start (Fork (E {_key = 22, prio = -1600.0}) Start (Fork (E {_key = 23, prio = -1700.0}) Start (Fork (E {_key = 24, prio = -1800.0}) Start (Fork (E {_key = 25, prio = -1900.0}) Start (Fork (E {_key = 26, prio = -2000.0}) Start (Fork (E {_key = 27, prio = -2100.0}) Start (Fork (E {_key = 28, prio = -2200.0}) Start (Fork (E {_key = 29, prio = -2300.0}) Start (Fork (E {_key = 30, prio = -2400.0}) Start (Fork (E {_key = 31, prio = -2500.0}) Start (Fork (E {_key = 32, prio = -2600.0}) Start (Fork (E {_key = 33, prio = -2700.0}) Start (Fork (E {_key = 34, prio = -2800.0}) Start (Fork (E {_key = 35, prio = -2900.0}) Start (Fork (E {_key = 36, prio = -3000.0}) Start (Fork (E {_key = 37, prio = -3100.0}) Start (Fork (E {_key = 38, prio = -3200.0}) Start (Fork (E {_key = 39, prio = -3300.0}) Start (Fork (E {_key = 40, prio = -3400.0}) Start (Fork (E {_key = 41, prio = -3500.0}) Start (Fork (E {_key = 42, prio = -3600.0}) Start (Fork (E {_key = 43, prio = -3700.0}) Start (Fork (E {_key = 44, prio = -3800.0}) Start (Fork (E {_key = 45, prio = -3900.0}) Start (Fork (E {_key = 46, prio = -4000.0}) Start (Fork (E {_key = 47, prio = -4100.0}) Start (Fork (E {_key = 48, prio = -4200.0}) Start (Fork (E {_key = 49, prio = -4300.0}) Start (Fork (E {_key = 50, prio = -4400.0}) Start (Fork (E {_key = 51, prio = -4500.0}) Start (Fork (E {_key = 52, prio = -4600.0}) Start (Fork (E {_key = 53, prio = -4700.0}) Start (Fork (E {_key = 54, prio = -4800.0}) Start (Fork (E {_key = 55, prio = -4900.0}) Start (Fork (E {_key = 56, prio = -5000.0}) Start (Fork (E {_key = 57, prio = -5100.0}) Start (Fork (E {_key = 58, prio = -5200.0}) Start (Fork (E {_key = 59, prio = -5300.0}) Start (Fork (E {_key = 60, prio = -5400.0}) Start (Fork (E {_key = 61, prio = -5500.0}) Start (Fork (E {_key = 62, prio = -5600.0}) Start (Fork (E {_key = 63, prio = -5700.0}) Start (Fork (E {_key = 64, prio = -5800.0}) Start (Fork (E {_key = 65, prio = -5900.0}) Start (Fork (E {_key = 66, prio = -6000.0}) Start (Fork (E {_key = 67, prio = -6100.0}) Start (Fork (E {_key = 68, prio = -6200.0}) Start (Fork (E {_key = 69, prio = -6300.0}) Start (Fork (E {_key = 70, prio = -6400.0}) Start (Fork (E {_key = 71, prio = -6500.0}) Start (Fork (E {_key = 72, prio = -6600.0}) Start (Fork (E {_key = 73, prio = -6700.0}) Start (Fork (E {_key = 74, prio = -6800.0}) Start (Fork (E {_key = 75, prio = -6900.0}) Start (Fork (E {_key = 76, prio = -7000.0}) Start (Fork (E {_key = 77, prio = -7100.0}) Start (Fork (E {_key = 78, prio = -7200.0}) Start (Fork (E {_key = 79, prio = -7300.0}) Start (Fork (E {_key = 80, prio = -7400.0}) Start (Fork (E {_key = 81, prio = -7500.0}) Start (Fork (E {_key = 82, prio = -7600.0}) Start (Fork (E {_key = 83, prio = -7700.0}) Start (Fork (E {_key = 84, prio = -7800.0}) Start (Fork (E {_key = 85, prio = -7900.0}) Start (Fork (E {_key = 86, prio = -8000.0}) Start (Fork (E {_key = 87, prio = -8100.0}) Start (Fork (E {_key = 88, prio = -8200.0}) Start (Fork (E {_key = 89, prio = -8300.0}) Start (Fork (E {_key = 90, prio = -8400.0}) Start (Fork (E {_key = 91, prio = -8500.0}) Start (Fork (E {_key = 92, prio = -8600.0}) Start (Fork (E {_key = 93, prio = -8700.0}) Start (Fork (E {_key = 94, prio = -8800.0}) Start (Fork (E {_key = 95, prio = -8900.0}) Start (Fork (E {_key = 96, prio = -9000.0}) Start (Fork (E {_key = 97, prio = -9100.0}) Start (Fork (E {_key = 98, prio = -9200.0}) Start (Fork (E {_key = 99, prio = -9300.0}) Start (Fork (E {_key = 100, prio = -9400.0}) Start (Fork (E {_key = 101, prio = -9500.0}) Start (Fork (E {_key = 102, prio = -9600.0}) Start (Fork (E {_key = 103, prio = -9700.0}) Start (Fork (E {_key = 104, prio = -9800.0}) Start (Fork (E {_key = 105, prio = -9900.0}) Start (Fork (E {_key = 106, prio = -10000.0}) Start (Fork (E {_key = 107, prio = -10100.0}) Start (Fork (E {_key = 108, prio = -10200.0}) Start (Fork (E {_key = 109, prio = -10300.0}) Start (Fork (E {_key = 110, prio = -10400.0}) Start (Fork (E {_key = 111, prio = -10500.0}) Start (Fork (E {_key = 112, prio = -10600.0}) Start (Fork (E {_key = 113, prio = -10700.0}) Start (Fork (E {_key = 114, prio = -10800.0}) Start (Fork (E {_key = 115, prio = -10900.0}) Start (Fork (E {_key = 116, prio = -11000.0}) Start (Fork (E {_key = 117, prio = -11100.0}) Start (Fork (E {_key = 118, prio = -11200.0}) Start (Fork (E {_key = 119, prio = -11300.0}) Start (Fork (E {_key = 120, prio = -11400.0}) Start (Fork (E {_key = 121, prio = -11500.0}) Start (Fork (E {_key = 122, prio = -11600.0}) Start (Fork (E {_key = 123, prio = -11700.0}) Start (Fork (E {_key = 124, prio = -11800.0}) Start (Fork (E {_key = 125, prio = -11900.0}) Start (Fork (E {_key = 126, prio = -12000.0}) Start (Fork (E {_key = 127, prio = -12100.0}) Start (Fork (E {_key = 128, prio = -12200.0}) Start (Fork (E {_key = 129, prio = -12300.0}) Start (Fork (E {_key = 130, prio = -12400.0}) Start (Fork (E {_key = 131, prio = -12500.0}) Start (Fork (E {_key = 132, prio = -12600.0}) Start (Fork (E {_key = 133, prio = -12700.0}) Start (Fork (E {_key = 134, prio = -12800.0}) Start (Fork (E {_key = 135, prio = -12900.0}) Start (Fork (E {_key = 136, prio = -13000.0}) Start (Fork (E {_key = 137, prio = -13100.0}) Start (Fork (E {_key = 138, prio = -13200.0}) Start (Fork (E {_key = 139, prio = -13300.0}) Start (Fork (E {_key = 140, prio = -13400.0}) Start (Fork (E {_key = 141, prio = -13500.0}) Start (Fork (E {_key = 142, prio = -13600.0}) Start (Fork (E {_key = 143, prio = -13700.0}) Start (Fork (E {_key = 144, prio = -13800.0}) Start (Fork (E {_key = 145, prio = -13900.0}) Start (Fork (E {_key = 146, prio = -14000.0}) Start (Fork (E {_key = 147, prio = -14100.0}) Start (Fork (E {_key = 148, prio = -14200.0}) Start (Fork (E {_key = 149, prio = -14300.0}) Start (Fork (E {_key = 150, prio = -14400.0}) Start (Fork (E {_key = 151, prio = -14500.0}) Start (Fork (E {_key = 152, prio = -14600.0}) Start (Fork (E {_key = 153, prio = -14700.0}) Start (Fork (E {_key = 154, prio = -14800.0}) Start (Fork (E {_key = 155, prio = -14900.0}) Start (Fork (E {_key = 156, prio = -15000.0}) Start (Fork (E {_key = 157, prio = -15100.0}) Start (Fork (E {_key = 158, prio = -15200.0}) Start (Fork (E {_key = 159, prio = -15300.0}) Start (Fork (E {_key = 160, prio = -15400.0}) Start (Fork (E {_key = 161, prio = -15500.0}) Start (Fork (E {_key = 162, prio = -15600.0}) Start (Fork (E {_key = 163, prio = -15700.0}) Start (Fork (E {_key = 164, prio = -15800.0}) Start (Fork (E {_key = 165, prio = -15900.0}) Start (Fork (E {_key = 166, prio = -16000.0}) Start (Fork (E {_key = 167, prio = -16100.0}) Start (Fork (E {_key = 168, prio = -16200.0}) Start (Fork (E {_key = 169, prio = -16300.0}) Start (Fork (E {_key = 170, prio = -16400.0}) Start (Fork (E {_key = 171, prio = -16500.0}) Start (Fork (E {_key = 172, prio = -16600.0}) Start (Fork (E {_key = 173, prio = -16700.0}) Start (Fork (E {_key = 174, prio = -16800.0}) Start (Fork (E {_key = 175, prio = -16900.0}) Start (Fork (E {_key = 176, prio = -17000.0}) Start (Fork (E {_key = 177, prio = -17100.0}) Start (Fork (E {_key = 178, prio = -17200.0}) Start (Fork (E {_key = 179, prio = -17300.0}) Start (Fork (E {_key = 180, prio = -17400.0}) Start (Fork (E {_key = 181, prio = -17500.0}) Start (Fork (E {_key = 182, prio = -17600.0}) Start (Fork (E {_key = 183, prio = -17700.0}) Start (Fork (E {_key = 184, prio = -17800.0}) Start (Fork (E {_key = 185, prio = -17900.0}) Start (Fork (E {_key = 186, prio = -18000.0}) Start (Fork (E {_key = 187, prio = -18100.0}) Start (Fork (E {_key = 188, prio = -18200.0}) Start (Fork (E {_key = 189, prio = -18300.0}) Start (Fork (E {_key = 190, prio = -18400.0}) Start (Fork (E {_key = 191, prio = -18500.0}) Start (Fork (E {_key = 192, prio = -18600.0}) Start (Fork (E {_key = 193, prio = -18700.0}) Start (Fork (E {_key = 194, prio = -18800.0}) Start (Fork (E {_key = 195, prio = -18900.0}) Start (Fork (E {_key = 196, prio = -19000.0}) Start (Fork (E {_key = 197, prio = -19100.0}) Start (Fork (E {_key = 198, prio = -19200.0}) Start (Fork (E {_key = 199, prio = -19300.0}) Start (Fork (E {_key = 200, prio = -19400.0}) Start Start)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+out > Before atMost
+out > []
+out > Winner (E {_key = 1, prio = 500.0}) (Fork (E {_key = 2, prio = 400.0}) Start (Fork (E {_key = 3, prio = 300.0}) Start (Fork (E {_key = 4, prio = 200.0}) Start (Fork (E {_key = 5, prio = 100.0}) Start (Fork (E {_key = 6, prio = 0.0}) Start (Fork (E {_key = 7, prio = -100.0}) Start (Fork (E {_key = 8, prio = -200.0}) Start (Fork (E {_key = 9, prio = -300.0}) Start (Fork (E {_key = 10, prio = -400.0}) Start (Fork (E {_key = 11, prio = -500.0}) Start (Fork (E {_key = 12, prio = -600.0}) Start (Fork (E {_key = 13, prio = -700.0}) Start (Fork (E {_key = 14, prio = -800.0}) Start (Fork (E {_key = 15, prio = -900.0}) Start (Fork (E {_key = 16, prio = -1000.0}) Start (Fork (E {_key = 17, prio = -1100.0}) Start (Fork (E {_key = 18, prio = -1200.0}) Start (Fork (E {_key = 19, prio = -1300.0}) Start (Fork (E {_key = 20, prio = -1400.0}) Start (Fork (E {_key = 21, prio = -1500.0}) Start (Fork (E {_key = 22, prio = -1600.0}) Start (Fork (E {_key = 23, prio = -1700.0}) Start (Fork (E {_key = 24, prio = -1800.0}) Start (Fork (E {_key = 25, prio = -1900.0}) Start (Fork (E {_key = 26, prio = -2000.0}) Start (Fork (E {_key = 27, prio = -2100.0}) Start (Fork (E {_key = 28, prio = -2200.0}) Start (Fork (E {_key = 29, prio = -2300.0}) Start (Fork (E {_key = 30, prio = -2400.0}) Start (Fork (E {_key = 31, prio = -2500.0}) Start (Fork (E {_key = 32, prio = -2600.0}) Start (Fork (E {_key = 33, prio = -2700.0}) Start (Fork (E {_key = 34, prio = -2800.0}) Start (Fork (E {_key = 35, prio = -2900.0}) Start (Fork (E {_key = 36, prio = -3000.0}) Start (Fork (E {_key = 37, prio = -3100.0}) Start (Fork (E {_key = 38, prio = -3200.0}) Start (Fork (E {_key = 39, prio = -3300.0}) Start (Fork (E {_key = 40, prio = -3400.0}) Start (Fork (E {_key = 41, prio = -3500.0}) Start (Fork (E {_key = 42, prio = -3600.0}) Start (Fork (E {_key = 43, prio = -3700.0}) Start (Fork (E {_key = 44, prio = -3800.0}) Start (Fork (E {_key = 45, prio = -3900.0}) Start (Fork (E {_key = 46, prio = -4000.0}) Start (Fork (E {_key = 47, prio = -4100.0}) Start (Fork (E {_key = 48, prio = -4200.0}) Start (Fork (E {_key = 49, prio = -4300.0}) Start (Fork (E {_key = 50, prio = -4400.0}) Start (Fork (E {_key = 51, prio = -4500.0}) Start (Fork (E {_key = 52, prio = -4600.0}) Start (Fork (E {_key = 53, prio = -4700.0}) Start (Fork (E {_key = 54, prio = -4800.0}) Start (Fork (E {_key = 55, prio = -4900.0}) Start (Fork (E {_key = 56, prio = -5000.0}) Start (Fork (E {_key = 57, prio = -5100.0}) Start (Fork (E {_key = 58, prio = -5200.0}) Start (Fork (E {_key = 59, prio = -5300.0}) Start (Fork (E {_key = 60, prio = -5400.0}) Start (Fork (E {_key = 61, prio = -5500.0}) Start (Fork (E {_key = 62, prio = -5600.0}) Start (Fork (E {_key = 63, prio = -5700.0}) Start (Fork (E {_key = 64, prio = -5800.0}) Start (Fork (E {_key = 65, prio = -5900.0}) Start (Fork (E {_key = 66, prio = -6000.0}) Start (Fork (E {_key = 67, prio = -6100.0}) Start (Fork (E {_key = 68, prio = -6200.0}) Start (Fork (E {_key = 69, prio = -6300.0}) Start (Fork (E {_key = 70, prio = -6400.0}) Start (Fork (E {_key = 71, prio = -6500.0}) Start (Fork (E {_key = 72, prio = -6600.0}) Start (Fork (E {_key = 73, prio = -6700.0}) Start (Fork (E {_key = 74, prio = -6800.0}) Start (Fork (E {_key = 75, prio = -6900.0}) Start (Fork (E {_key = 76, prio = -7000.0}) Start (Fork (E {_key = 77, prio = -7100.0}) Start (Fork (E {_key = 78, prio = -7200.0}) Start (Fork (E {_key = 79, prio = -7300.0}) Start (Fork (E {_key = 80, prio = -7400.0}) Start (Fork (E {_key = 81, prio = -7500.0}) Start (Fork (E {_key = 82, prio = -7600.0}) Start (Fork (E {_key = 83, prio = -7700.0}) Start (Fork (E {_key = 84, prio = -7800.0}) Start (Fork (E {_key = 85, prio = -7900.0}) Start (Fork (E {_key = 86, prio = -8000.0}) Start (Fork (E {_key = 87, prio = -8100.0}) Start (Fork (E {_key = 88, prio = -8200.0}) Start (Fork (E {_key = 89, prio = -8300.0}) Start (Fork (E {_key = 90, prio = -8400.0}) Start (Fork (E {_key = 91, prio = -8500.0}) Start (Fork (E {_key = 92, prio = -8600.0}) Start (Fork (E {_key = 93, prio = -8700.0}) Start (Fork (E {_key = 94, prio = -8800.0}) Start (Fork (E {_key = 95, prio = -8900.0}) Start (Fork (E {_key = 96, prio = -9000.0}) Start (Fork (E {_key = 97, prio = -9100.0}) Start (Fork (E {_key = 98, prio = -9200.0}) Start (Fork (E {_key = 99, prio = -9300.0}) Start (Fork (E {_key = 100, prio = -9400.0}) Start (Fork (E {_key = 101, prio = -9500.0}) Start (Fork (E {_key = 102, prio = -9600.0}) Start (Fork (E {_key = 103, prio = -9700.0}) Start (Fork (E {_key = 104, prio = -9800.0}) Start (Fork (E {_key = 105, prio = -9900.0}) Start (Fork (E {_key = 106, prio = -10000.0}) Start (Fork (E {_key = 107, prio = -10100.0}) Start (Fork (E {_key = 108, prio = -10200.0}) Start (Fork (E {_key = 109, prio = -10300.0}) Start (Fork (E {_key = 110, prio = -10400.0}) Start (Fork (E {_key = 111, prio = -10500.0}) Start (Fork (E {_key = 112, prio = -10600.0}) Start (Fork (E {_key = 113, prio = -10700.0}) Start (Fork (E {_key = 114, prio = -10800.0}) Start (Fork (E {_key = 115, prio = -10900.0}) Start (Fork (E {_key = 116, prio = -11000.0}) Start (Fork (E {_key = 117, prio = -11100.0}) Start (Fork (E {_key = 118, prio = -11200.0}) Start (Fork (E {_key = 119, prio = -11300.0}) Start (Fork (E {_key = 120, prio = -11400.0}) Start (Fork (E {_key = 121, prio = -11500.0}) Start (Fork (E {_key = 122, prio = -11600.0}) Start (Fork (E {_key = 123, prio = -11700.0}) Start (Fork (E {_key = 124, prio = -11800.0}) Start (Fork (E {_key = 125, prio = -11900.0}) Start (Fork (E {_key = 126, prio = -12000.0}) Start (Fork (E {_key = 127, prio = -12100.0}) Start (Fork (E {_key = 128, prio = -12200.0}) Start (Fork (E {_key = 129, prio = -12300.0}) Start (Fork (E {_key = 130, prio = -12400.0}) Start (Fork (E {_key = 131, prio = -12500.0}) Start (Fork (E {_key = 132, prio = -12600.0}) Start (Fork (E {_key = 133, prio = -12700.0}) Start (Fork (E {_key = 134, prio = -12800.0}) Start (Fork (E {_key = 135, prio = -12900.0}) Start (Fork (E {_key = 136, prio = -13000.0}) Start (Fork (E {_key = 137, prio = -13100.0}) Start (Fork (E {_key = 138, prio = -13200.0}) Start (Fork (E {_key = 139, prio = -13300.0}) Start (Fork (E {_key = 140, prio = -13400.0}) Start (Fork (E {_key = 141, prio = -13500.0}) Start (Fork (E {_key = 142, prio = -13600.0}) Start (Fork (E {_key = 143, prio = -13700.0}) Start (Fork (E {_key = 144, prio = -13800.0}) Start (Fork (E {_key = 145, prio = -13900.0}) Start (Fork (E {_key = 146, prio = -14000.0}) Start (Fork (E {_key = 147, prio = -14100.0}) Start (Fork (E {_key = 148, prio = -14200.0}) Start (Fork (E {_key = 149, prio = -14300.0}) Start (Fork (E {_key = 150, prio = -14400.0}) Start (Fork (E {_key = 151, prio = -14500.0}) Start (Fork (E {_key = 152, prio = -14600.0}) Start (Fork (E {_key = 153, prio = -14700.0}) Start (Fork (E {_key = 154, prio = -14800.0}) Start (Fork (E {_key = 155, prio = -14900.0}) Start (Fork (E {_key = 156, prio = -15000.0}) Start (Fork (E {_key = 157, prio = -15100.0}) Start (Fork (E {_key = 158, prio = -15200.0}) Start (Fork (E {_key = 159, prio = -15300.0}) Start (Fork (E {_key = 160, prio = -15400.0}) Start (Fork (E {_key = 161, prio = -15500.0}) Start (Fork (E {_key = 162, prio = -15600.0}) Start (Fork (E {_key = 163, prio = -15700.0}) Start (Fork (E {_key = 164, prio = -15800.0}) Start (Fork (E {_key = 165, prio = -15900.0}) Start (Fork (E {_key = 166, prio = -16000.0}) Start (Fork (E {_key = 167, prio = -16100.0}) Start (Fork (E {_key = 168, prio = -16200.0}) Start (Fork (E {_key = 169, prio = -16300.0}) Start (Fork (E {_key = 170, prio = -16400.0}) Start (Fork (E {_key = 171, prio = -16500.0}) Start (Fork (E {_key = 172, prio = -16600.0}) Start (Fork (E {_key = 173, prio = -16700.0}) Start (Fork (E {_key = 174, prio = -16800.0}) Start (Fork (E {_key = 175, prio = -16900.0}) Start (Fork (E {_key = 176, prio = -17000.0}) Start (Fork (E {_key = 177, prio = -17100.0}) Start (Fork (E {_key = 178, prio = -17200.0}) Start (Fork (E {_key = 179, prio = -17300.0}) Start (Fork (E {_key = 180, prio = -17400.0}) Start (Fork (E {_key = 181, prio = -17500.0}) Start (Fork (E {_key = 182, prio = -17600.0}) Start (Fork (E {_key = 183, prio = -17700.0}) Start (Fork (E {_key = 184, prio = -17800.0}) Start (Fork (E {_key = 185, prio = -17900.0}) Start (Fork (E {_key = 186, prio = -18000.0}) Start (Fork (E {_key = 187, prio = -18100.0}) Start (Fork (E {_key = 188, prio = -18200.0}) Start (Fork (E {_key = 189, prio = -18300.0}) Start (Fork (E {_key = 190, prio = -18400.0}) Start (Fork (E {_key = 191, prio = -18500.0}) Start (Fork (E {_key = 192, prio = -18600.0}) Start (Fork (E {_key = 193, prio = -18700.0}) Start (Fork (E {_key = 194, prio = -18800.0}) Start (Fork (E {_key = 195, prio = -18900.0}) Start (Fork (E {_key = 196, prio = -19000.0}) Start (Fork (E {_key = 197, prio = -19100.0}) Start (Fork (E {_key = 198, prio = -19200.0}) Start (Fork (E {_key = 199, prio = -19300.0}) Start (Fork (E {_key = 200, prio = -19400.0}) Start Start)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+out > After atMost
+out >
diff --git a/ghc-tests/bronze/T8138.out b/ghc-tests/bronze/T8138.out
new file mode 100644
index 0000000000000000000000000000000000000000..ebf6f77cd6d9b8a0e5837236bd4ff62c649c841c
--- /dev/null
+++ b/ghc-tests/bronze/T8138.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0]
+out >
diff --git a/ghc-tests/bronze/cgrun068.out b/ghc-tests/bronze/cgrun068.out
new file mode 100644
index 0000000000000000000000000000000000000000..53b0591fe8e0ed5affd2870faa172aac75b1be8f
--- /dev/null
+++ b/ghc-tests/bronze/cgrun068.out
@@ -0,0 +1,4 @@
+ret > ExitSuccess
+out > test_copyMutableArray: OK
+out > test_cloneMutableArray: OK
+out >
diff --git a/ghc-tests/bronze/concio002.out b/ghc-tests/bronze/concio002.out
new file mode 100644
index 0000000000000000000000000000000000000000..8c8a3a69e0b20c8341efca47e631ed77a394be7d
--- /dev/null
+++ b/ghc-tests/bronze/concio002.out
@@ -0,0 +1,6 @@
+ret > ExitSuccess
+out > parent1
+out > child
+out > msg
+out > parent2
+out >
diff --git a/ghc-tests/bronze/hClose003.out b/ghc-tests/bronze/hClose003.out
new file mode 100644
index 0000000000000000000000000000000000000000..292f228449bbafc8569b8cd3e2d804a5790653bb
--- /dev/null
+++ b/ghc-tests/bronze/hClose003.out
@@ -0,0 +1,6 @@
+ret > ExitSuccess
+out > Right ()
+out > False
+out > Left <file descriptor: X>: hClose: resource vanished (Broken pipe)
+out > False
+out >
diff --git a/ghc-tests/bronze/hwaitPipe.out b/ghc-tests/bronze/hwaitPipe.out
new file mode 100644
index 0000000000000000000000000000000000000000..babd3c29811f7ee5d3f17015b36ad133aacceb28
--- /dev/null
+++ b/ghc-tests/bronze/hwaitPipe.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > delta >= 0: True
+out >
diff --git a/ghc-tests/bronze/hwaitSocket.out b/ghc-tests/bronze/hwaitSocket.out
new file mode 100644
index 0000000000000000000000000000000000000000..babd3c29811f7ee5d3f17015b36ad133aacceb28
--- /dev/null
+++ b/ghc-tests/bronze/hwaitSocket.out
@@ -0,0 +1,3 @@
+ret > ExitSuccess
+out > delta >= 0: True
+out >
diff --git a/ghc-tests/bronze/rand001.out b/ghc-tests/bronze/rand001.out
new file mode 100644
index 0000000000000000000000000000000000000000..16cc8829d815f5f68254c0c371891b92801de2cd
--- /dev/null
+++ b/ghc-tests/bronze/rand001.out
@@ -0,0 +1,7 @@
+ret > ExitSuccess
+out > True
+out > True
+out > True
+out > True
+out > True
+out >
diff --git a/ghc-tests/ghc-tests.cabal b/ghc-tests/ghc-tests.cabal
index db7a4b09155dfacf7b612879661f35196db69367..aa7414878d1ae5011a6f9d1d7437d713ae25e910 100644
--- a/ghc-tests/ghc-tests.cabal
+++ b/ghc-tests/ghc-tests.cabal
@@ -23,12 +23,86 @@ extra-source-files: CHANGELOG.md
test-suite ghc-tests
type: exitcode-stdio-1.0
- build-depends: base, ghc, tasty
+ build-depends: base,
+ ghc,
+ tasty,
+ QuickCheck,
+ unix,
+ process,
+ random,
+ primitive,
+ containers,
+ regex-compat,
+ parallel,
+ vector,
+ syb,
+ stm,
+ transformers,
+ network,
+ utf8-string,
+ tasty-quickcheck,
+ tasty-silver,
+ text,
+ temporary,
+ array,
+ tasty-hunit,
+ ghc-prim,
+ directory,
+ filepath,
+ async,
+ bytestring,
+ time,
+ deepseq,
+
+ mtl
main-is: Main.hs
- -- other-modules:
+ other-modules: Chan001
+ , MVar001
+ , HClose003
+ , Concio002
+ , Rand001
+ , HWaitPipe
+ , HWaitSocket
+ , Arr016
+ , Cgrun068
+ , T7953
+ , CopySmallArrayStressTest
+ , T367
+ , T367A
+ , Throwto001
+ , PerformGC
+ , Conc023
+ , CompareAndSwap
+ , T13916
+ , T13916_Bracket
+ , T8138
+ , Drvrun022
+ , T3087
+ , FFI009
+ , T2267
+ , T14768
+ , TC191
+ , TC220
+ , T12926
+ , T14854
+
+ , MaessenHashtab.Data.HashTab
+ , MaessenHashtab.HashTest
+
+ , T15038.Main
+ , T15038.Packed.Bytes
+ , T15038.Packed.Bytes.Parser
+ , T15038.Packed.Bytes.Stream.ST
+ , T15038.Parser
+ , T15038.Data.Trie.Naive
+
+ , Tasty.Bronze
- -- LANGUAGE extensions used by modules in this package.
- -- other-extensions:
build-depends: base >=4.14.1.0 && <5
hs-source-dirs: tests
default-language: Haskell2010
+ ghc-options: -threaded "-with-rtsopts=-qg -N" -O2 -dcore-lint
+
+ if arch(i386)
+ -- For reliable floating point results on i386
+ ghc-options: -msse2
diff --git a/ghc-tests/tests/Arr016.hs b/ghc-tests/tests/Arr016.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c2848fbe5e5d582852688478126c2e3173dabfda
--- /dev/null
+++ b/ghc-tests/tests/Arr016.hs
@@ -0,0 +1,229 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Arr016 where
+
+{-
+ - This is a test framework for Arrays, using QuickCheck
+ -
+ -}
+
+import qualified Data.Array as Array
+import Control.Monad ( liftM2, liftM3, liftM4 )
+import System.Random
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+
+import Data.Ix
+import Data.List( (\\) )
+
+infixl 9 !, //
+
+prop_array =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ Array.array b vs
+ `same_arr`
+ array b vs
+prop_listArray =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (vector (length [fst b..snd b]))
+ $ \ (vs :: [Bool]) ->
+ Array.listArray b vs == Array.array b (zipWith (\ a b -> (a,b))
+ (Array.range b) vs)
+
+prop_indices =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ let arr = Array.array b vs
+ in Array.indices arr == ((Array.range . Array.bounds) arr)
+
+prop_elems =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ let arr = Array.array b vs
+ in Array.elems arr == [arr Array.! i | i <- Array.indices arr]
+
+prop_assocs =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ let arr = Array.array b vs
+ in Array.assocs arr == [(i, arr Array.! i) | i <- Array.indices arr]
+
+prop_slashslash =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ let arr = Array.array b vs
+ us = []
+ in arr Array.// us == Array.array (Array.bounds arr)
+ ([(i,arr Array.! i)
+ | i <- Array.indices arr \\ [i | (i,_) <- us]]
+ ++ us)
+prop_accum =
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+
+ forAll (genIVPs b 10) $ \ (us :: [(Int,Int)]) ->
+ forAll (choose (0,length us))
+ $ \ n ->
+ let us' = take n us in
+ forAll arbitrary $ \ (fn :: Int -> Int -> Int) ->
+ let arr = Array.array b vs
+ in Array.accum fn arr us'
+ == foldl (\a (i,v) -> a Array.// [(i,fn (a Array.! i) v)]) arr us'
+
+prop_accumArray =
+ forAll arbitrary $ \ (f :: Int -> Int -> Int) ->
+ forAll arbitrary $ \ (z :: Int) ->
+ forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (vs :: [(Int,Int)]) ->
+ Array.accumArray f z b vs == Array.accum f
+ (Array.array b [(i,z) | i <- Array.range b]) vs
+
+
+same_arr :: (Eq b) => Array.Array Int b -> Array Int b -> Bool
+same_arr a1 a2 = a == c && b == d
+ && all (\ n -> (a1 Array.! n) == (a2 ! n)) [a..b]
+ where (a,b) = Array.bounds a1 :: (Int,Int)
+ (c,d) = bounds a2 :: (Int,Int)
+
+genBounds :: Gen (Int,Int)
+genBounds = do m <- choose (0,20)
+ n <- choose (minBound,maxBound-m)
+ return (n,n+m-1)
+
+genIVP :: Arbitrary a => (Int,Int) -> Gen (Int,a)
+genIVP b = do { i <- choose b
+ ; v <- arbitrary
+ ; return (i,v)
+ }
+
+genIVPs :: Arbitrary a => (Int,Int) -> Int -> Gen [(Int,a)]
+genIVPs b@(low,high) s
+ = do { let is = [low..high]
+ ; vs <- vector (length is)
+ ; shuffleN s (zip is vs)
+ }
+
+shuffleN 0 xs = return xs
+shuffleN n xs = shuffle xs >>= shuffleN (n - 1)
+
+prop_id = forAll genBounds $ \ (b :: (Int,Int)) ->
+ forAll (genIVPs b 10) $ \ (ivps :: [(Int,Int)]) ->
+ label (show (ivps :: [(Int,Int)])) True
+
+-- rift takes a list, split it (using an Int argument),
+-- and then rifts together the split lists into one.
+-- Think: rifting a pack of cards.
+rift :: Int -> [a] -> [a]
+rift n xs = comb (drop n xs) (take n xs)
+ where
+ comb (a:as) (b:bs) = a : b : comb as bs
+ comb (a:as) [] = a : as
+ comb [] (b:bs) = b : bs
+ comb [] [] = []
+
+
+prop_shuffle =
+ forAll (shuffleN 10 [1..10::Int]) $ \ lst ->
+ label (show lst) True
+
+------------------------------------------------------------------------------
+
+arr016 :: TestTree
+arr016 = testGroup "arr016"
+ [ testProperty "array" prop_array
+ , testProperty "listArray" prop_listArray
+ , testProperty "indicies" prop_indices
+ , testProperty "elems" prop_elems
+ , testProperty "assocs" prop_assocs
+ , testProperty "slashslash" prop_slashslash
+ , testProperty "accum" prop_accum
+ , testProperty "accumArray" prop_accumArray ]
+
+
+instance Show (a -> b) where { show _ = "<FN>" }
+
+------------------------------------------------------------------------------
+
+data Array a b = MkArray (a,a) (a -> b) deriving ()
+
+array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+array b ivs =
+ if and [inRange b i | (i,_) <- ivs]
+ then MkArray b
+ (\j -> case [v | (i,v) <- ivs, i == j] of
+ [v] -> v
+ [] -> error "Array.!: \
+ \undefined array element"
+ _ -> error "Array.!: \
+ \multiply defined array element")
+ else error "Array.array: out-of-range array association"
+
+listArray :: (Ix a) => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: (Ix a) => Array a b -> a -> b
+(!) (MkArray _ f) = f
+
+bounds :: (Ix a) => Array a b -> (a,a)
+bounds (MkArray b _) = b
+
+indices :: (Ix a) => Array a b -> [a]
+indices = range . bounds
+
+elems :: (Ix a) => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: (Ix a) => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+a // us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
+ -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
+ -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
+ -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+instance (Ix a) => Functor (Array a) where
+ fmap fn (MkArray b f) = MkArray b (fn . f)
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ a <= a' = assocs a <= assocs a'
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+--------------------------------------------------------------------
+
+-- QuickCheck v.0.2
+-- DRAFT implementation; last update 000104.
+-- Koen Claessen, John Hughes.
+-- This file represents work in progress, and might change at a later date.
+
+
+--------------------------------------------------------------------
+-- Generator
+
+
diff --git a/ghc-tests/tests/Cgrun068.hs b/ghc-tests/tests/Cgrun068.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d0ea90b411e5b9afce94867103614cbf95bb2c0d
--- /dev/null
+++ b/ghc-tests/tests/Cgrun068.hs
@@ -0,0 +1,384 @@
+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
+ UnboxedTuples #-}
+
+-- !!! stress tests of copying/cloning primitive arrays
+
+-- Note: You can run this test manually with an argument
+-- (i.e. ./cgrun068 10000) if you want to run the stress test for
+-- longer.
+
+{-
+Test strategy
+=============
+
+We create an array of arrays of integers. Repeatedly we then either
+
+* allocate a new array in place of an old, or
+
+* copy a random segment of an array into another array (which might be
+ the source array).
+
+By running this process long enough we hope to trigger any bugs
+related to garbage collection or edge cases.
+
+We only test copyMutableArray# and cloneArray# as they are
+representative of all the primops.
+-}
+
+module Cgrun068 ( main ) where
+
+import Debug.Trace (trace)
+
+import Control.Exception (assert)
+import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Class
+import GHC.Exts hiding (IsList(..))
+import GHC.ST hiding (liftST)
+import Prelude hiding (length, read)
+import qualified Prelude as P
+import qualified Prelude as P
+import System.Environment
+import System.Random
+import System.IO
+
+main :: Int -> Handle -> Handle -> IO ()
+main numMods stdout _ = do
+ hPutStr stdout
+ (test_copyMutableArray numMods ++ "\n" ++
+ test_cloneMutableArray numMods ++ "\n"
+ )
+
+-- Number of arrays
+numArrays :: Int
+numArrays = 100
+
+-- Maxmimum length of a sub-array
+maxLen :: Int
+maxLen = 1024
+
+-- Create an array of arrays, with each sub-array having random length
+-- and content.
+setup :: Rng s (MArray s (MArray s Int))
+setup = do
+ len <- rnd (1, numArrays)
+ marr <- liftST $ new_ len
+ let go i
+ | i >= len = return ()
+ | otherwise = do
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr i subarr
+ go (i+1)
+ go 0
+ return marr
+
+-- Replace one of the sub-arrays with a newly allocated array.
+allocate :: MArray s (MArray s Int) -> Rng s ()
+allocate marr = do
+ ix <- rnd (0, length marr - 1)
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr ix subarr
+
+type CopyFunction s a =
+ MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+
+-- Copy a random segment of an array onto another array, using the
+-- supplied copy function.
+copy :: MArray s (MArray s a) -> CopyFunction s a
+ -> Rng s (Int, Int, Int, Int, Int)
+copy marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ dst <- liftST $ read marr dix
+ let srcLen = length src
+ srcOff <- rnd (0, srcLen - 1)
+ let dstLen = length dst
+ dstOff <- rnd (0, dstLen - 1)
+ n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
+ liftST $ f src srcOff dst dstOff n
+ return (six, dix, srcOff, dstOff, n)
+
+type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)
+
+-- Clone a random segment of an array, replacing another array, using
+-- the supplied clone function.
+clone :: MArray s (MArray s a) -> CloneFunction s a
+ -> Rng s (Int, Int, Int, Int)
+clone marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ let srcLen = length src
+ -- N.B. The array length might be zero if we previously cloned
+ -- zero elements from some array.
+ srcOff <- rnd (0, max 0 (srcLen - 1))
+ n <- rnd (0, srcLen - srcOff)
+ dst <- liftST $ f src srcOff n
+ liftST $ write marr dix dst
+ return (six, dix, srcOff, n)
+
+------------------------------------------------------------------------
+-- copyMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: Int -> String
+test_copyMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_copyMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or copy
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doCopy
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doCopy = do
+ inp <- liftST $ asList marr
+ _ <- local $ copy marr copyMArray
+ (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff dstOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff dstOff n =
+ error $ "test_copyMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+asList :: MArray s (MArray s a) -> ST s [[a]]
+asList marr = toListM =<< mapArrayM toListM marr
+
+unlinesShow :: Show a => [a] -> String
+unlinesShow = concatMap (\ x -> show x ++ "\n")
+
+------------------------------------------------------------------------
+-- cloneMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_cloneMutableArray :: Int -> String
+test_cloneMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_cloneMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or clone
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doClone
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doClone = do
+ inp <- liftST $ asList marr
+ _ <- local $ clone marr cloneMArray
+ (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff n =
+ error $ "test_cloneMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+------------------------------------------------------------------------
+-- Convenience wrappers for Array# and MutableArray#
+
+data Array a = Array
+ { unArray :: Array# a
+ , lengthA :: {-# UNPACK #-} !Int}
+
+data MArray s a = MArray
+ { unMArray :: MutableArray# s a
+ , lengthM :: {-# UNPACK #-} !Int}
+
+class IArray a where
+ length :: a -> Int
+instance IArray (Array a) where
+ length = lengthA
+instance IArray (MArray s a) where
+ length = lengthM
+
+instance Eq a => Eq (Array a) where
+ arr1 == arr2 = toList arr1 == toList arr2
+
+new :: Int -> a -> ST s (MArray s a)
+new n@(I# n#) a =
+ assert (n >= 0) $
+ ST $ \s# -> case newArray# n# a s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# n #)
+
+new_ :: Int -> ST s (MArray s a)
+new_ n = new n (error "Undefined element")
+
+write :: MArray s a -> Int -> a -> ST s ()
+write marr i@(I# i#) a =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ case writeArray# (unMArray marr) i# a s# of
+ s2# -> (# s2#, () #)
+
+read :: MArray s a -> Int -> ST s a
+read marr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ readArray# (unMArray marr) i# s#
+
+index :: Array a -> Int -> a
+index arr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length arr) $
+ case indexArray# (unArray arr) i# of
+ (# a #) -> a
+
+unsafeFreeze :: MArray s a -> ST s (Array a)
+unsafeFreeze marr = ST $ \ s# ->
+ case unsafeFreezeArray# (unMArray marr) s# of
+ (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)
+
+toList :: Array a -> [a]
+toList arr = go 0
+ where
+ go i | i >= length arr = []
+ | otherwise = index arr i : go (i+1)
+
+fromList :: [e] -> ST s (MArray s e)
+fromList es = do
+ marr <- new_ n
+ let go !_ [] = return ()
+ go i (x:xs) = write marr i x >> go (i+1) xs
+ go 0 es
+ return marr
+ where
+ n = P.length es
+
+mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
+mapArrayM f src = do
+ dst <- new_ n
+ let go i
+ | i >= n = return dst
+ | otherwise = do
+ el <- read src i
+ el' <- f el
+ write dst i el'
+ go (i+1)
+ go 0
+ where
+ n = length src
+
+toListM :: MArray s e -> ST s [e]
+toListM marr =
+ sequence [read marr i | i <- [0..(length marr)-1]]
+
+------------------------------------------------------------------------
+-- Wrappers around copy/clone primops
+
+copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ ST $ \ s# ->
+ case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+ s2# -> (# s2#, () #)
+
+cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArray marr off@(I# off#) n@(I# n#) =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $
+ ST $ \ s# ->
+ case cloneMutableArray# (unMArray marr) off# n# s# of
+ (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)
+
+------------------------------------------------------------------------
+-- Manual versions of copy/clone primops. Used to validate the
+-- primops
+
+copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
+copyMArraySlow !src !six !dst !dix n =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ if six < dix
+ then goB (six+n-1) (dix+n-1) 0 -- Copy backwards
+ else goF six dix 0 -- Copy forwards
+ where
+ goF !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goF (i+1) (j+1) (c+1)
+ goB !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goB (i-1) (j-1) (c+1)
+
+cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArraySlow !marr !off n =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $ do
+ marr2 <- new_ n
+ let go !i !j c
+ | c >= n = return marr2
+ | otherwise = do
+ b <- read marr i
+ write marr2 j b
+ go (i+1) (j+1) (c+1)
+ go off 0 0
+
+------------------------------------------------------------------------
+-- Utilities for simplifying RNG passing
+
+newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
+ deriving (Functor, Applicative, Monad)
+
+-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
+rnd :: Random a => (a, a) -> Rng s a
+rnd r = Rng $ do
+ g <- get
+ let (x, g') = randomR r g
+ put g'
+ return x
+
+-- Run a sub-computation without affecting the RNG state.
+local :: Rng s a -> Rng s a
+local m = Rng $ do
+ g <- get
+ x <- unRng m
+ put g
+ return x
+
+liftST :: ST s a -> Rng s a
+liftST m = Rng $ lift m
+
+run :: Rng s a -> ST s a
+run = flip evalStateT (mkStdGen 13) . unRng
+
diff --git a/ghc-tests/tests/Chan001.hs b/ghc-tests/tests/Chan001.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d1ef0d8d2c2ef6f6f2b4e6e8c2d370a508db198c
--- /dev/null
+++ b/ghc-tests/tests/Chan001.hs
@@ -0,0 +1,101 @@
+module Chan001 where
+import Test.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.Chan
+import Control.Concurrent
+import Control.Monad
+import Test.Tasty.QuickCheck
+import Test.Tasty
+
+data Action = NewChan | ReadChan | WriteChan Int | ReturnInt Int
+ | ReturnBool Bool
+ deriving (Eq,Show)
+
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ quickCheck prop_NewWriteRead_NewRet
+
+testChan :: TestTree
+testChan =
+ testGroup "Chan001" $ [
+ testProperty "NewWriteRead_NewRet" prop_NewWriteRead_NewRet ]
+
+
+prop_NewWriteRead_NewRet n =
+ [NewChan,WriteChan n,ReadChan] =^ [NewChan,ReturnInt n]
+
+
+perform :: [Action] -> IO ([Bool],[Int])
+perform [] = return ([],[])
+
+perform (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
+ NewChan -> newChan >>= \chan -> perform' chan as
+ _ -> error $ "Please use NewChan as first action"
+
+
+perform' :: Chan Int -> [Action] -> IO ([Bool],[Int])
+perform' _ [] = return ([],[])
+
+perform' chan (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' chan as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' chan as)
+ ReadChan -> liftM2 (\v (b,l) -> (b,v:l)) (readChan chan)
+ (perform' chan as)
+ WriteChan n -> writeChan chan n >> perform' chan as
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions =
+ liftM (NewChan:) (actions' 0)
+
+
+actions' :: Int -> Gen [Action]
+actions' contents =
+ oneof ([return [],
+ liftM2 (:) (liftM WriteChan arbitrary) (actions' (contents+1))]
+ ++
+ if contents==0
+ then []
+ else [liftM (ReadChan:) (actions' (contents-1))])
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta 0 c))
+ (\suff -> observe c suff == observe c' suff)
+ where observe x suff = unsafePerformIO (perform (x++suff))
+
+
+(^=^) :: [Action] -> [Action] -> Property
+c ^=^ c' =
+ forAll actions
+ (\pref -> forAll (actions' (delta 0 (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Int -> [Action] -> Int
+delta i [] = i
+
+delta i (ReturnInt _:as) = delta i as
+
+delta i (ReturnBool _:as) = delta i as
+
+delta _ (NewChan:as) = delta 0 as
+
+delta i (WriteChan _:as) = delta (i+1) as
+
+delta i (ReadChan:as) = delta (if i==0
+ then error "read on empty Chan"
+ else i-1) as
+
diff --git a/ghc-tests/tests/CompareAndSwap.hs b/ghc-tests/tests/CompareAndSwap.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b6978b82cd08eec76f10b730155e2485c55c4133
--- /dev/null
+++ b/ghc-tests/tests/CompareAndSwap.hs
@@ -0,0 +1,80 @@
+{-# Language MagicHash, UnboxedTuples #-}
+module CompareAndSwap where
+
+-- | Note: extensive testing of atomic operations is performed in the
+-- "atomic-primops" library. Only extremely rudimentary tests appear
+-- here.
+
+import GHC.IO
+import GHC.IORef
+import GHC.ST
+import GHC.STRef
+import GHC.Prim
+import GHC.Base
+import Data.Primitive.Array
+import Data.IORef
+import Control.Monad
+import System.IO
+
+------------------------------------------------------------------------
+
+casArrayST :: MutableArray s a -> Int -> a -> a -> ST s (Bool, a)
+casArrayST (MutableArray arr#) (I# i#) old new = ST$ \s1# ->
+ case casArray# arr# i# old new s1# of
+ (# s2#, x#, res #) -> (# s2#, (isTrue# (x# ==# 0#), res) #)
+
+casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'
+ -> a -- ^ The 'old' value to compare
+ -> a -- ^ The 'new' value to replace 'current' if @old == current@
+ -> ST s (Bool, a)
+casSTRef (STRef var#) old new = ST $ \s1# ->
+ -- The primop treats the boolean as a sort of error code.
+ -- Zero means the CAS worked, one that it didn't.
+ -- We flip that here:
+ case casMutVar# var# old new s1# of
+ (# s2#, x#, res #) -> (# s2#, (isTrue# (x# ==# 0#), res) #)
+
+-- | Performs a machine-level compare and swap operation on an
+-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a
+-- swap is performed, along with the 'current' value from the 'IORef'.
+--
+-- Note \"compare\" here means pointer equality in the sense of
+-- 'GHC.Prim.reallyUnsafePtrEquality#'.
+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'
+ -> a -- ^ The 'old' value to compare
+ -> a -- ^ The 'new' value to replace 'current' if @old == current@
+ -> IO (Bool, a)
+casIORef (IORef var) old new = stToIO (casSTRef var old new)
+
+
+------------------------------------------------------------------------
+-- Make sure this Int corresponds to a single object in memory (NOINLINE):
+{-# NOINLINE mynum #-}
+mynum :: Int
+mynum = 33
+
+main stdout _ = do
+ hPutStrLn stdout "Perform a CAS within an IORef"
+ ref <- newIORef mynum
+ res <- casIORef ref mynum 44
+ res2 <- casIORef ref mynum 44
+ hPutStrLn stdout $ " 1st try should succeed: "++show res
+ hPutStrLn stdout $ " 2nd should fail: "++show res2
+
+ ------------------------------------------------------------
+ hPutStrLn stdout "Perform a CAS within a MutableArray#"
+ arr <- newArray 5 mynum
+
+ res <- stToIO$ casArrayST arr 3 mynum 44
+ res2 <- stToIO$ casArrayST arr 3 mynum 44
+ hPutStrLn stdout $ " 1st try should succeed: "++show res
+ hPutStrLn stdout $ " 2nd should fail: "++show res2
+
+ hPutStrLn stdout "Printing array:"
+ forM_ [0..4] $ \ i -> do
+ x <- readArray arr i
+ hPutStr stdout (" "++show x)
+ hPutStrLn stdout ""
+
+ ------------------------------------------------------------
+ hPutStrLn stdout "Done."
diff --git a/ghc-tests/tests/Conc023.hs b/ghc-tests/tests/Conc023.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e80f9bf3eed74525b66c2fe55cf0783689b3f5b7
--- /dev/null
+++ b/ghc-tests/tests/Conc023.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Conc023 where
+-- !!! test threadDelay, Random, and QSemN.
+
+-- start a large number (n) of threads each of which will wait for a
+-- random delay between 0 and m seconds. We use a semaphore to wait
+-- for all the threads to finish.
+
+import System.Random
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+n = 5000 -- no. of threads
+m = 3000 -- maximum delay
+
+main = do
+ v <- newEmptyMVar
+ is <- replicateM n $ getStdRandom (randomR (1,m))
+ mapM_ (fork_sleep v) is
+ replicateM_ n (takeMVar v)
+ where
+ fork_sleep v i = forkIO $ do threadDelay (i*1000); putMVar v ()
diff --git a/ghc-tests/tests/Concio002.hs b/ghc-tests/tests/Concio002.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e54045943c4a47d2d755e4ccbb563871aabe90e3
--- /dev/null
+++ b/ghc-tests/tests/Concio002.hs
@@ -0,0 +1,15 @@
+module Concio002 where
+import System.Process
+import System.IO
+import Control.Concurrent
+
+main stdout _ = do
+ (hin,hout,herr,ph) <- runInteractiveProcess "cat" [] Nothing Nothing
+ forkIO $ do threadDelay 100000
+ hPutStrLn stdout "child"
+ hFlush stdout
+ hPutStrLn hin "msg"
+ hFlush hin
+ hPutStrLn stdout "parent1"
+ hGetLine hout >>= hPutStrLn stdout
+ hPutStrLn stdout "parent2"
diff --git a/ghc-tests/tests/CopySmallArrayStressTest.hs b/ghc-tests/tests/CopySmallArrayStressTest.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7f7fad22be30a305a1152ff188f6be593535587f
--- /dev/null
+++ b/ghc-tests/tests/CopySmallArrayStressTest.hs
@@ -0,0 +1,383 @@
+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
+ UnboxedTuples #-}
+
+-- !!! stress tests of copying/cloning primitive arrays
+
+-- Note: You can run this test manually with an argument (i.e.
+-- ./CopySmallArrayStressTest 10000) if you want to run the stress
+-- test for longer.
+
+{-
+Test strategy
+=============
+
+We create an array of arrays of integers. Repeatedly we then either
+
+* allocate a new array in place of an old, or
+
+* copy a random segment of an array into another array (which might be
+ the source array).
+
+By running this process long enough we hope to trigger any bugs
+related to garbage collection or edge cases.
+
+We only test copySmallMutableArray# and cloneSmallArray# as they are
+representative of all the primops.
+-}
+
+module CopySmallArrayStressTest ( main ) where
+
+
+import Control.Exception (assert)
+import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Class
+import GHC.Exts hiding (IsList(..))
+import GHC.ST hiding (liftST)
+import Prelude hiding (length, read)
+import qualified Prelude as P
+import qualified Prelude as P
+import System.Environment
+import System.Random
+import System.IO
+
+main :: Int -> Handle -> Handle -> IO ()
+main numMods stdout _ = do
+ hPutStr stdout
+ (test_copyMutableArray numMods ++ "\n" ++
+ test_cloneMutableArray numMods ++ "\n"
+ )
+
+-- Number of arrays
+numArrays :: Int
+numArrays = 100
+
+-- Maxmimum length of a sub-array
+maxLen :: Int
+maxLen = 1024
+
+-- Create an array of arrays, with each sub-array having random length
+-- and content.
+setup :: Rng s (MArray s (MArray s Int))
+setup = do
+ len <- rnd (1, numArrays)
+ marr <- liftST $ new_ len
+ let go i
+ | i >= len = return ()
+ | otherwise = do
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr i subarr
+ go (i+1)
+ go 0
+ return marr
+
+-- Replace one of the sub-arrays with a newly allocated array.
+allocate :: MArray s (MArray s Int) -> Rng s ()
+allocate marr = do
+ ix <- rnd (0, length marr - 1)
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr ix subarr
+
+type CopyFunction s a =
+ MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+
+-- Copy a random segment of an array onto another array, using the
+-- supplied copy function.
+copy :: MArray s (MArray s a) -> CopyFunction s a
+ -> Rng s (Int, Int, Int, Int, Int)
+copy marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ dst <- liftST $ read marr dix
+ let srcLen = length src
+ srcOff <- rnd (0, srcLen - 1)
+ let dstLen = length dst
+ dstOff <- rnd (0, dstLen - 1)
+ n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
+ liftST $ f src srcOff dst dstOff n
+ return (six, dix, srcOff, dstOff, n)
+
+type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)
+
+-- Clone a random segment of an array, replacing another array, using
+-- the supplied clone function.
+clone :: MArray s (MArray s a) -> CloneFunction s a
+ -> Rng s (Int, Int, Int, Int)
+clone marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ let srcLen = length src
+ -- N.B. The array length might be zero if we previously cloned
+ -- zero elements from some array.
+ srcOff <- rnd (0, max 0 (srcLen - 1))
+ n <- rnd (0, srcLen - srcOff)
+ dst <- liftST $ f src srcOff n
+ liftST $ write marr dix dst
+ return (six, dix, srcOff, n)
+
+------------------------------------------------------------------------
+-- copySmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: Int -> String
+test_copyMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_copyMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or copy
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doCopy
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doCopy = do
+ inp <- liftST $ asList marr
+ _ <- local $ copy marr copyMArray
+ (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff dstOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff dstOff n =
+ error $ "test_copyMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+asList :: MArray s (MArray s a) -> ST s [[a]]
+asList marr = toListM =<< mapArrayM toListM marr
+
+unlinesShow :: Show a => [a] -> String
+unlinesShow = concatMap (\ x -> show x ++ "\n")
+
+------------------------------------------------------------------------
+-- cloneSmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_cloneMutableArray :: Int -> String
+test_cloneMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_cloneMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or clone
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doClone
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doClone = do
+ inp <- liftST $ asList marr
+ _ <- local $ clone marr cloneMArray
+ (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff n =
+ error $ "test_cloneMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+------------------------------------------------------------------------
+-- Convenience wrappers for SmallArray# and SmallMutableArray#
+
+data Array a = Array
+ { unArray :: SmallArray# a
+ , lengthA :: {-# UNPACK #-} !Int}
+
+data MArray s a = MArray
+ { unMArray :: SmallMutableArray# s a
+ , lengthM :: {-# UNPACK #-} !Int}
+
+class IArray a where
+ length :: a -> Int
+instance IArray (Array a) where
+ length = lengthA
+instance IArray (MArray s a) where
+ length = lengthM
+
+instance Eq a => Eq (Array a) where
+ arr1 == arr2 = toList arr1 == toList arr2
+
+new :: Int -> a -> ST s (MArray s a)
+new n@(I# n#) a =
+ assert (n >= 0) $
+ ST $ \s# -> case newSmallArray# n# a s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# n #)
+
+new_ :: Int -> ST s (MArray s a)
+new_ n = new n (error "Undefined element")
+
+write :: MArray s a -> Int -> a -> ST s ()
+write marr i@(I# i#) a =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ case writeSmallArray# (unMArray marr) i# a s# of
+ s2# -> (# s2#, () #)
+
+read :: MArray s a -> Int -> ST s a
+read marr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ readSmallArray# (unMArray marr) i# s#
+
+index :: Array a -> Int -> a
+index arr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length arr) $
+ case indexSmallArray# (unArray arr) i# of
+ (# a #) -> a
+
+unsafeFreeze :: MArray s a -> ST s (Array a)
+unsafeFreeze marr = ST $ \ s# ->
+ case unsafeFreezeSmallArray# (unMArray marr) s# of
+ (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)
+
+toList :: Array a -> [a]
+toList arr = go 0
+ where
+ go i | i >= length arr = []
+ | otherwise = index arr i : go (i+1)
+
+fromList :: [e] -> ST s (MArray s e)
+fromList es = do
+ marr <- new_ n
+ let go !_ [] = return ()
+ go i (x:xs) = write marr i x >> go (i+1) xs
+ go 0 es
+ return marr
+ where
+ n = P.length es
+
+mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
+mapArrayM f src = do
+ dst <- new_ n
+ let go i
+ | i >= n = return dst
+ | otherwise = do
+ el <- read src i
+ el' <- f el
+ write dst i el'
+ go (i+1)
+ go 0
+ where
+ n = length src
+
+toListM :: MArray s e -> ST s [e]
+toListM marr =
+ sequence [read marr i | i <- [0..(length marr)-1]]
+
+------------------------------------------------------------------------
+-- Wrappers around copy/clone primops
+
+copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ ST $ \ s# ->
+ case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+ s2# -> (# s2#, () #)
+
+cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArray marr off@(I# off#) n@(I# n#) =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $
+ ST $ \ s# ->
+ case cloneSmallMutableArray# (unMArray marr) off# n# s# of
+ (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)
+
+------------------------------------------------------------------------
+-- Manual versions of copy/clone primops. Used to validate the
+-- primops
+
+copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
+copyMArraySlow !src !six !dst !dix n =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ if six < dix
+ then goB (six+n-1) (dix+n-1) 0 -- Copy backwards
+ else goF six dix 0 -- Copy forwards
+ where
+ goF !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goF (i+1) (j+1) (c+1)
+ goB !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goB (i-1) (j-1) (c+1)
+
+cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArraySlow !marr !off n =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $ do
+ marr2 <- new_ n
+ let go !i !j c
+ | c >= n = return marr2
+ | otherwise = do
+ b <- read marr i
+ write marr2 j b
+ go (i+1) (j+1) (c+1)
+ go off 0 0
+
+------------------------------------------------------------------------
+-- Utilities for simplifying RNG passing
+
+newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
+ deriving (Functor, Applicative, Monad)
+
+-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
+rnd :: Random a => (a, a) -> Rng s a
+rnd r = Rng $ do
+ g <- get
+ let (x, g') = randomR r g
+ put g'
+ return x
+
+-- Run a sub-computation without affecting the RNG state.
+local :: Rng s a -> Rng s a
+local m = Rng $ do
+ g <- get
+ x <- unRng m
+ put g
+ return x
+
+liftST :: ST s a -> Rng s a
+liftST m = Rng $ lift m
+
+run :: Rng s a -> ST s a
+run = flip evalStateT (mkStdGen 13) . unRng
+
diff --git a/ghc-tests/tests/Drvrun022.hs b/ghc-tests/tests/Drvrun022.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6f8bdc7cb66d33ff4380ce273ccf6b22fbf67a6b
--- /dev/null
+++ b/ghc-tests/tests/Drvrun022.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Drvrun022 where
+
+-- GHC 6.4.1 output "testz" in z-encoded form!
+
+import Data.Generics
+import System.IO
+
+data TestZ = TestZ { testz :: Int }
+ deriving (Show, Read, Eq, Data, Typeable)
+
+main stdout _ = hPrint stdout $ constrFields . toConstr $ TestZ { testz = 2 }
diff --git a/ghc-tests/tests/FFI009.hs b/ghc-tests/tests/FFI009.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8c61a2ae5369c3853748c54153e159945328a148
--- /dev/null
+++ b/ghc-tests/tests/FFI009.hs
@@ -0,0 +1,555 @@
+module FFI009 where
+
+import Foreign
+import System.Random
+import System.IO
+
+--------------------------------------------------------------------------------
+
+type FunType5I = Int -> Int -> Int -> Int -> Int -> Int
+
+foreign import ccall "dynamic" callFun5I :: FunPtr FunType5I -> FunType5I
+foreign import ccall "wrapper" mkFun5I :: FunType5I -> IO (FunPtr FunType5I)
+
+manyArgs5I :: FunType5I
+manyArgs5I a1 a2 a3 a4 a5 = (((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5
+
+test5I :: Handle -> IO ()
+test5I stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ funAddr <- mkFun5I manyArgs5I
+ hPrint stdout (callFun5I funAddr a1 a2 a3 a4 a5 ==
+ manyArgs5I a1 a2 a3 a4 a5)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunType11D = Double -> Double -> Double -> Double -> Double -> Double
+ -> Double -> Double -> Double -> Double -> Double -> Double
+
+foreign import ccall "dynamic" callFun11D :: FunPtr FunType11D -> FunType11D
+foreign import ccall "wrapper" mkFun11D :: FunType11D -> IO (FunPtr FunType11D)
+
+manyArgs11D :: FunType11D
+manyArgs11D a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
+ ((((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5) * 31 + a6
+ + a7 + a8 + a9 + a10 + a11
+
+test11D :: Handle -> IO ()
+test11D stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ funAddr <- mkFun11D manyArgs11D
+ let x = callFun11D funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
+ y = manyArgs11D a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
+ if x /= y then
+ hPrint stdout x >> hPrint stdout y
+ else
+ hPrint stdout True
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunType11M = Int -> Double -> Float -> Char -> Bool -> Int -> Float -> Int
+ -> Char -> Double -> Bool -> Double
+
+foreign import ccall "dynamic" callFun11M :: FunPtr FunType11M -> FunType11M
+foreign import ccall "wrapper" mkFun11M :: FunType11M -> IO (FunPtr FunType11M)
+
+manyArgs11M :: FunType11M
+manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
+ (((((((((fromIntegral a1 * 31 + a2) * 31 +
+ realToFrac a3) * 31 + fromIntegral (fromEnum a4)) * 31 +
+ fromIntegral (fromEnum a5)) * 31 + fromIntegral a6) * 31 +
+ realToFrac a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral (fromEnum a9)) * 31 + a10) * 31 +
+ fromIntegral (fromEnum a11)
+
+test11M :: Handle -> IO ()
+test11M stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ funAddr <- mkFun11M manyArgs11M
+ hPrint stdout (callFun11M funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 ==
+ manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM1 = Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM1 :: FunPtr FunTypeM1 -> FunTypeM1
+foreign import ccall "wrapper" mkFunM1 :: FunTypeM1 -> IO (FunPtr FunTypeM1)
+
+manyArgsM1 :: FunTypeM1
+manyArgsM1 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ (((((((((( a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM1 :: Handle -> IO ()
+testM1 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM1 manyArgsM1
+ hPrint stdout (callFunM1 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM1 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM2 = Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM2 :: FunPtr FunTypeM2 -> FunTypeM2
+foreign import ccall "wrapper" mkFunM2 :: FunTypeM2 -> IO (FunPtr FunTypeM2)
+
+manyArgsM2 :: FunTypeM2
+manyArgsM2 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM2 :: Handle -> IO ()
+testM2 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM2 manyArgsM2
+ hPrint stdout (callFunM2 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM2 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM3 = Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM3 :: FunPtr FunTypeM3 -> FunTypeM3
+foreign import ccall "wrapper" mkFunM3 :: FunTypeM3 -> IO (FunPtr FunTypeM3)
+
+manyArgsM3 :: FunTypeM3
+manyArgsM3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM3 :: Handle -> IO ()
+testM3 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM3 manyArgsM3
+ hPrint stdout (callFunM3 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM4 = Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM4 :: FunPtr FunTypeM4 -> FunTypeM4
+foreign import ccall "wrapper" mkFunM4 :: FunTypeM4 -> IO (FunPtr FunTypeM4)
+
+manyArgsM4 :: FunTypeM4
+manyArgsM4 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM4 :: Handle -> IO ()
+testM4 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM4 manyArgsM4
+ hPrint stdout (callFunM4 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM4 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM5 = Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM5 :: FunPtr FunTypeM5 -> FunTypeM5
+foreign import ccall "wrapper" mkFunM5 :: FunTypeM5 -> IO (FunPtr FunTypeM5)
+
+manyArgsM5 :: FunTypeM5
+manyArgsM5 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM5 :: Handle -> IO ()
+testM5 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM5 manyArgsM5
+ hPrint stdout (callFunM5 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM5 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM6 = Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM6 :: FunPtr FunTypeM6 -> FunTypeM6
+foreign import ccall "wrapper" mkFunM6 :: FunTypeM6 -> IO (FunPtr FunTypeM6)
+
+manyArgsM6 :: FunTypeM6
+manyArgsM6 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM6 :: Handle -> IO ()
+testM6 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM6 manyArgsM6
+ hPrint stdout (callFunM6 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM6 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM7 = Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM7 :: FunPtr FunTypeM7 -> FunTypeM7
+foreign import ccall "wrapper" mkFunM7 :: FunTypeM7 -> IO (FunPtr FunTypeM7)
+
+manyArgsM7 :: FunTypeM7
+manyArgsM7 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM7 :: Handle -> IO ()
+testM7 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM7 manyArgsM7
+ hPrint stdout (callFunM7 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM7 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM8 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM8 :: FunPtr FunTypeM8 -> FunTypeM8
+foreign import ccall "wrapper" mkFunM8 :: FunTypeM8 -> IO (FunPtr FunTypeM8)
+
+manyArgsM8 :: FunTypeM8
+manyArgsM8 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM8 :: Handle -> IO ()
+testM8 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM8 manyArgsM8
+ hPrint stdout (callFunM8 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM8 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM9 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double
+ -> Int -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM9 :: FunPtr FunTypeM9 -> FunTypeM9
+foreign import ccall "wrapper" mkFunM9 :: FunTypeM9 -> IO (FunPtr FunTypeM9)
+
+manyArgsM9 :: FunTypeM9
+manyArgsM9 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM9 :: Handle -> IO ()
+testM9 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM9 manyArgsM9
+ hPrint stdout (callFunM9 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM9 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM10 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Double -> Int -> Int -> Double
+
+foreign import ccall "dynamic" callFunM10 :: FunPtr FunTypeM10 -> FunTypeM10
+foreign import ccall "wrapper" mkFunM10 :: FunTypeM10 -> IO (FunPtr FunTypeM10)
+
+manyArgsM10 :: FunTypeM10
+manyArgsM10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + a10) * 31 +
+ fromIntegral a11) * 31 + fromIntegral a12
+
+testM10 :: Handle -> IO ()
+testM10 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM10 manyArgsM10
+ hPrint stdout (callFunM10 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM11 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Double -> Int -> Double
+
+foreign import ccall "dynamic" callFunM11 :: FunPtr FunTypeM11 -> FunTypeM11
+foreign import ccall "wrapper" mkFunM11 :: FunTypeM11 -> IO (FunPtr FunTypeM11)
+
+manyArgsM11 :: FunTypeM11
+manyArgsM11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ a11) * 31 + fromIntegral a12
+
+testM11 :: Handle -> IO ()
+testM11 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM11 manyArgsM11
+ hPrint stdout (callFunM11 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+type FunTypeM12 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> Double -> Double
+
+foreign import ccall "dynamic" callFunM12 :: FunPtr FunTypeM12 -> FunTypeM12
+foreign import ccall "wrapper" mkFunM12 :: FunTypeM12 -> IO (FunPtr FunTypeM12)
+
+manyArgsM12 :: FunTypeM12
+manyArgsM12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 +
+ fromIntegral a3) * 31 + fromIntegral a4) * 31 +
+ fromIntegral a5) * 31 + fromIntegral a6) * 31 +
+ fromIntegral a7) * 31 + fromIntegral a8) * 31 +
+ fromIntegral a9) * 31 + fromIntegral a10) * 31 +
+ fromIntegral a11) * 31 + a12
+
+testM12 :: Handle -> IO ()
+testM12 stdout = do
+ a1 <- randomIO
+ a2 <- randomIO
+ a3 <- randomIO
+ a4 <- randomIO
+ a5 <- randomIO
+ a6 <- randomIO
+ a7 <- randomIO
+ a8 <- randomIO
+ a9 <- randomIO
+ a10 <- randomIO
+ a11 <- randomIO
+ a12 <- randomIO
+ funAddr <- mkFunM12 manyArgsM12
+ hPrint stdout (callFunM12 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
+ manyArgsM12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
+ freeHaskellFunPtr funAddr
+
+--------------------------------------------------------------------------------
+
+rep :: Handle -> String -> (Handle -> IO ()) -> IO ()
+rep stdout msg tst = do
+ hPutStrLn stdout ("Testing " ++ msg ++ "...")
+ sequence_ (replicate 10 (tst stdout))
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ setStdGen (mkStdGen 4711)
+ rep stdout "5 Int arguments" test5I
+ rep stdout "11 Double arguments" test11D
+ rep stdout "11 mixed arguments" test11M
+ rep stdout "Double as 1st argument, rest Int" testM1
+ rep stdout "Double as 2nd argument, rest Int" testM2
+ rep stdout "Double as 3rd argument, rest Int" testM3
+ rep stdout "Double as 4th argument, rest Int" testM4
+ rep stdout "Double as 5th argument, rest Int" testM5
+ rep stdout "Double as 6th argument, rest Int" testM6
+ rep stdout "Double as 7th argument, rest Int" testM7
+ rep stdout "Double as 8th argument, rest Int" testM8
+ rep stdout "Double as 9th argument, rest Int" testM9
+ rep stdout "Double as 10th argument, rest Int" testM10
+ rep stdout "Double as 11th argument, rest Int" testM11
+ rep stdout "Double as 12th argument, rest Int" testM12
diff --git a/ghc-tests/tests/HClose003.hs b/ghc-tests/tests/HClose003.hs
new file mode 100644
index 0000000000000000000000000000000000000000..87d55ff918e2afdf58a5a7ed016364062b9f7c3d
--- /dev/null
+++ b/ghc-tests/tests/HClose003.hs
@@ -0,0 +1,45 @@
+-- Test for #3128, file descriptor leak when hClose fails
+module HClose003 where
+
+import System.IO
+import Control.Exception
+import Data.Char
+
+import System.Posix
+import qualified GHC.IO.Device as IODevice
+import GHC.IO.Handle
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.Types
+import System.Posix.Internals
+import Tasty.Bronze
+
+
+main stdout _stderr = do
+ (read,write) <- createPipe
+ hread <- fdToHandle read
+ hwrite <- fdToHandle write
+
+ -- close the FD without telling the IO library:
+ showPossibleException stdout (hClose hread)
+ hIsOpen hread >>= hPrint stdout
+
+ -- put some data in the Handle's write buffer:
+ hPutStr hwrite "testing"
+ -- now try to close the Handle:
+ showPossibleException stdout (hClose hwrite)
+ hIsOpen hwrite >>= hPrint stdout
+
+showPossibleException :: Handle -> IO () -> IO ()
+showPossibleException stdout f = do
+ e <- try f
+ hPutStrLn stdout (sanitise (show (e :: Either SomeException ())))
+ where
+ -- we don't care which file descriptor it is
+ sanitise [] = []
+ sanitise (x:xs) = if isDigit x then ('X':(sanitise' xs)) else (x:(sanitise xs))
+ sanitise' [] = []
+ sanitise' (x:xs) = if isDigit x then (sanitise' xs) else (x:(sanitise xs))
+
+naughtyClose h =
+ withHandle_ "naughtyClose" h $ \ Handle__{haDevice=dev} ->
+ IODevice.close dev
diff --git a/ghc-tests/tests/HWaitPipe.hs b/ghc-tests/tests/HWaitPipe.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4f8ff011c6f8ced5e2617cb4b47bdfee2c9d274e
--- /dev/null
+++ b/ghc-tests/tests/HWaitPipe.hs
@@ -0,0 +1,24 @@
+module HWaitPipe where
+import Control.Concurrent
+import Control.Monad
+import GHC.Clock
+import System.IO
+import System.Posix.IO
+import System.Timeout
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ (readPipe, _) <- createPipe
+ readPipeHandle <- fdToHandle readPipe
+ let nanoSecondsPerSecond = 1000 * 1000 * 1000
+ let milliSecondsPerSecond = 1000
+ let timeToSpend = 1
+ let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
+ let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
+ start <- getMonotonicTimeNSec
+ b <- hWaitForInput readPipeHandle timeToSpendMilli
+ end <- getMonotonicTimeNSec
+ let timeSpentNano = fromIntegral $ end - start
+ let delta = timeSpentNano - timeToSpendNano
+ -- We can never wait for a shorter amount of time than specified
+ hPutStrLn stdout $ "delta >= 0: " ++ show (delta > 0)
diff --git a/ghc-tests/tests/HWaitSocket.hs b/ghc-tests/tests/HWaitSocket.hs
new file mode 100644
index 0000000000000000000000000000000000000000..980f126d8f650e2e8f423336d2d837ed4cf6e23f
--- /dev/null
+++ b/ghc-tests/tests/HWaitSocket.hs
@@ -0,0 +1,49 @@
+module HWaitSocket where
+import Control.Concurrent
+import Control.Monad
+import Foreign.C
+import GHC.Clock
+import GHC.IO.Device
+import GHC.IO.Handle.FD
+import System.IO
+import System.Posix.IO
+import System.Posix.Types
+import System.Timeout
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ socketHandle <- makeTestSocketHandle
+ let nanoSecondsPerSecond = 1000 * 1000 * 1000
+ let milliSecondsPerSecond = 1000
+ let timeToSpend = 1
+ let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
+ let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
+ start <- getMonotonicTimeNSec
+ b <- hWaitForInput socketHandle timeToSpendMilli
+ end <- getMonotonicTimeNSec
+ let timeSpentNano = fromIntegral $ end - start
+ let delta = timeSpentNano - timeToSpendNano
+ -- We can never wait for a shorter amount of time than specified
+ hPutStrLn stdout $ "delta >= 0: " ++ show (delta >= 0)
+
+foreign import ccall unsafe "socket" c_socket ::
+ CInt -> CInt -> CInt -> IO CInt
+
+makeTestSocketHandle :: IO Handle
+makeTestSocketHandle = do
+ sockNum <-
+ c_socket
+ 1 -- PF_LOCAL
+ 2 -- SOCK_DGRAM
+ 0
+ let fd = fromIntegral sockNum :: Fd
+ h <-
+ fdToHandle'
+ (fromIntegral fd)
+ (Just GHC.IO.Device.Stream)
+ True
+ "testsocket"
+ ReadMode
+ True
+ hSetBuffering h NoBuffering
+ pure h
diff --git a/ghc-tests/tests/MVar001.hs b/ghc-tests/tests/MVar001.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c6dc97f1c9c97ad5483cc6aecad4c9ee350921bc
--- /dev/null
+++ b/ghc-tests/tests/MVar001.hs
@@ -0,0 +1,145 @@
+module MVar001 where
+import Test.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Control.Monad
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+
+data Action = NewEmptyMVar | NewMVar Int | TakeMVar | ReadMVar | PutMVar Int
+ | SwapMVar Int | IsEmptyMVar | ReturnInt Int | ReturnBool Bool
+ deriving (Eq,Show)
+
+testMVar :: TestTree
+testMVar = testGroup "MVar001" $ [
+ testProperty "NewEIs_NewERet" prop_NewEIs_NewERet
+ , testProperty "NewIs_NewRet" prop_NewIs_NewRet
+ , testProperty "NewTake_NewRet" prop_NewTake_NewRet
+ , testProperty "NewEPutTake_NewERet" prop_NewEPutTake_NewERet
+ , testProperty "NewRead_NewRet" prop_NewRead_NewRet
+ , testProperty "NewSwap_New" prop_NewSwap_New ]
+
+
+prop_NewEIs_NewERet =
+ [NewEmptyMVar,IsEmptyMVar] =^ [NewEmptyMVar,ReturnBool True]
+
+prop_NewIs_NewRet n =
+ [NewMVar n,IsEmptyMVar] =^ [NewMVar n,ReturnBool False]
+
+prop_NewTake_NewRet n =
+ [NewMVar n,TakeMVar] =^ [NewEmptyMVar,ReturnInt n]
+
+prop_NewEPutTake_NewERet n =
+ [NewEmptyMVar,PutMVar n,TakeMVar] =^
+ [NewEmptyMVar,ReturnInt n]
+
+prop_NewRead_NewRet n =
+ [NewMVar n,ReadMVar] =^ [NewMVar n,ReturnInt n]
+
+prop_NewSwap_New m n =
+ [NewMVar m,SwapMVar n] =^ [NewMVar n]
+
+
+perform :: [Action] -> IO ([Bool],[Int])
+perform [] = return ([],[])
+
+perform (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
+ NewEmptyMVar -> newEmptyMVar >>= \mv -> perform' mv as
+ NewMVar n -> newMVar n >>= \mv -> perform' mv as
+ _ -> error $ "Please use NewMVar or NewEmptyMVar as first "
+ ++ "action"
+
+
+perform' :: MVar Int -> [Action] -> IO ([Bool],[Int])
+perform' _ [] = return ([],[])
+
+perform' mv (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' mv as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' mv as)
+ TakeMVar -> liftM2 (\v (b,l) -> (b,v:l)) (takeMVar mv)
+ (perform' mv as)
+ ReadMVar -> liftM2 (\v (b,l) -> (b,v:l)) (readMVar mv)
+ (perform' mv as)
+ PutMVar n -> putMVar mv n >> perform' mv as
+ SwapMVar n -> swapMVar mv n >> perform' mv as
+ IsEmptyMVar -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyMVar mv)
+ (perform' mv as)
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions =
+ oneof [liftM (NewEmptyMVar:) (actions' True),
+ liftM2 (:) (liftM NewMVar arbitrary) (actions' False)]
+
+
+actions' :: Bool -> Gen [Action]
+actions' empty =
+ oneof ([return [],
+ liftM (IsEmptyMVar:) (actions' empty)] ++
+ if empty
+ then [liftM2 (:) (liftM PutMVar arbitrary) (actions' False)]
+ else []
+ ++
+ if empty
+ then []
+ else [liftM (TakeMVar:) (actions' True)]
+ ++
+ if empty
+ then []
+ else [liftM (ReadMVar:) (actions' False)]
+ ++
+ if empty
+ then []
+ else [liftM2 (:) (liftM SwapMVar arbitrary) (actions' False)] )
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta True c))
+ (\suff -> observe c suff == observe c' suff)
+ where observe x suff = unsafePerformIO (perform (x++suff))
+
+
+(^=^) :: [Action] -> [Action] -> Property
+c ^=^ c' =
+ forAll actions
+ (\pref -> forAll (actions' (delta True (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Bool -> [Action] -> Bool
+delta b [] = b
+
+delta b (ReturnInt _:as) = delta b as
+
+delta b (ReturnBool _:as) = delta b as
+
+delta _ (NewEmptyMVar:as) = delta True as
+
+delta _ (NewMVar _:as) = delta False as
+
+delta b (TakeMVar:as) = delta (if b
+ then error "take on empty MVar"
+ else True) as
+
+delta b (ReadMVar:as) = delta (if b
+ then error "read on empty MVar"
+ else False) as
+
+delta _ (PutMVar _:as) = delta False as
+
+delta b (SwapMVar _:as) = delta (if b
+ then error "swap on empty MVar"
+ else False) as
+
+delta b (IsEmptyMVar:as) = delta b as
diff --git a/ghc-tests/tests/MaessenHashtab/Data/HashTab.hs b/ghc-tests/tests/MaessenHashtab/Data/HashTab.hs
new file mode 100644
index 0000000000000000000000000000000000000000..fe2d86769a48c0204e0679825b123b25ba68a959
--- /dev/null
+++ b/ghc-tests/tests/MaessenHashtab/Data/HashTab.hs
@@ -0,0 +1,340 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.HashTable
+-- Copyright : (c) The University of Glasgow 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- An implementation of extensible hash tables, as described in
+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,
+-- pp. 446--457. The implementation is also derived from the one
+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).
+--
+-----------------------------------------------------------------------------
+
+module MaessenHashtab.Data.HashTab (
+ -- * Basic hash table operations
+ HashTable, new, insert, delete, lookup, update,
+ -- * Converting to and from lists
+ fromList, toList,
+ -- * Hash functions
+ -- $hash_functions
+ hashInt, hashString,
+ prime,
+ -- * Diagnostics
+ longestChain
+ ) where
+
+-- This module is imported by Data.Typeable, which is pretty low down in the
+-- module hierarchy, so don't import "high-level" modules
+
+-- Right now we import high-level modules with gay abandon.
+import Prelude hiding ( lookup )
+import Data.Tuple ( fst )
+import Data.Bits
+import Data.Maybe
+import Data.List ( maximumBy, partition )
+import Data.Int ( Int32 )
+
+import Data.Array.Base
+import Data.Array hiding (bounds)
+import Data.Array.IO
+
+import Data.Char ( ord )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Control.Monad ( mapM, sequence_ )
+
+
+-----------------------------------------------------------------------
+
+readHTArray :: HTArray a -> Int32 -> IO a
+readMutArray :: MutArray a -> Int32 -> IO a
+writeMutArray :: MutArray a -> Int32 -> a -> IO ()
+freezeArray :: MutArray a -> IO (HTArray a)
+thawArray :: HTArray a -> IO (MutArray a)
+newMutArray :: (Int32, Int32) -> a -> IO (MutArray a)
+#if defined(DEBUG) || defined(__NHC__)
+type MutArray a = IOArray Int32 a
+type HTArray a = MutArray a
+newMutArray = newArray
+readHTArray = readArray
+readMutArray = readArray
+writeMutArray = writeArray
+freezeArray = return
+thawArray = return
+#else
+type MutArray a = IOArray Int32 a
+type HTArray a = Array Int32 a
+newMutArray = newArray
+readHTArray arr i = return $! (unsafeAt arr (fromIntegral i))
+readMutArray arr i = unsafeRead arr (fromIntegral i)
+writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x
+freezeArray = unsafeFreeze
+thawArray = unsafeThaw
+#endif
+
+newtype HashTable key val = HashTable (IORef (HT key val))
+-- TODO: the IORef should really be an MVar.
+
+data HT key val
+ = HT {
+ kcount :: !Int32, -- Total number of keys.
+ buckets :: !(HTArray [(key,val)]),
+ bmask :: !Int32,
+ hash_fn :: key -> Int32,
+ cmp :: key -> key -> Bool
+ }
+
+-- -----------------------------------------------------------------------------
+-- Sample hash functions
+
+-- $hash_functions
+--
+-- This implementation of hash tables uses the low-order /n/ bits of the hash
+-- value for a key, where /n/ varies as the hash table grows. A good hash
+-- function therefore will give an even distribution regardless of /n/.
+--
+-- If your keyspace is integrals such that the low-order bits between
+-- keys are highly variable, then you could get away with using 'id'
+-- as the hash function.
+--
+-- We provide some sample hash functions for 'Int' and 'String' below.
+
+-- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@
+-- where P is a suitable prime (currently 1500007). Should give
+-- reasonable results for most distributions of 'Int' values, except
+-- when the keys are all multiples of the prime!
+--
+hashInt :: Int -> Int32
+hashInt = (`rem` prime) . fromIntegral
+
+-- | A sample hash function for 'String's. The implementation is:
+--
+-- > hashString = fromIntegral . foldr f 0
+-- > where f c m = ord c + (m * 128) `rem` 1500007
+--
+-- which seems to give reasonable results.
+--
+hashString :: String -> Int32
+hashString = fromIntegral . foldl f 0
+ where f m c = ord c + (m * 128) `rem` fromIntegral prime
+
+-- | A prime larger than the maximum hash table size
+prime :: Int32
+prime = 1500007
+
+-- -----------------------------------------------------------------------------
+-- Parameters
+
+tABLE_MAX = 1024 * 1024 :: Int32 -- Maximum size of hash table
+#if tABLE_MIN
+#else
+tABLE_MIN = 16 :: Int32
+
+hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket
+
+hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation
+#endif
+
+{- Hysteresis favors long association-list-like behavior for small tables. -}
+
+-- -----------------------------------------------------------------------------
+-- Creating a new hash table
+
+-- | Creates a new hash table. The following property should hold for the @eq@
+-- and @hash@ functions passed to 'new':
+--
+-- > eq A B => hash A == hash B
+--
+new
+ :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys
+ -> (key -> Int32) -- ^ @hash@: A hash function on keys
+ -> IO (HashTable key val) -- ^ Returns: an empty hash table
+
+new cmpr hash = do
+ -- make a new hash table with a single, empty, segment
+ let mask = tABLE_MIN-1
+ bkts' <- newMutArray (0,mask) []
+ bkts <- freezeArray bkts'
+
+ let
+ kcnt = 0
+ ht = HT { buckets=bkts, kcount=kcnt, bmask=mask,
+ hash_fn=hash, cmp=cmpr }
+
+ table <- newIORef ht
+ return (HashTable table)
+
+-- -----------------------------------------------------------------------------
+-- Inserting a key\/value pair into the hash table
+
+-- | Inserts a key\/value mapping into the hash table.
+--
+-- Note that 'insert' doesn't remove the old entry from the table -
+-- the behaviour is like an association list, where 'lookup' returns
+-- the most-recently-inserted mapping for a key in the table. The
+-- reason for this is to keep 'insert' as efficient as possible. If
+-- you need to update a mapping, then we provide 'update'.
+--
+insert :: HashTable key val -> key -> val -> IO ()
+
+insert (HashTable ref) key val = do
+ table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref
+ let table1 = table{ kcount = k+1 }
+ indx = bucketIndex table key
+ bucket <- readHTArray bkts indx
+ bkts' <- thawArray bkts
+ writeMutArray bkts' indx ((key,val):bucket)
+ freezeArray bkts'
+ table2 <-
+ if tooBig k b
+ then expandHashTable table1
+ else return table1
+ writeIORef ref table2
+
+tooBig :: Int32 -> Int32 -> Bool
+tooBig k b = k-hYSTERESIS > hLOAD * b
+
+bucketIndex :: HT key val -> key -> Int32
+bucketIndex HT{ hash_fn=hash, bmask=mask } key =
+ let h = hash key
+ in (h .&. mask)
+
+expandHashTable :: HT key val -> IO (HT key val)
+expandHashTable
+ table@HT{ buckets=bkts, bmask=mask } = do
+ let
+ oldsize = mask + 1
+ newmask = mask + mask + 1
+ newsize = newmask + 1
+ --
+ if newsize > tABLE_MAX
+ then return table
+ else do
+ --
+ newbkts' <- newMutArray (0,newmask) []
+
+ let
+ table'=table{ bmask=newmask }
+ splitBucket oldindex = do
+ bucket <- readHTArray bkts oldindex
+ let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket
+ writeMutArray newbkts' oldindex oldb
+ writeMutArray newbkts' (oldindex + oldsize) newb
+ mapM_ splitBucket [0..mask]
+
+ newbkts <- freezeArray newbkts'
+
+ return ( table'{ buckets=newbkts } )
+
+-- -----------------------------------------------------------------------------
+-- Deleting a mapping from the hash table
+
+-- Remove a key from a bucket
+deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)])
+deleteBucket _ [] = (0,[])
+deleteBucket del (pair@(k,_):bucket) =
+ case deleteBucket del bucket of
+ (dels, bucket') | del k -> dels' `seq` (dels', bucket')
+ | otherwise -> (dels, pair:bucket')
+ where dels' = dels + 1
+
+-- | Remove an entry from the hash table.
+delete :: HashTable key val -> key -> IO ()
+
+delete (HashTable ref) key = do
+ table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref
+ let indx = bucketIndex table key
+ bkts' <- thawArray bkts
+ bucket <- readMutArray bkts' indx
+ let (removed,bucket') = deleteBucket (cmpr key) bucket
+ writeMutArray bkts' indx bucket'
+ freezeArray bkts'
+ writeIORef ref ( table{kcount = kcnt - removed} )
+
+-- -----------------------------------------------------------------------------
+-- Updating a mapping in the hash table
+
+-- | Updates an entry in the hash table, returning 'True' if there was
+-- already an entry for this key, or 'False' otherwise. After 'update'
+-- there will always be exactly one entry for the given key in the table.
+--
+-- 'insert' is more efficient than 'update' if you don't care about
+-- multiple entries, or you know for sure that multiple entries can't
+-- occur. However, 'update' is more efficient than 'delete' followed
+-- by 'insert'.
+update :: HashTable key val -> key -> val -> IO Bool
+
+update (HashTable ref) key val = do
+ table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref
+ let indx = bucketIndex table key
+ bkts' <- thawArray bkts
+ bucket <- readMutArray bkts' indx
+ let (deleted,bucket') = deleteBucket (cmpr key) bucket
+ k' = k + 1 - deleted
+ table1 = table{ kcount=k' }
+
+ writeMutArray bkts' indx ((key,val):bucket')
+ freezeArray bkts'
+ table2 <-
+ if tooBig k' b -- off by one from insert's resize heuristic.
+ then expandHashTable table1
+ else return table1
+ writeIORef ref table2
+ return (deleted>0)
+
+-- -----------------------------------------------------------------------------
+-- Looking up an entry in the hash table
+
+-- | Looks up the value of a key in the hash table.
+lookup :: HashTable key val -> key -> IO (Maybe val)
+
+lookup (HashTable ref) key = do
+ table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref
+ let indx = bucketIndex table key
+ bucket <- readHTArray bkts indx
+ case [ val | (key',val) <- bucket, cmpr key key' ] of
+ [] -> return Nothing
+ (v:_) -> return (Just v)
+
+-- -----------------------------------------------------------------------------
+-- Converting to/from lists
+
+-- | Convert a list of key\/value pairs into a hash table. Equality on keys
+-- is taken from the Eq instance for the key type.
+--
+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)
+fromList hash list = do
+ table <- new (==) hash
+ sequence_ [ insert table k v | (k,v) <- list ]
+ return table
+
+-- | Converts a hash table to a list of key\/value pairs.
+--
+toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)]
+toList (HashTable ref) = do
+ HT{ buckets=bkts, bmask=b } <- readIORef ref
+ fmap concat (mapM (readHTArray bkts) [0..b])
+
+-- -----------------------------------------------------------------------------
+-- Diagnostics
+
+-- | This function is useful for determining whether your hash function
+-- is working well for your data set. It returns the longest chain
+-- of key\/value pairs in the hash table for which all the keys hash to
+-- the same bucket. If this chain is particularly long (say, longer
+-- than 10 elements), then it might be a good idea to try a different
+-- hash function.
+--
+longestChain :: HashTable key val -> IO [(key,val)]
+longestChain (HashTable ref) = do
+ HT{ buckets=bkts, bmask=b } <- readIORef ref
+ let lengthCmp (_:x)(_:y) = lengthCmp x y
+ lengthCmp [] [] = EQ
+ lengthCmp [] _ = LT
+ lengthCmp _ [] = GT
+ fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b])
diff --git a/ghc-tests/tests/MaessenHashtab/HashTest.hs b/ghc-tests/tests/MaessenHashtab/HashTest.hs
new file mode 100644
index 0000000000000000000000000000000000000000..660dd8c2e5c2bffd06a1e0b43593c0f9005a4d86
--- /dev/null
+++ b/ghc-tests/tests/MaessenHashtab/HashTest.hs
@@ -0,0 +1,273 @@
+{- Test code for Data.HashTable -}
+
+module MaessenHashtab.HashTest(hashTest) where
+
+import Prelude hiding (lookup)
+import qualified Prelude (lookup)
+import Data.Maybe(isJust,isNothing)
+import Data.Int(Int32)
+import Test.QuickCheck
+import System.IO.Unsafe(unsafePerformIO)
+import MaessenHashtab.Data.HashTab
+import Control.Monad(liftM2, foldM)
+import System.Random
+import System.Environment
+import System.IO
+
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+infixr 0 ==.
+infixr 0 ==~
+infixr 0 ~~
+
+type HT = HashTable Int Int
+newtype HashFun = HF {unHF :: (Int -> Int32)}
+data Empty = E {e :: (IO HT), hfe :: HashFun}
+data MkH = H {h :: (IO HT), hfh :: HashFun}
+newtype List a = L [a]
+
+data Action = Lookup Int
+ | Insert Int Int
+ | Delete Int
+ | Update Int Int
+ deriving (Show)
+
+instance Arbitrary Action where
+ arbitrary = frequency [(10,fmap Lookup arbitrary),
+ (5, liftM2 Insert arbitrary arbitrary),
+ (3, liftM2 Update arbitrary arbitrary),
+ (1, fmap Delete arbitrary)]
+
+simA :: [Action] -> [Either Bool [Int]]
+simA = fst . foldl sim ([],[])
+ where sim :: ([Either Bool [Int]], [Action]) -> Action ->
+ ([Either Bool [Int]], [Action])
+ sim (res, past) (Lookup k) = (Right (lkup k past) : res, past)
+ sim (res, past) (Insert k v) = (res, Insert k v : past)
+ sim (res, past) (Delete k) = (res, Delete k : past)
+ sim (res, past) (Update k v) =
+ (Left (not (null l)) : res, Update k v : past)
+ where l = lkup k past
+ lkup _ [] = []
+ lkup k (Delete k' : _)
+ | k==k' = []
+ lkup k (Update k' v : _)
+ | k==k' = [v]
+ lkup k (Insert k' v : past)
+ | k==k' = v:lkup k past
+ lkup k (_ : past) = lkup k past
+
+runA :: HashFun -> [Action] -> IO [Either Bool (Maybe Int)]
+runA hf acts = do
+ ht <- new (==) (unHF hf)
+ let run res (Lookup a) = fmap (lkup res) $ lookup ht a
+ run res (Insert k v) = insert ht k v >> return res
+ run res (Delete k) = delete ht k >> return res
+ run res (Update k v) = fmap (upd res) $ update ht k v
+ lkup res m = Right m : res
+ upd res b = Left b : res
+ foldM run [] acts
+
+(~~) :: IO [Either Bool (Maybe Int)] -> [Either Bool [Int]] -> Bool
+acts ~~ sims = and $ zipWith same (unsafePerformIO acts) sims
+ where same (Left b) (Left b') = b==b'
+ same (Right Nothing) (Right []) = True
+ same (Right (Just a)) (Right xs) = a `elem` xs
+ same _ _ = False
+
+lookups :: HT -> [Int] -> IO [Maybe Int]
+lookups ht ks = mapM (lookup ht) ks
+
+instance Show HashFun where
+ showsPrec _ (HF hf) r
+ | hf 1 == 0 = "degenerate"++r
+ | otherwise = "usual"++r
+
+instance Show Empty where
+ showsPrec _ ee r = shows (hfe ee) r
+
+instance Show MkH where
+ showsPrec _ hh r = shows (hfh hh) $
+ ("; "++shows (unsafePerformIO (h hh >>= toList)) r)
+
+instance Show a => Show (List a) where
+ showsPrec _ (L l) r = shows l r
+
+instance Arbitrary HashFun where
+ arbitrary = frequency [(20,return (HF hashInt)),
+ (1,return (HF (const 0)))]
+
+instance Arbitrary Empty where
+ arbitrary = fmap mkE arbitrary
+ where mkE (HF hf) = E {e = new (==) hf, hfe=HF hf}
+
+instance Arbitrary a => Arbitrary (List a) where
+ arbitrary = do
+ sz <- frequency [(50, sized return),
+ (1,return (4096*2)),
+ (0, return (1024*1024))]
+ resize sz $ fmap L $ sized vector
+
+instance Arbitrary MkH where
+ arbitrary = do
+ hf <- arbitrary
+ L list <- arbitrary
+ let mkH act = H { h = act, hfh = hf }
+ return (mkH . fromList (unHF hf) $ list)
+
+(==~) :: (Eq a) => IO a -> IO a -> Bool
+act1 ==~ act2 = unsafePerformIO act1 == unsafePerformIO act2
+
+(==.) :: (Eq a) => IO a -> a -> Bool
+act ==. v = unsafePerformIO act == v
+
+notin :: (Testable a) => Int -> MkH -> a -> Property
+k `notin` hh = \prop ->
+ let f = (not . isJust . unsafePerformIO) (h hh >>= flip lookup k) in
+ f `trivial` prop
+
+prop_emptyLookup :: Empty -> Int -> Bool
+prop_emptyLookup ee k =
+ isNothing . unsafePerformIO $
+ (do mt <- e ee
+ lookup mt k)
+
+prop_emptyToList :: Empty -> Bool
+prop_emptyToList ee =
+ (do mt <- e ee
+ toList mt) ==. []
+
+prop_emptyFromList :: HashFun -> Int -> Bool
+prop_emptyFromList hf k =
+ (do mt <- new (==) (unHF hf) :: IO HT
+ lookup mt k) ==~
+ (do mt <- fromList (unHF hf) []
+ lookup mt k)
+
+prop_insert :: MkH -> Int -> Int -> Bool
+prop_insert hh k v =
+ (do ht <- h hh
+ insert ht k v
+ lookup ht k) ==. Just v
+
+prop_insertu :: MkH -> Int -> Int -> List Int -> Bool
+prop_insertu hh k v (L ks) =
+ let ks' = filter (k /=) ks in
+ (do ht <- h hh
+ insert ht k v
+ lookups ht ks') ==~
+ (do ht <- h hh
+ lookups ht ks')
+
+prop_delete :: MkH -> Int -> Property
+prop_delete hh k =
+ k `notin` hh $
+ isNothing . unsafePerformIO $
+ (do ht <- h hh
+ delete ht k
+ lookup ht k)
+
+prop_deleteu :: MkH -> Int -> List Int -> Bool
+prop_deleteu hh k (L ks) =
+ let ks' = filter (k /=) ks in
+ (do ht <- h hh
+ delete ht k
+ lookups ht ks') ==~
+ (do ht <- h hh
+ lookups ht ks')
+
+naiveUpdate :: HT -> Int -> Int -> IO ()
+naiveUpdate ht k v = do
+ delete ht k
+ insert ht k v
+
+prop_update :: MkH -> Int -> Int -> List Int -> Bool
+prop_update hh k v (L ks) =
+ (do ht <- h hh
+ _ <- update ht k v
+ lookups ht ks) ==~
+ (do ht <- h hh
+ naiveUpdate ht k v
+ lookups ht ks)
+
+prop_updatec :: MkH -> Int -> Int -> Bool
+prop_updatec hh k v =
+ (do ht <- h hh
+ _ <- update ht k v
+ lookup ht k) ==. Just v
+
+prop_updateLookup :: MkH -> Int -> Int -> Property
+prop_updateLookup hh k v =
+ k `notin` hh $
+ (do ht <- h hh
+ update ht k v) ==~
+ (do ht <- h hh
+ fmap isJust (lookup ht k))
+
+prop_simulation :: HashFun -> List Action -> Property
+prop_simulation hf (L acts) =
+ (null acts `trivial`) $
+ runA hf acts ~~ simA acts
+
+trivial b = classify b "trivial"
+
+{-
+
+For "fromList" and "toList" properties we're a bit sloppy: we perform
+multiple insertions for a key (potentially) but give nor promises
+about which one we will retrieve with lookup, or what order they'll be
+returned by toList (or if they'll all be returned at all). Thus we
+insert all occurrences of a key with the same value, and do all
+checking via lookups.
+
+-}
+
+prop_fromList :: HashFun -> List Int -> List Int -> Property
+prop_fromList hf (L l) (L ks) =
+ null l `trivial`
+ let assocs = map (\t -> (t,t)) l in
+ ( do ht <- fromList (unHF hf) assocs
+ lookups ht ks) ==. (map (`Prelude.lookup` assocs) ks)
+
+prop_fromListInsert :: HashFun -> List (Int,Int) -> Int -> Int -> List Int -> Property
+prop_fromListInsert hf (L l) k v (L ks) =
+ null l `trivial`
+ (( do ht <- fromList (unHF hf) l
+ insert ht k v
+ lookups ht ks) ==~
+ ( do ht <- fromList (unHF hf) (l++[(k,v)])
+ lookups ht ks))
+
+prop_toList :: HashFun -> List Int -> List Int -> Property
+prop_toList hf (L l) (L ks) =
+ null l `trivial`
+ let assocs = map (\t -> (t,t)) l in
+ ( do ht <- fromList (unHF hf) assocs
+ lookups ht ks) ==~
+ ( do ht <- fromList (unHF hf) assocs
+ fmap (\as -> map (`Prelude.lookup` as) ks) $ toList ht )
+
+
+hashTest :: TestTree
+hashTest =
+ testGroup "hashTest" $
+ [ te "emptyLookup:" prop_emptyLookup,
+ te "emptyToList:" prop_emptyToList,
+ te "emptyFromList:" prop_emptyFromList,
+ te "insert:" prop_insert,
+ te "insertu:" prop_insertu,
+ te "delete:" prop_delete,
+ te "deleteu:" prop_deleteu,
+ te "update:" prop_update,
+ te "updatec:" prop_updatec,
+ te "updateLookup:" prop_updateLookup,
+ te "fromList:" prop_fromList,
+ te "fromListInsert:" prop_fromListInsert,
+ te "toList:" prop_toList,
+ te "simulation:" prop_simulation
+ ]
+
+ where
+ te name prop = testProperty name prop
diff --git a/ghc-tests/tests/Main.hs b/ghc-tests/tests/Main.hs
index b18367d5d78233ed941e980045c0718a7301b3a8..cb78f7e7981c4edc10d04fc62d8f39e57cca82a7 100644
--- a/ghc-tests/tests/Main.hs
+++ b/ghc-tests/tests/Main.hs
@@ -1,6 +1,75 @@
+{-# LANGUAGE NumericUnderscores #-}
module Main where
import System.Exit
+import Chan001
+import MVar001
+import qualified HClose003
+import qualified Concio002
+import qualified Rand001
+import qualified HWaitPipe
+import qualified HWaitSocket
+import qualified Cgrun068
+import qualified T7953
+import qualified CopySmallArrayStressTest
+import qualified T367
+import qualified T367A
+import qualified Throwto001
+import qualified PerformGC
+import qualified Conc023
+import qualified CompareAndSwap
+import qualified T13916
+import qualified T8138
+import qualified Drvrun022
+import qualified T3087
+import qualified FFI009
+import qualified T2267
+import qualified T14768
+import qualified T15038.Main
+import qualified TC191
+import qualified TC220
+import qualified T12926
+import qualified T14854
+import qualified T15038.Main as T15038
+import qualified MaessenHashtab.HashTest as HashTest
+import Arr016
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Tasty.Bronze
+import qualified Test.Tasty.Silver.Interactive as I
+
+bronzeDir = "bronze/"
+
main :: IO ()
-main = return ()
+main = defaultMainWithIngredients (I.interactiveTests (const False) : defaultIngredients) $
+ testGroup "all" [ testChan
+ , testMVar
+ , arr016
+ -- flaky
+ -- , goldenVsOut "hClose003" "bronze/hClose003.out" HClose003.main
+ , goldenVsOut "concio002" "bronze/concio002.out" Concio002.main
+ , goldenVsOut "rand001" "bronze/rand001.out" Rand001.main
+ , goldenVsOut "hwaitPipe" "bronze/hwaitPipe.out" HWaitPipe.main
+ , goldenVsOut "hwaitSocket" "bronze/hwaitSocket.out" HWaitSocket.main
+ , goldenVsOut "cgrun068" "bronze/cgrun068.out" (Cgrun068.main 100)
+ , goldenVsOut "CopySmallArrayStressTest" "bronze/CopySmallArrayStressTest.out" (CopySmallArrayStressTest.main 100)
+ , goldenVsOut "T7953" "bronze/T7953.out" T7953.main
+ , goldenVsOut "T367" "bronze/T367.out" T367.main
+ , goldenVsOut "CompareAndSwap" "bronze/CompareAndSwap.out" CompareAndSwap.main
+ , goldenVsOut "T8138" "bronze/T8138.out" T8138.main
+ , goldenVsOut "Drvrun022" "bronze/Drvrun022.out" Drvrun022.main
+ , goldenVsOut "T3087" "bronze/T3087.out" T3087.main
+ , goldenVsOut "FFI009" "bronze/FFI009.out" FFI009.main
+ , HashTest.hashTest
+ , goldenVsOut "T14768" "bronze/T14768.out" T14768.main
+ , goldenVsOut "T14854" "bronze/T14854.out" T14854.main
+ , goldenVsOut "T14854" "bronze/T15038.out" T15038.main
+
+ , localOption (mkTimeout 2_000_000) $ goldenVsOut "T367A" "bronze/T367A.out" T367A.main
+ , testCase "Throwto001" (Throwto001.main 1000 2000)
+ , testCase "PerformGC" (PerformGC.main 400)
+ , testCase "Conc023" Conc023.main
+ , testCase "T13916" T13916.main
+ ]
diff --git a/ghc-tests/tests/PerformGC.hs b/ghc-tests/tests/PerformGC.hs
new file mode 100644
index 0000000000000000000000000000000000000000..853fdcd08c1d8a9249c66223577f100723202329
--- /dev/null
+++ b/ghc-tests/tests/PerformGC.hs
@@ -0,0 +1,23 @@
+module PerformGC (main) where
+
+-- Test for #10545
+
+import System.Environment
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import System.Random
+import System.Mem
+import qualified Data.Set as Set
+
+main n = do
+ forkIO $ doSomeWork
+ forM_ [1..n] $ \n -> do threadDelay 1000; performMinorGC
+
+doSomeWork :: IO ()
+doSomeWork = forever $ do
+ ns <- replicateM 10000 randomIO :: IO [Int]
+ ms <- replicateM 1000 randomIO
+ let set = Set.fromList ns
+ elems = filter (`Set.member` set) ms
+ evaluate $ sum elems
diff --git a/ghc-tests/tests/Rand001.hs b/ghc-tests/tests/Rand001.hs
new file mode 100644
index 0000000000000000000000000000000000000000..96da02a8e7583102543b570bd371c3166c218222
--- /dev/null
+++ b/ghc-tests/tests/Rand001.hs
@@ -0,0 +1,23 @@
+module Rand001(main) where
+
+import System.Random
+import System.IO
+
+tstRnd rng = checkRange rng (genRnd 50 rng)
+
+genRnd n rng = take n (randomRs rng (mkStdGen 2))
+
+checkRange (lo,hi) = all pred
+ where
+ pred
+ | lo <= hi = \ x -> x >= lo && x <= hi
+ | otherwise = \ x -> x >= hi && x <= lo
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ hPrint stdout (tstRnd (1,5::Double))
+ hPrint stdout (tstRnd (1,5::Int))
+ hPrint stdout (tstRnd (10,54::Integer))
+ hPrint stdout (tstRnd ((-6),2::Int))
+ hPrint stdout (tstRnd (2,(-6)::Int))
+
diff --git a/ghc-tests/tests/T12926.hs b/ghc-tests/tests/T12926.hs
new file mode 100644
index 0000000000000000000000000000000000000000..66ed946b60c89318434041a3501a4f778fb3d628
--- /dev/null
+++ b/ghc-tests/tests/T12926.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -O2 #-}
+
+module T12926 where
+
+import GHC.Base
+import qualified Data.Vector.Unboxed.Base
+import qualified Data.Vector.Generic.Base
+import Data.Vector.Generic.Mutable
+import qualified Data.Vector.Generic.Mutable.Base
+import Data.Vector.Generic (fromList)
+
+data A = A Int Int Int
+
+instance Data.Vector.Unboxed.Base.Unbox A
+
+newtype instance Data.Vector.Unboxed.Base.MVector s_a4iX A
+ = MV_A (Data.Vector.Unboxed.Base.MVector s_a4iX (Int, Int, Int))
+
+instance MVector Data.Vector.Unboxed.Base.MVector A where
+ basicLength (MV_A v) =
+ basicLength v
+ basicUnsafeSlice idx len (MV_A v) =
+ MV_A (basicUnsafeSlice idx len v)
+ basicUnsafeNew len =
+ MV_A `liftM` (basicUnsafeNew len)
+ basicUnsafeWrite (MV_A v) idx val_a4iW =
+ basicUnsafeWrite v idx ((\ (A a_a4iT b_a4iU c_a4iV) -> (a_a4iT, b_a4iU, c_a4iV)) val_a4iW)
+
+newtype instance Data.Vector.Unboxed.Base.Vector A =
+ V_A (Data.Vector.Unboxed.Base.Vector (Int, Int, Int))
+
+instance Data.Vector.Generic.Base.Vector Data.Vector.Unboxed.Base.Vector A where
+
+mkA :: Data.Vector.Unboxed.Base.Vector A
+mkA = fromList []
diff --git a/ghc-tests/tests/T13916.hs b/ghc-tests/tests/T13916.hs
new file mode 100755
index 0000000000000000000000000000000000000000..09496d5f2c227a06ce7ded3160de254b99bf9ab7
--- /dev/null
+++ b/ghc-tests/tests/T13916.hs
@@ -0,0 +1,33 @@
+module T13916 where
+
+import Data.IORef
+import System.IO.Unsafe
+import Control.Concurrent.STM
+import Control.Concurrent.Async
+import Control.Concurrent
+import System.IO
+import System.Directory
+import System.FilePath
+import T13916_Bracket
+
+type Thing = MVar Bool
+
+main :: IO ()
+main = do
+ withEnvCache limit spawner $ \cache ->
+ forConcurrently_ [1..1000 :: Int] $ \n -> withEnv cache (\handle -> put handle n)
+ where
+ limit :: Limit
+ limit = Hard 1
+
+ put handle n = return ()
+
+spawner :: Spawner Thing
+spawner = Spawner
+ { maker = mkhandle
+ , killer = \thing -> takeMVar thing >> putMVar thing True
+ , isDead = \thing -> readMVar thing
+ }
+
+mkhandle :: IO Thing
+mkhandle = newMVar False
diff --git a/ghc-tests/tests/T13916_Bracket.hs b/ghc-tests/tests/T13916_Bracket.hs
new file mode 100755
index 0000000000000000000000000000000000000000..45b13733739e015f5aae2e11acd80ee50f232639
--- /dev/null
+++ b/ghc-tests/tests/T13916_Bracket.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{- |
+Module : Bracket
+Description : Handling multiple environments with bracket-like apis
+Maintainer : robertkennedy@clearwateranalytics.com
+Stability : stable
+
+This module is meant for ie Sql or mongo connections, where you may wish for some number of easy to grab
+environments. In particular, this assumes your connection has some initialization/release functions
+
+This module creates bugs with any optimizations enabled. The bugs do not occur if the program is in the same
+module.
+-}
+module T13916_Bracket (
+ -- * Data Types
+ Spawner(..), Limit(..), Cache,
+ -- * Usage
+ withEnvCache, withEnv
+ ) where
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TSem
+import Control.Exception hiding (handle)
+import Control.Monad
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+-- * Data Types
+-- | Tells the program how many environments it is allowed to spawn.
+-- A `Lax` limit will spawn extra connections if the `Cache` is empty,
+-- while a `Hard` limit will not spawn any more than the given number of connections simultaneously.
+--
+-- @since 0.3.7
+data Limit = Hard {getLimit :: {-# unpack #-} !Int}
+
+data Spawner env = Spawner
+ { maker :: IO env
+ , killer :: env -> IO ()
+ , isDead :: env -> IO Bool
+ }
+
+type VCache env = Vector (TMVar env)
+data Cache env = Unlimited { spawner :: Spawner env
+ , vcache :: !(VCache env)
+ }
+ | Limited { spawner :: Spawner env
+ , vcache :: !(VCache env)
+ , envsem :: TSem
+ }
+
+-- ** Initialization
+withEnvCache :: Limit -> Spawner env -> (Cache env -> IO a) -> IO a
+withEnvCache limit spawner = bracket starter releaseCache
+ where starter = case limit of
+ Hard n -> Limited spawner <$> initializeEmptyCache n <*> atomically (newTSem (fromIntegral n))
+
+-- ** Using a single value
+withEnv :: Cache env -> (env -> IO a) -> IO a
+withEnv cache = case cache of
+ Unlimited{..} -> withEnvUnlimited spawner vcache
+ Limited{..} -> withEnvLimited spawner vcache envsem
+
+-- *** Unlimited
+-- | Takes an env and returns it on completion of the function.
+-- If all envs are already taken or closed, this will spin up a new env.
+-- When the function finishes, this will attempt to put the env into the cache. If it cannot,
+-- it will kill the env. Note this can lead to many concurrent connections.
+--
+-- @since 0.3.5
+withEnvUnlimited :: Spawner env -> VCache env -> (env -> IO a) -> IO a
+withEnvUnlimited Spawner{..} cache = bracket taker putter
+ where
+ taker = do
+ mpipe <- atomically $ tryTakeEnv cache
+ case mpipe of
+ Nothing -> maker
+ Just env -> isDead env >>= \b -> if not b then return env else killer env >> maker
+
+ putter env = do
+ accepted <- atomically $ tryPutEnv cache env
+ unless accepted $ killer env
+
+-- *** Limited
+-- | Takes an env and returns it on completion of the function.
+-- If all envs are already taken, this will wait. This should have a constant number of environments
+--
+-- @since 0.3.6
+withEnvLimited :: Spawner env -> VCache env -> TSem -> (env -> IO a) -> IO a
+withEnvLimited spawner vcache envsem = bracket taker putter
+ where
+ taker = limitMakeEnv spawner vcache envsem
+ putter env = atomically $ putEnv vcache env
+
+limitMakeEnv :: Spawner env -> VCache env -> TSem -> IO env
+limitMakeEnv Spawner{..} vcache envsem = go
+ where
+ go = do
+ eenvpermission <- atomically $ ( Left <$> takeEnv vcache )
+ `orElse` ( Right <$> waitTSem envsem )
+ case eenvpermission of
+ Right () -> maker
+ Left env -> do
+ -- Given our env, we check if it's dead. If it's not, we are done and return it.
+ -- If it is dead, we release it, signal that a new env can be created, and then recurse
+ isdead <- isDead env
+ if not isdead then return env
+ else do
+ killer env
+ atomically $ signalTSem envsem
+ go
+
+-- * Low level
+initializeEmptyCache :: Int -> IO (VCache env)
+initializeEmptyCache n | n < 1 = return mempty
+ | otherwise = Vector.replicateM n newEmptyTMVarIO
+
+takeEnv :: VCache env -> STM env
+takeEnv = Vector.foldl folding retry
+ where folding m stmenv = m `orElse` takeTMVar stmenv
+
+tryTakeEnv :: VCache env -> STM (Maybe env)
+tryTakeEnv cache = (Just <$> takeEnv cache) `orElse` pure Nothing
+
+putEnv :: VCache env -> env -> STM ()
+putEnv cache env = Vector.foldl folding retry cache
+ where folding m stmenv = m `orElse` putTMVar stmenv env
+
+tryPutEnv :: VCache env -> env -> STM Bool
+tryPutEnv cache env = (putEnv cache env *> return True) `orElse` pure False
+
+releaseCache :: Cache env -> IO ()
+releaseCache cache = Vector.mapM_ qkRelease (vcache cache)
+ where qkRelease tenv = atomically (tryTakeTMVar tenv)
+ >>= maybe (return ()) (killer $ spawner cache)
diff --git a/ghc-tests/tests/T14768.hs b/ghc-tests/tests/T14768.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e8a82cf333db991173040878ccad2943092b1a73
--- /dev/null
+++ b/ghc-tests/tests/T14768.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T14768 where
+
+import Control.Monad (forM_, liftM)
+import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Generic.Mutable as M
+import qualified Data.Vector.Primitive as P
+import qualified Data.Vector.Unboxed as U
+import qualified Data.Vector.Unboxed.Mutable as MU
+import GHC.Exts
+import System.IO
+
+vec :: U.Vector Moebius
+vec = U.singleton Moebius0
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = hPrint stdout $ U.head vec == U.head vec
+
+data Moebius = Moebius0 | Moebius1 | Moebius2
+ deriving (Eq)
+
+fromMoebius :: Moebius -> Int
+fromMoebius Moebius0 = 0
+fromMoebius Moebius1 = 1
+fromMoebius Moebius2 = 2
+
+toMoebius :: Int -> Moebius
+toMoebius (I# i#) = tagToEnum# i#
+
+newtype instance U.MVector s Moebius = MV_Moebius (P.MVector s Int)
+newtype instance U.Vector Moebius = V_Moebius (P.Vector Int)
+
+instance U.Unbox Moebius
+
+instance M.MVector U.MVector Moebius where
+ basicLength (MV_Moebius v) = M.basicLength v
+ basicUnsafeSlice i n (MV_Moebius v) = MV_Moebius $ M.basicUnsafeSlice i n v
+ basicOverlaps (MV_Moebius v1) (MV_Moebius v2) = M.basicOverlaps v1 v2
+ basicUnsafeNew n = MV_Moebius `liftM` M.basicUnsafeNew n
+ basicInitialize (MV_Moebius v) = M.basicInitialize v
+ basicUnsafeReplicate n x = MV_Moebius `liftM` M.basicUnsafeReplicate n (fromMoebius x)
+ basicUnsafeRead (MV_Moebius v) i = toMoebius `liftM` M.basicUnsafeRead v i
+ basicUnsafeWrite (MV_Moebius v) i x = M.basicUnsafeWrite v i (fromMoebius x)
+ basicClear (MV_Moebius v) = M.basicClear v
+ basicSet (MV_Moebius v) x = M.basicSet v (fromMoebius x)
+ basicUnsafeCopy (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeCopy v1 v2
+ basicUnsafeMove (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeMove v1 v2
+ basicUnsafeGrow (MV_Moebius v) n = MV_Moebius `liftM` M.basicUnsafeGrow v n
+
+instance G.Vector U.Vector Moebius where
+ basicUnsafeFreeze (MV_Moebius v) = V_Moebius `liftM` G.basicUnsafeFreeze v
+ basicUnsafeThaw (V_Moebius v) = MV_Moebius `liftM` G.basicUnsafeThaw v
+ basicLength (V_Moebius v) = G.basicLength v
+ basicUnsafeSlice i n (V_Moebius v) = V_Moebius $ G.basicUnsafeSlice i n v
+ basicUnsafeIndexM (V_Moebius v) i = toMoebius `liftM` G.basicUnsafeIndexM v i
+ basicUnsafeCopy (MV_Moebius mv) (V_Moebius v) = G.basicUnsafeCopy mv v
+ elemseq _ = seq
diff --git a/ghc-tests/tests/T14854.hs b/ghc-tests/tests/T14854.hs
new file mode 100644
index 0000000000000000000000000000000000000000..070a94edebf57ed9599c03544675a91a53a6c5ac
--- /dev/null
+++ b/ghc-tests/tests/T14854.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE RecordWildCards #-}
+module T14854 (main) where
+
+import GHC.Data.FastString
+
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.ByteString (ByteString)
+import Data.ByteString.Builder
+import qualified Data.ByteString.Char8 as Char
+import Data.ByteString.Lazy (toStrict)
+import Data.List (transpose)
+import Data.Monoid
+import qualified Data.Sequence as Seq
+import Data.Time
+import GHC.Conc
+import System.IO
+import System.Random
+import Text.Printf
+
+data Options = Options
+ { optThreads :: Int -- ^ the number of threads to run concurrently
+ , optRepeat :: Int -- ^ how many times do we create the same 'FastString'
+ , optCount :: Int -- ^ the total number of different 'FastString's
+ , optPrefix :: Int -- ^ the length of prefix in each 'FastString'
+ }
+
+defOptions :: Options
+defOptions = Options
+ { optThreads = 8
+ , optRepeat = 16
+ , optCount = 10000
+ , optPrefix = 0
+ }
+
+run :: [[ByteString]] -> (ByteString -> Int) -> IO Int
+run jobs op = do
+ mvars <- forM ([0 ..] `zip` jobs) $ \(i, job) -> do
+ mvar <- newEmptyMVar
+ forkOn i $ do
+ uniq <- evaluate $ force $ maximum $ map op job
+ putMVar mvar uniq
+ return mvar
+ uniqs <- mapM takeMVar mvars
+ evaluate $ force $ maximum uniqs - 603979775
+
+summary :: IO [[[a]]] -> IO Int
+summary getTable = do
+ table <- getTable
+ evaluate $ force $ length $ concat $ concat table
+
+timeIt :: String -> IO a -> IO a
+timeIt name io = do
+ before <- getCurrentTime
+ ret <- io
+ after <- getCurrentTime
+ hPrintf stderr "%s: %.2fms\n" name
+ (realToFrac $ diffUTCTime after before * 1000 :: Double)
+ return ret
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ seed <- randomIO
+ let Options{..} = defOptions
+ shuffle (i:is) s
+ | Seq.null s = []
+ | otherwise = m: shuffle is (l <> r)
+ where
+ (l, m Seq.:< r) = Seq.viewl <$> Seq.splitAt (i `rem` Seq.length s) s
+ inputs =
+ shuffle (randoms $ mkStdGen seed) $
+ mconcat $ replicate optRepeat $
+ Seq.fromFunction optCount $ \i -> toStrict $ toLazyByteString $
+ byteString (Char.replicate optPrefix '_') <> intDec i
+ jobs <- evaluate $ force $ transpose $
+ map (take optThreads) $
+ takeWhile (not . null) $
+ iterate (drop optThreads) inputs
+ setNumCapabilities (length jobs)
+ -- The maximum unique may be greater than 'optCount'
+ u <- timeIt "run" $ run jobs $ uniqueOfFS . mkFastStringByteString
+ print $ optCount <= u && u <= min optThreads optRepeat * optCount
+ -- But we should never have duplicate 'FastString's in the table
+ n <- timeIt "summary" $ summary getFastStringTable
+ hPrint stdout $ n == optCount
diff --git a/ghc-tests/tests/T15038/Data/Trie/Naive.hs b/ghc-tests/tests/T15038/Data/Trie/Naive.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f0a38a5b8f938b49a133cdb5822a86755f25fa5a
--- /dev/null
+++ b/ghc-tests/tests/T15038/Data/Trie/Naive.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+module T15038.Data.Trie.Naive
+ ( Trie
+ , singleton
+ , singletonString
+ , lookup
+ , parser
+ , fromList
+ , fromListAppend
+ , fromStringList
+ ) where
+
+import Prelude hiding (lookup)
+
+import Data.Semigroup (Semigroup)
+import Data.Word (Word8)
+import Data.Map (Map)
+import Data.Bifunctor (second)
+import T15038.Packed.Bytes (Bytes)
+import qualified Data.Char
+import qualified Data.List as L
+import qualified T15038.Packed.Bytes.Parser as P
+import qualified T15038.Packed.Bytes as B
+import qualified Data.Semigroup as SG
+import qualified Data.Map.Strict as M
+
+data Trie a = Trie (Maybe a) (Map Word8 (Trie a))
+ deriving (Functor)
+
+instance Semigroup a => Semigroup (Trie a) where
+ (<>) = append
+
+instance Semigroup a => Monoid (Trie a) where
+ mempty = Trie Nothing M.empty
+ mappend = (SG.<>)
+
+append :: Semigroup a => Trie a -> Trie a -> Trie a
+append (Trie v1 m1) (Trie v2 m2) = Trie
+ (v1 SG.<> v2)
+ (M.unionWith append m1 m2)
+
+singleton :: Bytes -> a -> Trie a
+singleton k v = B.foldr (\b r -> Trie Nothing (M.singleton b r)) (Trie (Just v) M.empty) k
+
+singletonString :: String -> a -> Trie a
+singletonString k v = L.foldr (\c r -> Trie Nothing (M.singleton (c2w c) r)) (Trie (Just v) M.empty) k
+
+lookup :: Bytes -> Trie a -> Maybe a
+lookup k t0 = case B.foldr lookupStep (Just t0) k of
+ Nothing -> Nothing
+ Just (Trie v _) -> v
+
+lookupStep :: Word8 -> Maybe (Trie a) -> Maybe (Trie a)
+lookupStep w Nothing = Nothing
+lookupStep w (Just (Trie _ m)) = M.lookup w m
+
+parser :: Trie (P.Parser a) -> P.Parser a
+parser (Trie mp m) = case mp of
+ Just p -> p
+ Nothing -> do
+ w <- P.any
+ case M.lookup w m of
+ Nothing -> P.failure
+ Just t -> parser t
+
+fromList :: [(Bytes,a)] -> Trie a
+fromList = fmap SG.getFirst . fromListAppend . map (second SG.First)
+
+fromListAppend :: Semigroup a => [(Bytes,a)] -> Trie a
+fromListAppend = foldMap (uncurry singleton)
+
+fromStringList :: [(String,a)] -> Trie a
+fromStringList = fmap SG.getFirst . fromStringListAppend . map (second SG.First)
+
+fromStringListAppend :: Semigroup a => [(String,a)] -> Trie a
+fromStringListAppend = foldMap (uncurry singletonString)
+
+c2w :: Char -> Word8
+c2w = fromIntegral . Data.Char.ord
diff --git a/ghc-tests/tests/T15038/Main.hs b/ghc-tests/tests/T15038/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..dbf7000c4ac9e016ad53f78a29f67e37dd8c87e4
--- /dev/null
+++ b/ghc-tests/tests/T15038/Main.hs
@@ -0,0 +1,6 @@
+module T15038.Main where
+import qualified T15038.Parser as Parser
+import System.IO
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = hPrint stdout (iterate Parser.byteParserBadOnce 5 !! 100000)
diff --git a/ghc-tests/tests/T15038/Makefile b/ghc-tests/tests/T15038/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..48493c08ef2426d2ae5bd3c307644f4451771d7e
--- /dev/null
+++ b/ghc-tests/tests/T15038/Makefile
@@ -0,0 +1,15 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T15038
+T15038:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -o Main \
+ ./test/Main.hs \
+ ./test/Parser.hs \
+ ./src/Packed/Bytes/Stream/ST.hs \
+ ./src/Packed/Bytes/Parser.hs \
+ ./src/Packed/Bytes.hs \
+ ./common/Data/Trie/Naive.hs \
+ -package containers -package ghc-prim -package primitive
+ ./Main
diff --git a/ghc-tests/tests/T15038/Packed/Bytes.hs b/ghc-tests/tests/T15038/Packed/Bytes.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ecd57feaeac21114fc9a8fb372f4ff9635f51b8d
--- /dev/null
+++ b/ghc-tests/tests/T15038/Packed/Bytes.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC
+ -fno-warn-unsafe
+ -fno-warn-implicit-prelude
+ -fno-warn-missing-import-lists
+ -O2
+#-}
+
+module T15038.Packed.Bytes
+ ( Bytes(..)
+ , pack
+ , unpack
+ , length
+ -- * Folds
+ , foldr
+ -- * Unsliced Byte Arrays
+ , fromByteArray
+ ) where
+
+import Prelude hiding (take,length,replicate,drop,null,concat,foldr)
+
+import Data.Primitive (ByteArray(..))
+import Data.Word (Word8)
+import Control.Monad.ST (runST, ST)
+import qualified Data.Primitive as PM
+import qualified Data.List as L
+
+data Bytes = Bytes
+ {-# UNPACK #-} !ByteArray -- payload
+ {-# UNPACK #-} !Int -- offset
+ {-# UNPACK #-} !Int -- length
+
+instance Show Bytes where
+ show x = "pack " ++ show (unpack x)
+
+pack :: [Word8] -> Bytes
+pack bs = let arr = packByteArray bs in Bytes arr 0 (lengthByteArray arr)
+
+unpack :: Bytes -> [Word8]
+unpack (Bytes arr off len) = go off
+ where
+ go :: Int -> [Word8]
+ go !ix = if ix < len + off
+ then PM.indexByteArray arr ix : go (ix + 1)
+ else []
+
+fromByteArray :: ByteArray -> Bytes
+fromByteArray ba = Bytes ba 0 (lengthByteArray ba)
+
+length :: Bytes -> Int
+length (Bytes _ _ len) = len
+
+foldr :: (Word8 -> a -> a) -> a -> Bytes -> a
+foldr f a0 (Bytes arr off0 len) = go off0 where
+ !end = off0 + len
+ go !ix = if ix < end
+ then f (PM.indexByteArray arr ix) (go (ix + 1))
+ else a0
+
+packByteArray :: [Word8] -> ByteArray
+packByteArray ws0 = runST $ do
+ marr <- PM.newByteArray (L.length ws0)
+ let go [] !_ = return ()
+ go (w : ws) !ix = PM.writeByteArray marr ix w >> go ws (ix + 1)
+ go ws0 0
+ PM.unsafeFreezeByteArray marr
+
+unpackByteArray :: ByteArray -> [Word8]
+unpackByteArray arr = go 0 where
+ go :: Int -> [Word8]
+ go !ix = if ix < lengthByteArray arr
+ then PM.indexByteArray arr ix : go (ix + 1)
+ else []
+
+lengthByteArray :: ByteArray -> Int
+lengthByteArray = PM.sizeofByteArray
diff --git a/ghc-tests/tests/T15038/Packed/Bytes/Parser.hs b/ghc-tests/tests/T15038/Packed/Bytes/Parser.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6ae681c6a11d2f6ace7be4fe04ce0aa26d8693bc
--- /dev/null
+++ b/ghc-tests/tests/T15038/Packed/Bytes/Parser.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+
+{-# OPTIONS_GHC
+ -Weverything
+ -fno-warn-unsafe
+ -fno-warn-implicit-prelude
+ -fno-warn-missing-import-lists
+ -fno-warn-noncanonical-monoid-instances
+ -O2
+#-}
+
+module T15038.Packed.Bytes.Parser
+ ( Parser(..)
+ , Result(..)
+ , Leftovers(..)
+ , parseStreamST
+ , any
+ , failure
+ ) where
+
+import Control.Applicative
+import Data.Primitive (ByteArray(..))
+import GHC.Int (Int(I#))
+import GHC.ST (ST(..),runST)
+import GHC.Types (TYPE)
+import GHC.Word (Word8(W8#))
+import T15038.Packed.Bytes (Bytes(..))
+import T15038.Packed.Bytes.Stream.ST (ByteStream(..))
+import Prelude hiding (any,replicate)
+
+import qualified Data.Primitive as PM
+import qualified Control.Monad
+
+import GHC.Exts (Int#,ByteArray#,Word#, Word8#, State#,(+#),(-#),(>#),indexWord8Array#)
+
+type Bytes# = (# ByteArray#, Int#, Int# #)
+type Maybe# (a :: TYPE r) = (# (# #) | a #)
+type Leftovers# s = (# Bytes# , ByteStream s #)
+type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #)
+
+data Result s a = Result
+ { resultLeftovers :: !(Maybe (Leftovers s))
+ , resultValue :: !(Maybe a)
+ }
+
+data Leftovers s = Leftovers
+ { leftoversChunk :: {-# UNPACK #-} !Bytes
+ -- ^ The last chunk pulled from the stream
+ , leftoversStream :: ByteStream s
+ -- ^ The remaining stream
+ }
+
+data PureResult a = PureResult
+ { pureResultLeftovers :: {-# UNPACK #-} !Bytes
+ , pureResultValue :: !(Maybe a)
+ } deriving (Show)
+
+emptyByteArray :: ByteArray
+emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray)
+
+parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a)
+parseStreamST stream (Parser f) = ST $ \s0 ->
+ case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of
+ (# s1, r #) -> (# s1, boxResult r #)
+
+boxResult :: Result# s a -> Result s a
+boxResult (# leftovers, val #) = case val of
+ (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing
+ (# | a #) -> Result (boxLeftovers leftovers) (Just a)
+
+boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s)
+boxLeftovers (# (# #) | #) = Nothing
+boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream)
+
+instance Functor Parser where
+ fmap = mapParser
+
+-- Remember to write liftA2 by hand at some point.
+instance Applicative Parser where
+ pure = pureParser
+ (<*>) = Control.Monad.ap
+
+instance Monad Parser where
+ return = pure
+ (>>=) = bindLifted
+
+newtype Parser a = Parser
+ { getParser :: forall s.
+ Maybe# (Leftovers# s)
+ -> State# s
+ -> (# State# s, Result# s a #)
+ }
+
+nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #)
+nextNonEmpty (ByteStream f) s0 = case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, (# (# #) | #) #)
+ (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of
+ 0# -> nextNonEmpty stream s1
+ _ -> (# s1, (# | (# theBytes, stream #) #) #)
+
+withNonEmpty :: forall s b.
+ Maybe# (Leftovers# s)
+ -> State# s
+ -> (State# s -> (# State# s, Result# s b #))
+ -> (_ -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #))
+ -- The first argument is a Word8, not a full machine word.
+ -- The second argument is the complete,non-empty chunk
+ -- with the head byte still intact.
+ -> (# State# s, Result# s b #)
+withNonEmpty (# (# #) | #) s0 g _ = g s0
+withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of
+ 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0
+ _ -> case nextNonEmpty stream0 s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> g s1
+ (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) ->
+ f (indexWord8Array# arr1 off1) bytes1 stream1 s1
+
+-- | Consume the next byte from the input.
+any :: Parser Word8
+any = Parser go where
+ go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #)
+ go m s0 = withNonEmpty m s0
+ (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #))
+ (\theByte theBytes stream s ->
+ (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #)
+ )
+
+-- TODO: improve this
+mapParser :: (a -> b) -> Parser a -> Parser b
+mapParser f p = bindLifted p (pureParser . f)
+
+pureParser :: a -> Parser a
+pureParser a = Parser $ \leftovers0 s0 ->
+ (# s0, (# leftovers0, (# | a #) #) #)
+
+bindLifted :: Parser a -> (a -> Parser b) -> Parser b
+bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of
+ (# s1, (# leftovers1, val #) #) -> case val of
+ (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #)
+ (# | x #) -> case g x of
+ Parser k -> k leftovers1 s1
+
+-- This assumes that the Bytes is longer than the index. It also does
+-- not eliminate zero-length references to byte arrays.
+unsafeDrop# :: Int# -> Bytes# -> Bytes#
+unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #)
+
+unboxByteArray :: ByteArray -> ByteArray#
+unboxByteArray (ByteArray arr) = arr
+
+boxBytes :: Bytes# -> Bytes
+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)
+
+failure :: Parser a
+failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #))
diff --git a/ghc-tests/tests/T15038/Packed/Bytes/Stream/ST.hs b/ghc-tests/tests/T15038/Packed/Bytes/Stream/ST.hs
new file mode 100644
index 0000000000000000000000000000000000000000..765636700b74bf0e57307063cfd726cd8f5d306c
--- /dev/null
+++ b/ghc-tests/tests/T15038/Packed/Bytes/Stream/ST.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+{-# OPTIONS_GHC -O2 #-}
+
+module T15038.Packed.Bytes.Stream.ST
+ ( ByteStream(..)
+ , empty
+ , unpack
+ , fromBytes
+ ) where
+
+import Data.Primitive (Array,ByteArray(..))
+import Data.Semigroup (Semigroup)
+import Data.Word (Word8)
+import GHC.Exts (RealWorld,State#,Int#,ByteArray#)
+import GHC.Int (Int(I#))
+import GHC.ST (ST(..))
+import T15038.Packed.Bytes (Bytes(..))
+import System.IO (Handle)
+import qualified Data.Primitive as PM
+import qualified Data.Semigroup as SG
+import qualified T15038.Packed.Bytes as B
+
+type Bytes# = (# ByteArray#, Int#, Int# #)
+
+newtype ByteStream s = ByteStream
+ (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) )
+
+fromBytes :: Bytes -> ByteStream s
+fromBytes b = ByteStream
+ (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #))
+
+nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s))
+nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, Nothing #)
+ (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #)
+
+empty :: ByteStream s
+empty = ByteStream (\s -> (# s, (# (# #) | #) #) )
+
+boxBytes :: Bytes# -> Bytes
+boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)
+
+unboxBytes :: Bytes -> Bytes#
+unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #)
+
+unpack :: ByteStream s -> ST s [Word8]
+unpack stream = ST (unpackInternal stream)
+
+unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #)
+unpackInternal (ByteStream f) s0 = case f s0 of
+ (# s1, r #) -> case r of
+ (# (# #) | #) -> (# s1, [] #)
+ (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of
+ (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #)
diff --git a/ghc-tests/tests/T15038/Parser.hs b/ghc-tests/tests/T15038/Parser.hs
new file mode 100644
index 0000000000000000000000000000000000000000..537019928b382867f18662cdefc624fc22d8aca5
--- /dev/null
+++ b/ghc-tests/tests/T15038/Parser.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+module T15038.Parser
+ ( byteParserBadOnce
+ ) where
+
+import Control.Monad.ST (runST)
+import Data.Word (Word8)
+import T15038.Packed.Bytes (Bytes)
+import T15038.Packed.Bytes.Parser (Parser)
+import T15038.Packed.Bytes.Stream.ST (ByteStream)
+import qualified Data.Char
+import qualified T15038.Packed.Bytes as B
+import qualified T15038.Packed.Bytes.Parser as P
+import qualified T15038.Packed.Bytes.Stream.ST as Stream
+
+-- from common directory
+import qualified T15038.Data.Trie.Naive as Naive
+
+snmptrapdNaive :: Naive.Trie (Parser Word)
+snmptrapdNaive = Naive.fromStringList
+ [ ("STRING: ", P.any >>= \_ -> return 5)
+ ]
+
+runExampleParser :: Parser a -> (forall s. ByteStream s) -> (Maybe a, Maybe String)
+runExampleParser parser stream = runST $ do
+ P.Result mleftovers r <- P.parseStreamST stream parser
+ mextra <- case mleftovers of
+ Nothing -> return Nothing
+ Just (P.Leftovers chunk remainingStream) -> do
+ bs <- Stream.unpack remainingStream
+ return (Just (map word8ToChar (B.unpack chunk ++ bs)))
+ return (r,mextra)
+
+byteParserBadOnce :: Int -> Int
+byteParserBadOnce x = do
+ let sample = ("STRING: _6_ " ++ show x)
+ stream = Stream.fromBytes (s2b sample)
+ expected = 6
+ (r,mextra) = runExampleParser (Naive.parser snmptrapdNaive) stream
+ a1 = if Nothing == mextra then 1 else 0
+ a2 = if Just expected == r then 1 else 0
+ in a1 + (a2 + x)
+
+s2b :: String -> Bytes
+s2b = B.pack . map charToWord8
+
+charToWord8 :: Char -> Word8
+charToWord8 = fromIntegral . Data.Char.ord
+
+word8ToChar :: Word8 -> Char
+word8ToChar = Data.Char.chr . fromIntegral
diff --git a/ghc-tests/tests/T15038/all.T b/ghc-tests/tests/T15038/all.T
new file mode 100644
index 0000000000000000000000000000000000000000..08910f0c960019e60dad354dc483eb5713252d9e
--- /dev/null
+++ b/ghc-tests/tests/T15038/all.T
@@ -0,0 +1,3 @@
+test('T15038',
+ [reqlib('containers'), reqlib('ghc-prim'), reqlib('primitive')],
+ makefile_test, [])
diff --git a/ghc-tests/tests/T2267.hs b/ghc-tests/tests/T2267.hs
new file mode 100644
index 0000000000000000000000000000000000000000..46359825459bc9733a0c84b23a26dc585527043a
--- /dev/null
+++ b/ghc-tests/tests/T2267.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wunused-imports -Werror #-}
+
+module T2267 where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as BU
+
+toString :: B.ByteString -> String
+toString = BU.toString
+
+fromString :: String -> B.ByteString
+fromString = BU.fromString
diff --git a/ghc-tests/tests/T2317/Makefile b/ghc-tests/tests/T2317/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..9101fbd40ada5d47b499a48e62cb4ccd7f67ef71
--- /dev/null
+++ b/ghc-tests/tests/T2317/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/ghc-tests/tests/T2317/T2317.hs b/ghc-tests/tests/T2317/T2317.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5025582ebe0ea08eb7faf7077c625675ff2e9eee
--- /dev/null
+++ b/ghc-tests/tests/T2317/T2317.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE PatternSignatures #-}
+
+import Control.Monad
+import Control.Parallel
+import System.Environment
+import System.Random
+
+sort (x:xs) = sort lesser ++ [x] ++ sort greater
+ where lesser = filter (< x) xs
+ greater = filter (>= x) xs
+sort _ = []
+
+
+psort xs 10 = sort xs
+psort (x:xs) d = let d' = d + 1
+ l = psort lesser d'
+ g = psort greater d'
+ in l `par` g `par` (l ++ [x] ++ g)
+ where lesser = filter (< x) xs
+ greater = filter (>= x) xs
+psort _ _ = []
+
+main = do
+ args <- getArgs
+ let counts | null args = [100000]
+ | otherwise = map read args
+ rs :: [Int] <- randoms `fmap` getStdGen
+ forM_ counts $ \k -> do
+ let xs = take k rs
+ print . length $ xs
+-- s <- getCurrentTime
+ print . length $ psort xs 0
+-- e <- getCurrentTime
+-- print (e `diffUTCTime` s)
diff --git a/ghc-tests/tests/T2317/T2317.stdout b/ghc-tests/tests/T2317/T2317.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..7ab314964ee984633e3a2d6095a428f88f4c13e0
--- /dev/null
+++ b/ghc-tests/tests/T2317/T2317.stdout
@@ -0,0 +1,2 @@
+100000
+100000
diff --git a/ghc-tests/tests/T2317/all.T b/ghc-tests/tests/T2317/all.T
new file mode 100644
index 0000000000000000000000000000000000000000..c9bcda2434c04437024a317c4da259560a96e81c
--- /dev/null
+++ b/ghc-tests/tests/T2317/all.T
@@ -0,0 +1,5 @@
+test('T2317',
+ [when(fast(), skip),
+ reqlib('parallel'), reqlib('random')],
+ multimod_compile_and_run,
+ ['T2317',''])
diff --git a/ghc-tests/tests/T3087.hs b/ghc-tests/tests/T3087.hs
new file mode 100644
index 0000000000000000000000000000000000000000..22eb59bb47c1641bd36ef3697698a62e514ee362
--- /dev/null
+++ b/ghc-tests/tests/T3087.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE RankNTypes, DeriveDataTypeable #-}
+
+module T3087 where
+
+import Data.Generics hiding (ext2Q)
+import System.IO
+
+data MyMaybe a = MyNothing | MyJust a deriving (Data, Typeable)
+
+test1 :: ()
+test1 = undefined `ext1Q` (\ (Just _) -> ()) $ Just ()
+
+test1' :: ()
+test1' = undefined `ext1Q` (\ (MyJust _) -> ()) $ MyJust ()
+
+newtype Q r a = Q { unQ :: a -> r }
+
+ext2Q :: (Data d, Typeable t)
+ => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+ -> d -> q
+ext2Q def ext arg =
+ case dataCast2 (Q ext) of
+ Just (Q ext') -> ext' arg
+ Nothing -> def arg
+
+data MyPair a b = MyPair a b deriving (Data, Typeable)
+
+test2 :: ()
+test2 = undefined `ext2Q` (\(_,_) -> ()) $ ((),())
+
+test2' :: ()
+test2' = undefined `ext2Q` (\(MyPair _ _) -> ()) $ MyPair () ()
+
+main stdout _ = do { print test1; print test1'; print test2; print test2' }
+ where
+ print = hPrint stdout
diff --git a/ghc-tests/tests/T367.hs b/ghc-tests/tests/T367.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b02f2e19155f9e41f2c142d5f567cd5dadb2a330
--- /dev/null
+++ b/ghc-tests/tests/T367.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -O2 #-}
+module T367 where
+import Control.Concurrent
+import qualified Data.Vector as U
+import System.IO
+
+main stdout _ = do
+ -- Non allocating loop, needs -fno-omit-yields in order for the kill to
+ -- work
+ t <- forkIO (U.sum (U.enumFromTo 1 (1000000000 :: Int)) `seq` return ())
+ threadDelay 10
+ killThread t
+ hPutStrLn stdout "Done"
diff --git a/ghc-tests/tests/T367A.hs b/ghc-tests/tests/T367A.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6cb297db49dcaacfb13424164026196b8eaa82f5
--- /dev/null
+++ b/ghc-tests/tests/T367A.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -O2 -fno-omit-yields #-}
+-- Without -fno-omit-yields this test doesn't terminate
+module T367A where
+
+import Data.IORef
+import Control.Concurrent
+import System.IO
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ r <- newIORef False
+ done_var <- newEmptyMVar
+ hPutStrLn stdout "About to fork"
+
+ forkIO $ f stdout done_var r
+ threadDelay 1000000 -- 1 second
+
+ hPutStrLn stdout "Why is this never printed?!"
+ writeIORef r True
+ readMVar done_var
+ -- and why do we never exit?
+
+f :: Handle -> MVar () -> IORef Bool -> IO ()
+f stdout done_var r = readIORef r >>= \b-> if b then hPutStrLn stdout "Done" >> putMVar done_var () else f stdout done_var r
diff --git a/ghc-tests/tests/T7953.hs b/ghc-tests/tests/T7953.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f7fce007ed00f62f53ed108c21278049d1cb8824
--- /dev/null
+++ b/ghc-tests/tests/T7953.hs
@@ -0,0 +1,66 @@
+module T7953 (main) where
+
+import Control.Monad
+import System.IO
+import System.Random
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ hSetBuffering stdout NoBuffering
+ let q = fold $ zip [1..] (take 200 [500.0,400.0..])
+ hPrint stdout q
+ hPutStrLn stdout "Before atMost"
+ let (xs,q') = atMost 0.5 q -- this causes seqfault with -O2
+ hPrint stdout xs
+ hPrint stdout q'
+ hPutStrLn stdout "After atMost"
+
+fold :: [(Key, Prio)] -> PSQ
+fold [] = Void
+fold ((u,r):xs) = insert u r $ fold xs
+
+data Elem = E
+ { _key :: Key
+ , prio :: Prio
+ } deriving (Eq, Show)
+
+type Prio = Double
+type Key = Int
+
+data PSQ = Void
+ | Winner Elem Tree
+ deriving (Eq, Show)
+
+singleton :: Key -> Prio -> PSQ
+singleton k p = Winner (E k p) Start
+
+insert :: Key -> Prio -> PSQ -> PSQ
+insert k p q = case q of
+ Void -> singleton k p
+ Winner e t -> Winner (E k p) (Fork e Start t)
+
+atMost :: Prio -> PSQ -> ([Elem], PSQ)
+atMost pt q = case q of
+ (Winner e _)
+ | prio e > pt -> ([], q)
+ Void -> ([], Void)
+ Winner e Start -> ([e], Void)
+ Winner e (Fork e' tl tr) ->
+ let (sequ, q') = atMost pt (Winner e' tl)
+ (sequ', q'') = atMost pt (Winner e tr)
+ in (sequ ++ sequ', q' `play` q'')
+
+data Tree = Start
+ | Fork Elem Tree Tree
+ deriving (Eq, Show)
+
+lloser :: Key -> Prio -> Tree -> Tree -> Tree
+lloser k p tl tr = Fork (E k p) tl tr
+
+play :: PSQ -> PSQ -> PSQ
+Void `play` t' = t'
+t `play` Void = t
+Winner e@(E k p) t `play` Winner e'@(E k' p') t'
+ | p <= p' = Winner e (lloser k' p' t t')
+ | otherwise = Winner e' (lloser k p t t')
+
diff --git a/ghc-tests/tests/T8138.hs b/ghc-tests/tests/T8138.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9d869113e1c3a71cf9439def690bec3dbc25195c
--- /dev/null
+++ b/ghc-tests/tests/T8138.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T8138 where
+
+import Control.Monad.ST
+import Data.Primitive
+import System.IO
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+ let xs :: [Float] = runST $ do
+ barr <- mutableByteArrayFromList [1..fromIntegral n::Float]
+ peekByteArray n barr
+ hPrint stdout xs
+ where
+ n = 13
+
+mutableByteArrayFromList :: forall s a . (Prim a)
+ => [a]
+ -> ST s (MutableByteArray s)
+mutableByteArrayFromList xs = do
+ arr <- newByteArray (length xs*sizeOf (undefined :: a))
+ loop arr 0 xs
+ return arr
+ where
+ loop :: MutableByteArray s -> Int -> [a] -> ST s ()
+ loop _ _ [] = return ()
+
+ loop arr i (x : xs) = do
+ writeByteArray arr i x
+ loop arr (i+1) xs
+
+peekByteArray :: (Prim a)
+ => Int
+ -> MutableByteArray s
+ -> ST s [a]
+peekByteArray n arr =
+ loop 0 arr
+ where
+ loop :: (Prim a)
+ => Int
+ -> MutableByteArray s
+ -> ST s [a]
+ loop i _ | i >= n = return []
+
+ loop i arr = do
+ x <- readByteArray arr i
+ xs <- loop (i+1) arr
+ return (x : xs)
diff --git a/ghc-tests/tests/TC191.hs b/ghc-tests/tests/TC191.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a8cee168463da44aced16b3a3a5197848aa06a05
--- /dev/null
+++ b/ghc-tests/tests/TC191.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- This only typechecks if forall-hoisting works ok when
+-- importing from an interface file. The type of Twins.gzipWithQ
+-- is this:
+-- type GenericQ r = forall a. Data a => a -> r
+-- gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
+-- It's kept this way in the interface file for brevity and documentation,
+-- but when the type synonym is expanded, the foralls need expanding
+
+module TC191 where
+
+import Data.Generics.Basics
+import Data.Generics.Aliases
+import Data.Generics.Twins(gzipWithQ)
+
+-- | Generic equality: an alternative to \deriving Eq\
+geq :: Data a => a -> a -> Bool
+geq x y = geq' x y
+ where
+-- This type signature no longer works, because it is
+-- insufficiently polymorphic.
+-- geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
+ geq' :: GenericQ (GenericQ Bool)
+ geq' x y = (toConstr x == toConstr y)
+ && and (gzipWithQ geq' x y)
+
+
+
diff --git a/ghc-tests/tests/TC220.hs b/ghc-tests/tests/TC220.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b1b8c3ec10ca3a53a4941bc1e51dcf6d652f306b
--- /dev/null
+++ b/ghc-tests/tests/TC220.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- See #1033
+
+module TC220 where
+
+import Data.Generics
+import Control.Monad.State
+
+data HsExp = HsWildCard deriving( Typeable, Data )
+data HsName = HsName deriving( Typeable, Data )
+
+-- rename :: () -> HsExp -> State (HsName, [HsName]) HsExp
+-- Type sig commented out
+rename1 = \_ -> everywhereM (mkM (\e -> case e of HsWildCard -> return e))
+
+rename2 _ = everywhereM (mkM (\e -> case e of HsWildCard -> return e))
+
+uncomb1 :: State (HsName, [HsName]) HsExp
+uncomb1 = rename1 () undefined
+
+uncomb2 :: State (HsName, [HsName]) HsExp
+uncomb2 = rename2 () undefined
+
+
+
diff --git a/ghc-tests/tests/Tasty/Bronze.hs b/ghc-tests/tests/Tasty/Bronze.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c735b47860389dab1a4e559e7a3503b20483d409
--- /dev/null
+++ b/ghc-tests/tests/Tasty/Bronze.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+module Tasty.Bronze where
+
+import System.Exit
+import Test.Tasty
+import Test.Tasty.Silver
+import qualified System.Process as PT
+import Control.Exception
+import System.IO
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as T
+import System.Posix.Process.Internals
+import System.IO.Temp
+
+
+-- | Compares a given file with the output (exit code, stdout, stderr) of a program. Assumes
+-- that the program output is utf8 encoded.
+goldenVsOut
+ :: TestName -- ^ test name
+ -> FilePath -- ^ path to the golden file
+ -> (Handle -> Handle -> IO ())
+ -> TestTree
+goldenVsOut name ref cmd =
+ goldenVsAction name ref runProg printProcResult
+ where runProg = wrapAction cmd
+
+wrapAction :: (Handle -> Handle -> IO ()) -> IO (ExitCode, T.Text, T.Text)
+wrapAction io =
+ withSystemTempFile "stdout" $ \stdout_fp stdout_h -> do
+ withSystemTempFile "stderr" $ \stderr_fp stderr_h -> do
+ e_code <- catchExit (io stdout_h stderr_h)
+ hClose stdout_h
+ hClose stderr_h
+ !std_o <- readFile stdout_fp
+ !std_e <- readFile stderr_fp
+ return (e_code, T.pack std_o, T.pack std_e)
+
+catchExit :: IO () -> IO ExitCode
+catchExit io = catch (ExitSuccess <$ io) (\(e :: ExitCode) -> return e)
diff --git a/ghc-tests/tests/Throwto001.hs b/ghc-tests/tests/Throwto001.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5635bd265d8810a2971e40ab36d51b1fc5f32d74
--- /dev/null
+++ b/ghc-tests/tests/Throwto001.hs
@@ -0,0 +1,38 @@
+module Throwto001 where
+import Control.Concurrent
+import Control.Exception
+import Data.Array
+import System.Random
+import System.Environment
+import Control.Monad
+import GHC.Conc
+
+-- A fiendish throwTo test. A bunch of threads take random MVars from
+-- a shared array; if the MVar has Nothing in it, replace it with Just
+-- of the current thread's ThreadId. If the MVar has another ThreadId
+-- in it, then killThread that thread, and replace it with the current
+-- thread's ThreadId. We keep going until only one thread is left
+-- standing.
+--
+-- On multiple CPUs this should give throwTo a good workout.
+--
+main m t = do
+ ms <- replicateM m $ newMVar Nothing
+ let arr = listArray (1,m) ms
+ dead <- newTVarIO 0
+ ts <- replicateM t $ forkIO (thread m arr `onException`
+ (atomically $ do d <- readTVar dead
+ writeTVar dead $! d+1))
+ atomically $ do
+ d <- readTVar dead
+ when (d < t-1) $ retry
+
+thread m arr = do
+ x <- randomIO
+ id <- myThreadId
+ modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b ->
+ case b of
+ Nothing -> return (Just id)
+ Just other -> do when (other /= id) $ killThread other
+ return (Just id)
+ thread m arr