From b817cb7ac06d913bd32e176f3cce186b4af19949 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 31 Jan 2025 11:39:26 +0000 Subject: [PATCH] project planning: fix #10686 regression We previously only fetched the compiler in `instantiateProjectConfigSkeletonFetchingCompiler` if `null (toListOf traverseCondTreeV skel)` was false. c89ab54e13f1eb808dcdd470edecd7eaaa594cec changed this to always configure the compiler, such that it could be later re-used when determining whether jsem was supported to clone git submodules concurrently. This patch allows for the JobControl concurrency mechanism to be controlled without a compiler (which assumes -jsem is not supported), and restores the behaviour of not always configuring the compiler. Fixes #10686 --- cabal-install/src/Distribution/Client/CmdInstall.hs | 2 +- cabal-install/src/Distribution/Client/JobControl.hs | 20 ++++++++++++++------ .../src/Distribution/Client/ProjectBuilding.hs | 2 +- .../src/Distribution/Client/ProjectConfig.hs | 4 ++-- .../src/Distribution/Client/ProjectConfig/Legacy.hs | 15 ++++++++++----- .../src/Distribution/Client/ProjectPlanning.hs | 12 +++++++----- cabal-install/src/Distribution/Client/ScriptUtils.hs | 3 +-- 7 files changed, 36 insertions(+), 22 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 75e673e89..63cf59169 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -467,7 +467,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project fetchAndReadSourcePackages verbosity distDirLayout - compiler + (Just compiler) (projectConfigShared config) (projectConfigBuildOnly config) [ProjectPackageRemoteTarball uri | uri <- uris] diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index 0d8fa0acf..113237fa9 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -277,20 +277,28 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act newJobControlFromParStrat :: Verbosity - -> Compiler + -> Maybe Compiler + -- ^ The compiler, used to determine whether Jsem is supported. + -- When Nothing, Jsem is assumed to be unsupported. -> ParStratInstall -- ^ The parallel strategy -> Maybe Int -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy) -> IO (JobControl IO a) -newJobControlFromParStrat verbosity compiler parStrat numJobsCap = case parStrat of +newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of Serial -> newSerialJobControl NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n)) UseSem n -> - if jsemSupported compiler - then newSemaphoreJobControl verbosity (capJobs n) - else do - warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." + case mcompiler of + Just compiler + | jsemSupported compiler -> + newSemaphoreJobControl verbosity (capJobs n) + | otherwise -> + do + warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." + newParallelJobControl (capJobs n) + Nothing -> + -- Don't warn in the Nothing case, as there isn't really a "selected" compiler. newParallelJobControl (capJobs n) where capJobs n = min (fromMaybe maxBound numJobsCap) n diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 7a5d1059e..7bf6de869 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -369,7 +369,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - withJobControl (newJobControlFromParStrat verbosity compiler buildSettingNumJobs Nothing) $ \jobControl -> do + withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do -- Before traversing the install plan, preemptively find all packages that -- will need to be downloaded and start downloading them. asyncDownloadPackages diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 23e9f94ba..b9f2cfed6 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1261,7 +1261,7 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout - -> Compiler + -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1425,7 +1425,7 @@ fetchAndReadSourcePackageRemoteTarball syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout - -> Compiler + -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 96c528585..03c1fc8f1 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -84,9 +84,11 @@ import Distribution.PackageDescription ) import Distribution.PackageDescription.Configuration (simplifyWithSysParams) import Distribution.Simple.Compiler - ( CompilerInfo (..) + ( Compiler (..) + , CompilerInfo (..) , DebugInfoLevel (..) , OptimisationLevel (..) + , compilerInfo , interpretPackageDB ) import Distribution.Simple.InstallDirs (CopyDest (NoCopyDest)) @@ -216,10 +218,13 @@ type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton singletonProjectConfigSkeleton x = CondNode x mempty mempty -instantiateProjectConfigSkeletonFetchingCompiler :: (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig -instantiateProjectConfigSkeletonFetchingCompiler (os, arch, impl) flags skel - | null (toListOf traverseCondTreeV skel) = fst (ignoreConditions skel) - | otherwise = instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel +instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, Compiler) -> FlagAssignment -> ProjectConfigSkeleton -> m (ProjectConfig, Maybe Compiler) +instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel + | null (toListOf traverseCondTreeV skel) = pure (fst (ignoreConditions skel), Nothing) + | otherwise = do + (os, arch, comp) <- fetch + let conf = instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo comp) flags skel + pure (conf, Just comp) instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 39e87c046..c04bca730 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -394,11 +394,13 @@ rebuildProjectConfig liftIO $ info verbosity "Project settings changed, reconfiguring..." projectConfigSkeleton <- phaseReadProjectConfig - -- have to create the cache directory before configuring the compiler - liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + let fetchCompiler = do + -- have to create the cache directory before configuring the compiler + liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, compiler) - let projectConfig = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectConfigSkeleton + (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ liftIO $ warn verbosity "The builddir option is not supported in project and config files. It will be ignored." @@ -434,7 +436,7 @@ rebuildProjectConfig -- NOTE: These are all packages mentioned in the project configuration. -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`. phaseReadLocalPackages - :: Compiler + :: Maybe Compiler -> ProjectConfig -> Rebuild [PackageSpecifier UnresolvedSourcePackage] phaseReadLocalPackages diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index f397f4342..440de3c84 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -117,7 +117,6 @@ import qualified Distribution.SPDX.License as SPDX import Distribution.Simple.Compiler ( Compiler (..) , OptimisationLevel (..) - , compilerInfo ) import Distribution.Simple.Flag ( flagToMaybe @@ -381,7 +380,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - let projectCfg = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectCfgSkeleton + (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton let ctx' = ctx & lProjectConfig %~ (<> projectCfg) -- 2.11.4.GIT