Keep a running InstalledPackageIndex to skip expensive per-package ghc-pkg calls

Cabal/src/Distribution/Simple/Configure.hs

@@ -34,6 +34,7 @@ module Distribution.Simple.Configure
   ( configure
   , configure_setupHooks
   , computePackageInfo
+  , computePackageInfoFromIndex
   , configureFinal
   , runPreConfPackageHook
   , runPostConfPackageHook
@@ -1180,10 +1181,22 @@ computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do
       mbWorkDir
       packageDbs
       programDb0
+  computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet
 
-  -- The set of package names which are "shadowed" by internal
-  -- packages, and which component they map to
-  let internalPackageSet :: Set LibraryName
+-- | Like 'computePackageInfo' but takes a given 'InstalledPackageIndex'
+-- instead of needing to query the @hc-pkg@ program to obtain it.
+computePackageInfoFromIndex
+  :: VerbosityHandles
+  -> ConfigFlags
+  -> GenericPackageDescription
+  -> InstalledPackageIndex
+  -> IO ([PackageVersionConstraint], PackageInfo)
+computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet = do
+  let common = configCommonFlags cfg
+      verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+      -- The set of package names which are "shadowed" by internal
+      -- packages, and which component they map to
+      internalPackageSet :: Set LibraryName
       internalPackageSet = getInternalLibraries g_pkg_descr
 
   -- Some sanity checks related to dynamic/static linking.

cabal-install/src/Distribution/Client/InLibrary.hs

@@ -30,6 +30,7 @@ import qualified Distribution.Simple.Configure as Cabal
 import Distribution.Simple.Haddock (haddock_setupHooks)
 import Distribution.Simple.Install (install_setupHooks)
 import Distribution.Simple.LocalBuildInfo (mbWorkDirLBI)
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 import qualified Distribution.Simple.PreProcess as Cabal
 import Distribution.Simple.Program.Db
 import qualified Distribution.Simple.Register as Cabal
@@ -68,6 +69,7 @@ data LibraryConfigureInputs = LibraryConfigureInputs
   , packageDescription :: PD.PackageDescription
   , gPackageDescription :: PD.GenericPackageDescription
   , flagAssignment :: PD.FlagAssignment
+  , installedPkgIndex :: InstalledPackageIndex
   }
 
 libraryConfigureInputsFromElabPackage
@@ -76,6 +78,7 @@ libraryConfigureInputsFromElabPackage
   -> ProgramDb
   -> ElaboratedSharedConfig
   -> ElaboratedReadyPackage
+  -> InstalledPackageIndex
   -> [String]
   -- ^ targets
   -> LibraryConfigureInputs
@@ -90,6 +93,7 @@ libraryConfigureInputsFromElabPackage
     , pkgConfigCompiler = compil
     }
   (ReadyPackage pkg)
+  ipi
   userTargets =
     LibraryConfigureInputs
       { verbosityHandles = verbHandles
@@ -119,6 +123,7 @@ libraryConfigureInputsFromElabPackage
       , packageDescription = pkgDescr
       , gPackageDescription = gpkgDescr
       , flagAssignment = elabFlagAssignment pkg
+      , installedPkgIndex = ipi
       }
     where
       pkgDescr = elabPkgDescription pkg
@@ -140,6 +145,7 @@ configure
     , packageDescription = pkgDescr
     , gPackageDescription = gpkgDescr
     , flagAssignment = flagAssgn
+    , installedPkgIndex = ipi
     }
   cfg = do
     -- Here, we essentially want to call the Cabal library 'configure' function,
@@ -157,14 +163,15 @@ configure
           configureHooks $
             ExternalHooksExe.buildTypeSetupHooks verbosity mbWorkDir distPref bt
 
+    let pkgId :: PD.PackageIdentifier
+        pkgId = PD.package pkgDescr
+
     -- cabal-install uses paths relative to the current working directory,
     -- while the Cabal library expects symbolic paths. Perform the conversion here
     -- by making the paths absolute.
     packageDBs' <- traverse (traverse $ fmap makeSymbolicPath . canonicalizePath) packageDBs
 
     -- Configure package
-    let pkgId :: PD.PackageIdentifier
-        pkgId = PD.package pkgDescr
     case mbComp of
       Nothing -> setupMessage verbosity "Configuring" pkgId
       Just cname ->
@@ -188,11 +195,17 @@ configure
               { testsRequested = Cabal.fromFlag (Cabal.configTests cfg)
               , benchmarksRequested = Cabal.fromFlag (Cabal.configBenchmarks cfg)
               }
-    (_allConstraints, pkgInfo) <-
-      Cabal.computePackageInfo verbHandles cfg lbc1 gpkgDescr compil
-    -- It's OK to discard constraints here: we already have a finalized PackageDescription
+
+    -- NB: it's OK to discard constraints here: we already have a finalized PackageDescription
     -- in hand, and we are using exact UnitIds for all dependencies (this corresponds
     -- to using --exact-configuration and --dependency flags with the Setup CLI).
+    (_allConstraints, pkgInfo) <-
+      -- Use cabal-install's running InstalledPackageIndex 'ipi' to skip over
+      -- having to invoke ghc-pkg once per package.
+      --
+      -- See (ProjIPI3) from Note [Per-project InstalledPackageIndex]
+      -- in Distribution.Client.ProjectBuilding.
+      Cabal.computePackageInfoFromIndex verbHandles cfg gpkgDescr ipi
 
     -- Post-configure hooks & per-component configure
     lbi1 <-

cabal-install/src/Distribution/Client/ProjectBuilding.hs

@@ -87,7 +87,10 @@ import qualified Data.Set as Set
 
 import qualified Text.PrettyPrint as Disp
 
+import Control.Concurrent.STM (TVar, newTVarIO)
 import Control.Exception (assert, handle)
+import qualified Distribution.Client.IndexUtils as IndexUtils
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
 import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
 import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
 import System.Semaphore (SemaphoreName (..))
@@ -367,6 +370,19 @@ rebuildTargets
         createDirectoryIfMissingVerbose verbosity True distTempDirectory
         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 
+        -- Populate the running InstalledPackageIndex by doing a single
+        -- bulk read at startup. This allows us to obtain the
+        -- InstalledPackageInfo of every 'PreExisting' and 'Installed' unit
+        -- in the plan, regardless of how they ended up in the PackageDBs.
+        -- See (ProjIPI1) in Note [Per-project InstalledPackageIndex].
+        initialIPI <-
+          -- NB: 'getInstalledPackages' returns an error when there are no
+          -- PackageDBs, so we handle that case explicitly first.
+          if null packageDBsToUse
+            then return mempty
+            else IndexUtils.getInstalledPackages verbosity compiler packageDBsToUse progdb
+        ipiTVar <- newTVarIO initialIPI
+
         -- Concurrency control: create the job controller and concurrency limits
         -- for downloading, building and installing.
         withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do
@@ -401,6 +417,7 @@ rebuildTargets
                       cacheLock
                       sharedPackageConfig
                       installPlan
+                      ipiTVar
                       pkg
                       pkgBuildStatus
     where
@@ -457,6 +474,34 @@ rebuildTargets
           isRemote (RemoteSourceRepoPackage _ _) = True
           isRemote _ = False
 
+{- Note [Per-project InstalledPackageIndex]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In cabal-install, we keep a running InstalledPackageIndex, used for the whole
+project, containing all registered units relevant to the project.
+
+We do this to avoid repeatedly querying @ghc-pkg@ on a per-package basis when
+configuring individual packages.
+
+  (ProjIPI1)
+    We initialise the index with a single @ghc-pkg dump@ invocation, which
+    queries all the package DBs that the plan touches. This single read
+    replaces the per-package query that 'computePackageInfo' would otherwise
+    perform.
+
+    This robustly handles the case of resuming an interrupted build.
+
+  (ProjIPI2)
+    During execution, each time we register a library, we insert its
+    InstalledPackageInfo into the index, so that subsequent packages that
+    depend on it have it available, without needing to re-query @ghc-pkg@.
+
+  (ProjIPI3)
+    Before configuring a package, we read the running InstalledPackageIndex
+    and pass it to Cabal's 'computePackageInfoFromIndex' instead of
+    'computePackageInfo', skipping the expensive per-package @ghc-pkg dump@
+    invocation.
+-}
+
 -- | Create a package DB if it does not currently exist. Note that this action
 -- is /not/ safe to run concurrently.
 createPackageDBIfMissing
@@ -488,6 +533,7 @@ rebuildTarget
   -> Lock
   -> ElaboratedSharedConfig
   -> ElaboratedInstallPlan
+  -> TVar InstalledPackageIndex
   -> ElaboratedReadyPackage
   -> BuildStatus
   -> IO BuildResult
@@ -502,6 +548,7 @@ rebuildTarget
   cacheLock
   sharedPackageConfig
   plan
+  ipiTVar
   rpkg@(ReadyPackage pkg)
   pkgBuildStatus
     -- Technically, doing the --only-download filtering only in this function is
@@ -588,6 +635,7 @@ rebuildTarget
           sharedPackageConfig
           plan
           rpkg
+          ipiTVar
           srcdir
           builddir
 
@@ -604,6 +652,7 @@ rebuildTarget
           sharedPackageConfig
           plan
           rpkg
+          ipiTVar
           buildStatus
           srcdir
           builddir