From b74bac0d180fddbc13f2b8e47e8644ec00aa8203 Mon Sep 17 00:00:00 2001
From: Thomas Tuegel <ttuegel@gmail.com>
Date: Sat, 28 Mar 2015 22:26:28 -0500
Subject: [PATCH] fix deadlock in detailed-0.9 test suite runner
Fixes #2489. The detailed-0.9 test suite runner would deadlock because
the IO manager was not draining the output pipe of the child
process. Thanks to @r0ml for the patch.
---
Cabal/Distribution/Simple/Test/LibV09.hs | 12 ++++---
Cabal/tests/PackageTests.hs | 12 +++----
.../TestSuiteTests/ExeV10/Check.hs | 14 ++++----
.../TestSuiteTests/LibV09/Check.hs | 34 ++++++++++---------
.../TestSuiteTests/LibV09/tests/Deadlock.hs | 2 +-
5 files changed, 40 insertions(+), 34 deletions(-)
diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs
index 482953822d..859e6a9958 100644
--- a/Cabal/Distribution/Simple/Test/LibV09.hs
+++ b/Cabal/Distribution/Simple/Test/LibV09.hs
@@ -29,8 +29,9 @@ import Distribution.TestSuite
import Distribution.Text
import Distribution.Verbosity ( normal )
+import Control.Concurrent (forkIO)
import Control.Exception ( bracket )
-import Control.Monad ( when, unless )
+import Control.Monad ( when, unless, void )
import Data.Maybe ( mapMaybe )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
@@ -81,6 +82,12 @@ runTest pkg_descr lbi flags suite = do
hPutStr wIn $ show (tempLog, PD.testName suite)
hClose wIn
+ -- Append contents of temporary log file to the final human-
+ -- readable log file
+ logText <- hGetContents rOut
+ -- Force the IO manager to drain the test output pipe
+ void $ forkIO $ length logText `seq` return ()
+
-- Run test executable
_ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
dataDirPath = pwd </> PD.dataDir pkg_descr
@@ -118,9 +125,6 @@ runTest pkg_descr lbi flags suite = do
-- Write summary notice to log file indicating start of test suite
appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite
- -- Append contents of temporary log file to the final human-
- -- readable log file
- logText <- hGetContents rOut
appendFile (logFile suiteLog) logText
-- Write end-of-suite summary notice to log file
diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs
index 458c2a0aa1..e065f0f9d7 100644
--- a/Cabal/tests/PackageTests.hs
+++ b/Cabal/tests/PackageTests.hs
@@ -79,12 +79,12 @@ tests config version =
-- only for higher versions.
, testGroup "TestSuiteTests"
[ testGroup "ExeV10"
- (PackageTests.TestSuiteTests.ExeV10.Check.checks ghcPath)
+ (PackageTests.TestSuiteTests.ExeV10.Check.checks config)
, testGroup "LibV09"
- (PackageTests.TestSuiteTests.LibV09.Check.checks inplaceSpec ghcPath)
+ (PackageTests.TestSuiteTests.LibV09.Check.checks config)
]
- , testCase "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath)
- , testCase "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath)
+ , testCase "TestOptions" (PackageTests.TestOptions.Check.suite config)
+ , testCase "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite config)
-- ^ The benchmark stanza test will eventually be required
-- only for higher versions.
, testCase "BenchmarkExeV10/Test"
@@ -101,8 +101,8 @@ tests config version =
, testCase "DeterministicAr"
(PackageTests.DeterministicAr.Check.suite config)
, testCase "EmptyLib/emptyLib"
- (PackageTests.EmptyLib.Check.emptyLib ghcPath)
- , testCase "Haddock" (PackageTests.Haddock.Check.suite ghcPath)
+ (PackageTests.EmptyLib.Check.emptyLib config)
+ , testCase "Haddock" (PackageTests.Haddock.Check.suite config)
, testCase "OrderFlags"
(PackageTests.OrderFlags.Check.suite config)
, testCase "TemplateHaskell/dynamic"
diff --git a/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs b/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs
index 758ce679d4..299e29ccb9 100644
--- a/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs
+++ b/Cabal/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs
@@ -24,13 +24,13 @@ import Distribution.Version (Version(..), orLaterVersion)
import PackageTests.PackageTester
-checks :: FilePath -> [TestTree]
-checks ghcPath =
- [ testCase "Test" $ checkTest ghcPath
- , testGroup "WithHpc" $ hpcTestMatrix ghcPath
+checks :: SuiteConfig -> [TestTree]
+checks config =
+ [ testCase "Test" $ checkTest config
+ , testGroup "WithHpc" $ hpcTestMatrix config
, testGroup "WithoutHpc"
- [ testCase "NoTix" $ checkTestNoHpcNoTix ghcPath
- , testCase "NoMarkup" $ checkTestNoHpcNoMarkup ghcPath
+ [ testCase "NoTix" $ checkTestNoHpcNoTix config
+ , testCase "NoMarkup" $ checkTestNoHpcNoMarkup config
]
]
@@ -59,7 +59,7 @@ hpcTestMatrix config = do
enable cond flag
| cond = Just $ "--enable-" ++ flag
| otherwise = Nothing
- return $ testCase name $ checkTestWithHpc ghcPath ("WithHpc-" ++ name) opts
+ return $ testCase name $ checkTestWithHpc config ("WithHpc-" ++ name) opts
dir :: FilePath
dir = "PackageTests" </> "TestSuiteTests" </> "ExeV10"
diff --git a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs b/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs
index 1526a72182..ba9920dab0 100644
--- a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs
+++ b/Cabal/tests/PackageTests/TestSuiteTests/LibV09/Check.hs
@@ -9,31 +9,33 @@ import PackageTests.PackageTester
dir :: FilePath
dir = "PackageTests" </> "TestSuiteTests" </> "LibV09"
-checks :: PackageSpec -> FilePath -> [TestTree]
-checks inplaceSpec ghcPath =
- [ testCase "Build" $ checkBuild inplaceSpec ghcPath
- , localOption (mkTimeout $ 10 * 10 ^ (6 :: Int))
- $ testCase "Deadlock" $ checkDeadlock inplaceSpec ghcPath
+checks :: SuiteConfig -> [TestTree]
+checks config =
+ [ testCase "Build" (checkBuild config)
+ , localOption (mkTimeout $ 10 ^ (8 :: Int))
+ $ testCase "Deadlock" (checkDeadlock config)
]
-checkBuild :: PackageSpec -> FilePath -> Assertion
-checkBuild inplaceSpec ghcPath = do
- let spec = inplaceSpec
+checkBuild :: SuiteConfig -> Assertion
+checkBuild config = do
+ let spec = (inplaceSpec config)
{ directory = dir
, distPref = Just $ "dist-Build"
- , configOpts = "--enable-tests" : configOpts inplaceSpec
+ , configOpts = "--enable-tests"
+ : configOpts (inplaceSpec config)
}
- buildResult <- cabal_build spec ghcPath
+ buildResult <- cabal_build config spec
assertBuildSucceeded buildResult
-checkDeadlock :: PackageSpec -> FilePath -> Assertion
-checkDeadlock inplaceSpec ghcPath = do
- let spec = inplaceSpec
+checkDeadlock :: SuiteConfig -> Assertion
+checkDeadlock config = do
+ let spec = (inplaceSpec config)
{ directory = dir
, distPref = Just $ "dist-Test"
- , configOpts = "--enable-tests" : configOpts inplaceSpec
+ , configOpts = "--enable-tests"
+ : configOpts (inplaceSpec config)
}
- buildResult <- cabal_build spec ghcPath
+ buildResult <- cabal_build config spec
assertBuildSucceeded buildResult
- testResult <- cabal_test spec [] [] ghcPath
+ testResult <- cabal_test config spec [] []
assertTestFailed testResult
diff --git a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs b/Cabal/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs
index c20804bd55..5d7db101ed 100644
--- a/Cabal/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs
+++ b/Cabal/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs
@@ -5,4 +5,4 @@ import Distribution.TestSuite
import Lib
tests :: IO [Test]
-tests = return [nullt x | x <- [1 .. 10000]]
+tests = return [nullt x | x <- [1 .. 1000]]
--
GitLab