diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index ea1fc76e27872ad98f19fb0274dc77cd9be771b3..c7fedb64c17204a0f43e168dc4f69001b7c8d64b 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -21,6 +21,7 @@ module Distribution.Client.JobControl ( collectJob, remainingJobs, cancelJobs, + cleanupJobControl, JobLimit, newJobLimit, @@ -63,7 +64,11 @@ data JobControl m a = JobControl { -- | Try to cancel any outstanding but not-yet-started jobs. -- Call 'remainingJobs' after this to find out if any jobs are left -- (ie could not be cancelled). - cancelJobs :: m () + cancelJobs :: m (), + + -- | cleanup any resources created by the JobControl, intended to be used + -- as the finalised for `bracket`. + cleanupJobControl :: m () } @@ -79,7 +84,8 @@ newSerialJobControl = do spawnJob = spawn qVar, collectJob = collect qVar, remainingJobs = remaining qVar, - cancelJobs = cancel qVar + cancelJobs = cancel qVar, + cleanupJobControl = return () } where spawn :: TChan (IO a) -> IO a -> IO () @@ -118,7 +124,8 @@ newParallelJobControl maxJobLimit = do spawnJob = spawn inqVar countVar, collectJob = collect outqVar countVar, remainingJobs = remaining countVar, - cancelJobs = cancel inqVar countVar + cancelJobs = cancel inqVar countVar, + cleanupJobControl = return() } where worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () @@ -174,12 +181,13 @@ newSemaphoreJobControl semName maxJobLimit = do outqVar <- newTChanIO inqVar <- newTChanIO countVar <- newTVarIO 0 - forkIO (worker sem inqVar outqVar `finally` destroySemaphore sem) + forkIO (worker sem inqVar outqVar) return JobControl { spawnJob = spawn inqVar countVar, collectJob = collect outqVar countVar, remainingJobs = remaining countVar, - cancelJobs = cancel inqVar countVar + cancelJobs = cancel inqVar countVar, + cleanupJobControl = destroySemaphore sem } where worker :: Semaphore -> TChan (IO a) -> TChan (Either SomeException a) -> IO () diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 1023e5e162c4fe13739e0b51e6fcec6103d06f16..d7b8227917fead78789c58e0d73ab1c1fe5adb55 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -99,7 +99,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 -import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) +import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle, bracket) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>)) import System.IO (IOMode (AppendMode), Handle, withFile) @@ -584,7 +584,7 @@ rebuildTargets verbosity -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - jobControl <- case buildSettingNumJobs of + let mkJobControl = case buildSettingNumJobs of Serial -> newSerialJobControl Old n -> newParallelJobControl (fromMaybe numberOfProcessors n) UseSem sm n -> newSemaphoreJobControl (SemaphoreName sm) n @@ -603,30 +603,32 @@ rebuildTargets verbosity createDirectoryIfMissingVerbose verbosity True distTempDirectory traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse - -- Before traversing the install plan, preemptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - -- For each package in the plan, in dependency order, but in parallel... - InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) - installPlan $ \pkg -> - --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ - - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - buildSettings downloadMap - registerLock cacheLock - sharedPackageConfig - installPlan pkg - pkgBuildStatus + bracket mkJobControl cleanupJobControl $ \jobControl -> do + -- Before traversing the install plan, preemptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity withRepoCtx + installPlan pkgsBuildStatus $ \downloadMap -> + + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute jobControl keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan $ \pkg -> + --TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ + + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + installPlan pkg + pkgBuildStatus where keepGoing = buildSettingKeepGoing withRepoCtx = projectConfigWithBuilderRepoContext verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 743b62a285ec2c7c884f27679cd55d57f8b2bb56..6278639cca63a7d25bc3e5585103e0cb86464006 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -3622,14 +3622,17 @@ setupHsBuildFlags :: Flag String -> Verbosity -> FilePath -> Cabal.BuildFlags -setupHsBuildFlags par_strat _ _ verbosity builddir = +setupHsBuildFlags par_strat elab _ verbosity builddir = Cabal.BuildFlags { buildProgramPaths = mempty, --unused, set at configure time buildProgramArgs = mempty, --unused, set at configure time buildVerbosity = toFlag verbosity, buildDistPref = toFlag builddir, buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildUseSemaphore = par_strat, + buildUseSemaphore = + if traceShowId (elabSetupScriptCliVersion elab) >= mkVersion [3,9,0,0] + then par_strat + else mempty, buildArgs = mempty, -- unused, passed via args not flags buildCabalFilePath= mempty }