Commit 8ed21604 authored by refold's avatar refold

Use a lock instead of 'JobControl 1'.

parent 96d1ba3b
......@@ -106,7 +106,7 @@ configure verbosity packageDBs repos comp conf
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = False,
setupCacheLimit = Nothing
setupCacheLock = Nothing
}
where
-- Hack: we typically want to allow the UserPackageDB for finding the
......
......@@ -746,15 +746,16 @@ performInstallations verbosity
else newSerialJobControl
buildLimit <- newJobLimit numJobs
fetchLimit <- newJobLimit (min numJobs numFetchJobs)
installLimit <- newJobLimit 1 --serialise installation
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
executeInstallPlan verbosity jobControl installPlan $ \cpkg ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
installUnpackedPackage verbosity buildLimit installLimit
(setupScriptOptions installedPkgIndex installLimit)
installUnpackedPackage verbosity buildLimit installLock
(setupScriptOptions installedPkgIndex cacheLock)
miscOptions configFlags' installFlags haddockFlags
compid pkg mpath useLogFile
......@@ -766,7 +767,7 @@ performInstallations verbosity
numFetchJobs = 2
parallelBuild = numJobs >= 2
setupScriptOptions index limit = SetupScriptOptions {
setupScriptOptions index lock = SetupScriptOptions {
useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),
useCompiler = Just comp,
-- Hack: we typically want to allow the UserPackageDB for finding the
......@@ -788,7 +789,7 @@ performInstallations verbosity
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = parallelBuild,
setupCacheLimit = Just limit
setupCacheLock = Just lock
}
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
......@@ -956,7 +957,7 @@ installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do
installUnpackedPackage
:: Verbosity
-> JobLimit
-> JobLimit
-> Lock
-> SetupScriptOptions
-> InstallMisc
-> ConfigFlags
......@@ -967,7 +968,7 @@ installUnpackedPackage
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity buildLimit installLimit
installUnpackedPackage verbosity buildLimit installLock
scriptOptions miscOptions
configFlags installConfigFlags haddockFlags
compid pkg workingDir useLogFile =
......@@ -997,7 +998,7 @@ installUnpackedPackage verbosity buildLimit installLimit
| otherwise = TestsNotTried
-- Install phase
onFailure InstallFailed $ withJobLimit installLimit $
onFailure InstallFailed $ criticalSection installLock $
withWin32SelfUpgrade verbosity configFlags compid pkg $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
......
......@@ -20,6 +20,10 @@ module Distribution.Client.JobControl (
JobLimit,
newJobLimit,
withJobLimit,
Lock,
newLock,
criticalSection
) where
import Control.Monad
......@@ -77,3 +81,11 @@ newJobLimit n =
withJobLimit :: JobLimit -> IO a -> IO a
withJobLimit (JobLimit sem) =
bracket_ (waitQSem sem) (signalQSem sem)
newtype Lock = Lock (MVar ())
newLock :: IO Lock
newLock = fmap Lock $ newMVar ()
criticalSection :: Lock -> IO a -> IO a
criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
......@@ -56,7 +56,7 @@ import Distribution.Client.Config
import Distribution.Client.IndexUtils
( getInstalledPackages )
import Distribution.Client.JobControl
( JobLimit, withJobLimit )
( JobLimit, withJobLimit, Lock, criticalSection )
import Distribution.Simple.Utils
( die, debug, info, cabalVersion, findPackageDesc, comparing
, createDirectoryIfMissingVerbose, installExecutableFile
......@@ -91,8 +91,9 @@ data SetupScriptOptions = SetupScriptOptions {
useWorkingDir :: Maybe FilePath,
forceExternalSetupMethod :: Bool,
-- Used only in parallel code; should be Nothing otherwise.
setupCacheLimit :: Maybe JobLimit
-- Used only when calling setupWrapper from parallel code to serialise
-- access to the setup cache; should be Nothing otherwise.
setupCacheLock :: Maybe Lock
}
defaultSetupScriptOptions :: SetupScriptOptions
......@@ -106,7 +107,7 @@ defaultSetupScriptOptions = SetupScriptOptions {
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = False,
setupCacheLimit = Nothing
setupCacheLock = Nothing
}
setupWrapper :: Verbosity
......@@ -310,7 +311,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do
if setupProgFileExists
then debug verbosity $
"Found cached setup executable: " ++ setupProgFile
else withSetupCacheLimit $ do
else criticalSection' $ do
-- The cache may have been populated while we were waiting.
setupProgFileExists' <- doesFileExist setupProgFile
if setupProgFileExists'
......@@ -326,8 +327,8 @@ externalSetupMethod verbosity options pkg bt mkargs = do
cabalVersionString = "Cabal-" ++ (display cabalLibVersion)
compilerVersionString = fromMaybe "nonexisting-compiler"
(showCompilerId `fmap` useCompiler options')
withSetupCacheLimit = fromMaybe id
(fmap withJobLimit $ setupCacheLimit options')
criticalSection' = fromMaybe id
(fmap criticalSection $ setupCacheLock options')
-- | If the Setup.hs is out of date wrt the executable then recompile it.
-- Currently this is GHC only. It should really be generalised.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment