diff --git a/ChangeLog.md b/ChangeLog.md index 603b055fb8..a0c57c3923 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -91,6 +91,8 @@ Other enhancements: [#4463](https://github.com/commercialhaskell/stack/issues/4463) * Add `--cabal-files` flag to `stack ide targets` command. * Add `--stdout` flag to all `stack ide` subcommands. +* Use batches when unregistering packages with `ghc-pkg`. + (See [#2662](https://github.com/commercialhaskell/stack/issues/2662)) Bug fixes: diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index c342df45f1..31c5e06806 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -41,6 +41,9 @@ import Data.Conduit.Process.Typed runProcess_, getStdout, getStderr, createSource) import qualified Data.Conduit.Text as CT import Data.List hiding (any) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty (toList) +import Data.List.Split (chunksOf) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -580,18 +583,11 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports cv <- view actualCompilerVersionL let wc = view whichCompilerL cv - case Map.toList $ planUnregisterLocal plan of - [] -> return () - ids -> do + case nonEmpty . Map.toList $ planUnregisterLocal plan of + Nothing -> return () + Just ids -> do localDB <- packageDatabaseLocal - forM_ ids $ \(id', (ident, reason)) -> do - logInfo $ - fromString (packageIdentifierString ident) <> - ": unregistering" <> - if T.null reason - then "" - else " (" <> RIO.display reason <> ")" - unregisterGhcPkgId wc cv localDB id' ident + unregisterPackages cv localDB ids liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) @@ -661,6 +657,49 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do $ Map.elems $ planUnregisterLocal plan +unregisterPackages :: + (HasProcessContext env, HasLogFunc env, HasPlatform env) + => ActualCompiler + -> Path Abs Dir + -> NonEmpty (GhcPkgId, (PackageIdentifier, Text)) + -> RIO env () +unregisterPackages cv localDB ids = do + let wc = view whichCompilerL cv + let logReason ident reason = + logInfo $ + fromString (packageIdentifierString ident) <> ": unregistering" <> + if T.null reason + then "" + else " (" <> RIO.display reason <> ")" + let unregisterSinglePkg select (gid, (ident, reason)) = do + logReason ident reason + unregisterGhcPkgIds wc localDB $ select ident gid :| [] + + case cv of + -- GHC versions >= 8.0.1 support batch unregistering of packages. See + -- https://github.com/commercialhaskell/stack/pull/4554 + ACGhc v | v >= mkVersion [8, 0, 1] -> do + platform <- view platformL + -- According to https://support.microsoft.com/en-us/help/830473/command-prompt-cmd-exe-command-line-string-limitation + -- the maximum command line length on Windows since XP is 8191 characters. + -- We use conservative batch size of 100 ids on this OS thus argument name '-ipid', package name, + -- its version and a hash should fit well into this limit. + -- On Unix-like systems we're limited by ARG_MAX which is normally hundreds + -- of kilobytes so batch size of 500 should work fine. + let batchSize = case platform of + Platform _ Windows -> 100 + _ -> 500 + let chunksOfNE size = catMaybes . map nonEmpty . chunksOf size . NonEmpty.toList + for_ (chunksOfNE batchSize ids) $ \batch -> do + for_ batch $ \(_, (ident, reason)) -> logReason ident reason + unregisterGhcPkgIds wc localDB $ fmap (Right . fst) batch + + -- GHC versions >= 7.9 support unregistering of packages via their + -- GhcPkgId. + ACGhc v | v >= mkVersion [7, 9] -> for_ ids . unregisterSinglePkg $ \_ident gid -> Right gid + + _ -> for_ ids . unregisterSinglePkg $ \ident _gid -> Left ident + toActions :: HasEnvConfig env => InstalledMap -> Maybe (MVar ()) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 983215b787..7996eb6331 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -10,7 +10,7 @@ module Stack.GhcPkg (getGlobalDB ,findGhcPkgField ,createDatabase - ,unregisterGhcPkgId + ,unregisterGhcPkgIds ,getCabalPkgVer ,ghcPkgExeName ,ghcPkgPathEnvVar @@ -21,9 +21,9 @@ import Stack.Prelude import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import Data.List +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Distribution.Version (mkVersion) import Path (parent, ()) import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -147,25 +147,24 @@ findGhcPkgVersion wc pkgDbs name = do Just !v -> return (parseVersion $ T.unpack v) _ -> return Nothing -unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env) +-- | unregister list of package ghcids, batching available from GHC 8.0.1, +-- using GHC package id where available (from GHC 7.9) +unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env) => WhichCompiler - -> ActualCompiler -> Path Abs Dir -- ^ package database - -> GhcPkgId - -> PackageIdentifier + -> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env () -unregisterGhcPkgId wc cv pkgDb gid ident = do +unregisterGhcPkgIds wc pkgDb epgids = do eres <- ghcPkg wc [pkgDb] args case eres of Left e -> logWarn $ displayShow e Right _ -> return () where - -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead args = "unregister" : "--user" : "--force" : - (case cv of - ACGhc v | v < mkVersion [7, 9] -> - [packageIdentifierString ident] - _ -> ["--ipid", ghcPkgIdString gid]) + concatMap (either + (\ident -> [packageIdentifierString ident]) + (\gid -> ["--ipid", ghcPkgIdString gid])) + epgids -- | Get the version of Cabal from the global package database. getCabalPkgVer :: (HasProcessContext env, HasLogFunc env)