From face11c0c0d9d162c7cd08dce3feee29f4d67d22 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Oct 2023 17:18:19 +0700 Subject: [PATCH] Include the GHC "Project Unit Id" in the cabal store path - This allows the use of several **API incompatible builds of the same version of GHC** without corrupting the cabal store. - This relies on the "Project Unit Id" which is available since GHC 9.8.1, older versions of GHC do not benefit from this change. [fixes #8114] --- Cabal/src/Distribution/Simple/GHC.hs | 12 ++- .../Distribution/Client/CmdHaddockProject.hs | 2 +- .../src/Distribution/Client/CmdInstall.hs | 14 ++-- .../src/Distribution/Client/DistDirLayout.hs | 73 ++++++++++--------- .../Distribution/Client/ProjectBuilding.hs | 7 +- .../Distribution/Client/ProjectPlanning.hs | 22 +++--- .../src/Distribution/Client/Store.hs | 46 ++++++------ changelog.d/pr-9326 | 10 +++ 8 files changed, 104 insertions(+), 82 deletions(-) create mode 100644 changelog.d/pr-9326 diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 3c380a41a86..c06fd7bdfc3 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -83,6 +84,7 @@ import Prelude () import Control.Monad (forM_, msum) import Data.Char (isLower) +import Data.List (stripPrefix) import qualified Data.Map as Map import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -246,10 +248,16 @@ configure verbosity hcPath hcPkgPath conf0 = do filterExt ext = filter ((/= EnableExtension ext) . fst) + compilerId :: CompilerId + compilerId = CompilerId GHC ghcVersion + + compilerAbiTag :: AbiTag + compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-")) + let comp = Compiler - { compilerId = CompilerId GHC ghcVersion - , compilerAbiTag = NoAbiTag + { compilerId + , compilerAbiTag , compilerCompat = [] , compilerLanguages = languages , compilerExtensions = extensions diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index d63e890a3ee..4b36b2d5116 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -318,7 +318,7 @@ haddockProjectAction flags _extraArgs globalFlags = do packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (compilerId (pkgConfigCompiler sharedConfig')) + (pkgConfigCompiler sharedConfig') (elabUnitId package) docDir = packageDir "share" "doc" "html" destDir = outputDir packageName diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 46ce2cd6e5a..5e995988ae0 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -484,9 +484,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt -- progDb is a program database with compiler tools configured properly ( compiler@Compiler - { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) - } + { compilerId = CompilerId compilerFlavor compilerVersion } , platform , progDb ) <- @@ -498,7 +496,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt envFile <- getEnvFile clientInstallFlags platform compilerVersion existingEnvEntries <- getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile - packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir + packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb let @@ -824,7 +822,7 @@ installExes mkUnitBinDir :: UnitId -> FilePath mkUnitBinDir = InstallDirs.bindir - . storePackageInstallDirs' storeDirLayout (compilerId compiler) + . storePackageInstallDirs' storeDirLayout compiler mkExeName :: UnqualComponentName -> FilePath mkExeName exe = unUnqualComponentName exe <.> exeExtension platform @@ -1204,16 +1202,16 @@ getLocalEnv dir platform compilerVersion = <> ghcPlatformAndVersionString platform compilerVersion getPackageDbStack - :: CompilerId + :: Compiler -> Flag FilePath -> Flag FilePath -> IO PackageDBStack -getPackageDbStack compilerId storeDirFlag logsDirFlag = do +getPackageDbStack compiler storeDirFlag logsDirFlag = do mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag let mlogsDir = flagToMaybe logsDirFlag cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir - pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId + pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 2b4bc54fb3e..834bda34705 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -41,7 +41,8 @@ import Distribution.Package , UnitId ) import Distribution.Simple.Compiler - ( OptimisationLevel (..) + ( Compiler (..) + , OptimisationLevel (..) , PackageDB (..) , PackageDBStack ) @@ -116,13 +117,13 @@ data DistDirLayout = DistDirLayout -- | The layout of a cabal nix-style store. data StoreDirLayout = StoreDirLayout - { storeDirectory :: CompilerId -> FilePath - , storePackageDirectory :: CompilerId -> UnitId -> FilePath - , storePackageDBPath :: CompilerId -> FilePath - , storePackageDB :: CompilerId -> PackageDB - , storePackageDBStack :: CompilerId -> PackageDBStack - , storeIncomingDirectory :: CompilerId -> FilePath - , storeIncomingLock :: CompilerId -> UnitId -> FilePath + { storeDirectory :: Compiler -> FilePath + , storePackageDirectory :: Compiler -> UnitId -> FilePath + , storePackageDBPath :: Compiler -> FilePath + , storePackageDB :: Compiler -> PackageDB + , storePackageDBStack :: Compiler -> PackageDBStack + , storeIncomingDirectory :: Compiler -> FilePath + , storeIncomingLock :: Compiler -> UnitId -> FilePath } -- TODO: move to another module, e.g. CabalDirLayout? @@ -267,33 +268,35 @@ defaultStoreDirLayout :: FilePath -> StoreDirLayout defaultStoreDirLayout storeRoot = StoreDirLayout{..} where - storeDirectory :: CompilerId -> FilePath - storeDirectory compid = - storeRoot prettyShow compid - - storePackageDirectory :: CompilerId -> UnitId -> FilePath - storePackageDirectory compid ipkgid = - storeDirectory compid prettyShow ipkgid - - storePackageDBPath :: CompilerId -> FilePath - storePackageDBPath compid = - storeDirectory compid "package.db" - - storePackageDB :: CompilerId -> PackageDB - storePackageDB compid = - SpecificPackageDB (storePackageDBPath compid) - - storePackageDBStack :: CompilerId -> PackageDBStack - storePackageDBStack compid = - [GlobalPackageDB, storePackageDB compid] - - storeIncomingDirectory :: CompilerId -> FilePath - storeIncomingDirectory compid = - storeDirectory compid "incoming" - - storeIncomingLock :: CompilerId -> UnitId -> FilePath - storeIncomingLock compid unitid = - storeIncomingDirectory compid prettyShow unitid <.> "lock" + storeDirectory :: Compiler -> FilePath + storeDirectory compiler = + storeRoot case compilerAbiTag compiler of + NoAbiTag -> prettyShow (compilerId compiler) + AbiTag tag -> prettyShow (compilerId compiler) <> "-" <> tag + + storePackageDirectory :: Compiler -> UnitId -> FilePath + storePackageDirectory compiler ipkgid = + storeDirectory compiler prettyShow ipkgid + + storePackageDBPath :: Compiler -> FilePath + storePackageDBPath compiler = + storeDirectory compiler "package.db" + + storePackageDB :: Compiler -> PackageDB + storePackageDB compiler = + SpecificPackageDB (storePackageDBPath compiler) + + storePackageDBStack :: Compiler -> PackageDBStack + storePackageDBStack compiler = + [GlobalPackageDB, storePackageDB compiler] + + storeIncomingDirectory :: Compiler -> FilePath + storeIncomingDirectory compiler = + storeDirectory compiler "incoming" + + storeIncomingLock :: Compiler -> UnitId -> FilePath + storeIncomingLock compiler unitid = + storeIncomingDirectory compiler prettyShow unitid <.> "lock" defaultCabalDirLayout :: IO CabalDirLayout defaultCabalDirLayout = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index fa917b9f1bf..9af29f82236 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1280,7 +1280,7 @@ buildAndInstallUnpackedPackage let ipkg = ipkg0{Installed.installedUnitId = uid} assert ( elabRegisterPackageDBStack pkg - == storePackageDBStack compid + == storePackageDBStack compiler ) (return ()) criticalSection registerLock $ @@ -1288,7 +1288,7 @@ buildAndInstallUnpackedPackage verbosity compiler progdb - (storePackageDBStack compid) + (storePackageDBStack compiler) ipkg Cabal.defaultRegisterOptions { Cabal.registerMultiInstance = True @@ -1300,7 +1300,7 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - compid + compiler uid copyPkgFiles registerPkg @@ -1330,7 +1330,6 @@ buildAndInstallUnpackedPackage where pkgid = packageId rpkg uid = installedUnitId rpkg - compid = compilerId compiler dispname :: String dispname = case elabPkgOrComp pkg of diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 1b92a8aa54b..b6e39442889 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -897,7 +897,7 @@ rebuildInstallPlan -> Rebuild ElaboratedInstallPlan phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid + storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler let improvedPlan = improveInstallPlanWithInstalledPackages storePkgIdSet @@ -909,7 +909,7 @@ rebuildInstallPlan -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan where - compid = compilerId (pkgConfigCompiler elaboratedShared) + compiler = pkgConfigCompiler elaboratedShared -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -2349,7 +2349,7 @@ elaborateInstallPlan corePackageDbs = applyPackageDbFlags - (storePackageDBStack (compilerId compiler)) + (storePackageDBStack compiler) (projectConfigPackageDBs sharedPackageConfig) -- For this local build policy, every package that lives in a local source @@ -4026,15 +4026,15 @@ userInstallDirTemplates compiler = do storePackageInstallDirs :: StoreDirLayout - -> CompilerId + -> Compiler -> InstalledPackageId -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs storeDirLayout compid ipkgid = - storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid +storePackageInstallDirs storeDirLayout compiler ipkgid = + storePackageInstallDirs' storeDirLayout compiler $ newSimpleUnitId ipkgid storePackageInstallDirs' :: StoreDirLayout - -> CompilerId + -> Compiler -> UnitId -> InstallDirs.InstallDirs FilePath storePackageInstallDirs' @@ -4042,12 +4042,12 @@ storePackageInstallDirs' { storePackageDirectory , storeDirectory } - compid + compiler unitid = InstallDirs.InstallDirs{..} where - store = storeDirectory compid - prefix = storePackageDirectory compid unitid + store = storeDirectory compiler + prefix = storePackageDirectory compiler unitid bindir = prefix "bin" libdir = prefix "lib" libsubdir = "" @@ -4097,7 +4097,7 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab -- use special simplified install dirs storePackageInstallDirs' storeDirLayout - (compilerId (pkgConfigCompiler elaboratedShared)) + (pkgConfigCompiler elaboratedShared) (elabUnitId elab) -- TODO: [code cleanup] perhaps reorder this code diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index d678e137090..0c6050cda7f 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -27,6 +27,7 @@ import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad import Distribution.Compiler (CompilerId) +import Distribution.Simple.Compiler (Compiler (..)) import Distribution.Package (UnitId, mkUnitId) import Distribution.Simple.Utils @@ -129,15 +130,15 @@ import GHC.IO.Handle.Lock (hUnlock) -- or replace, i.e. not failing if the db entry already exists. -- | Check if a particular 'UnitId' exists in the store. -doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool -doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = - doesDirectoryExist (storePackageDirectory compid unitid) +doesStoreEntryExist :: StoreDirLayout -> Compiler -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} compile unitid = + doesDirectoryExist (storePackageDirectory compile unitid) -- | Return the 'UnitId's of all packages\/components already installed in the -- store. -getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) -getStoreEntries StoreDirLayout{storeDirectory} compid = do - paths <- getDirectoryContentsMonitored (storeDirectory compid) +getStoreEntries :: StoreDirLayout -> Compiler -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} compiler = do + paths <- getDirectoryContentsMonitored (storeDirectory compiler) return $! mkEntries paths where mkEntries = @@ -174,7 +175,7 @@ data NewStoreEntryOutcome newStoreEntry :: Verbosity -> StoreDirLayout - -> CompilerId + -> Compiler -> UnitId -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. @@ -184,20 +185,20 @@ newStoreEntry newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} - compid + compiler unitid copyFiles register = -- See $concurrency above for an explanation of the concurrency protocol - withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do + withTempIncomingDir storeDirLayout compiler $ \incomingTmpDir -> do -- Write all store entry files within the temp dir and return the prefix. (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir -- Take a lock named after the 'UnitId' in question. - withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do + withIncomingUnitIdLock verbosity storeDirLayout compiler unitid $ do -- Check for the existence of the final store entry directory. - exists <- doesStoreEntryExist storeDirLayout compid unitid + exists <- doesStoreEntryExist storeDirLayout compiler unitid if exists then -- If the entry exists then we lost the race and we must abandon, @@ -206,7 +207,7 @@ newStoreEntry info verbosity $ "Concurrent build race: abandoning build in favour of existing " ++ "store entry " - ++ prettyShow compid + ++ prettyShow (compilerId compiler) prettyShow unitid return UseExistingStoreEntry else -- If the entry does not exist then we won the race and can proceed. @@ -217,7 +218,7 @@ newStoreEntry -- Atomically rename the temp dir to the final store entry location. renameDirectory incomingEntryDir finalEntryDir for_ otherFiles $ \file -> do - let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file + let finalStoreFile = storeDirectory compiler makeRelative (incomingTmpDir (dropDrive (storeDirectory compiler))) file createDirectoryIfMissing True (takeDirectory finalStoreFile) renameFile file finalStoreFile @@ -225,38 +226,41 @@ newStoreEntry "Installed store entry " ++ prettyShow compid prettyShow unitid return UseNewStoreEntry where - finalEntryDir = storePackageDirectory compid unitid + compid = compilerId compiler + + finalEntryDir = storePackageDirectory compiler unitid withTempIncomingDir :: StoreDirLayout - -> CompilerId + -> Compiler -> (FilePath -> IO a) -> IO a -withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do +withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compiler action = do createDirectoryIfMissing True incomingDir withTempDirectory silent incomingDir "new" action where - incomingDir = storeIncomingDirectory compid + incomingDir = storeIncomingDirectory compiler withIncomingUnitIdLock :: Verbosity -> StoreDirLayout - -> CompilerId + -> Compiler -> UnitId -> IO a -> IO a withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} - compid + compiler unitid action = bracket takeLock releaseLock (\_hnd -> action) where + compid = compilerId compiler #ifdef MIN_VERSION_lukko takeLock | fileLockingSupported = do - fd <- fdOpen (storeIncomingLock compid unitid) + fd <- fdOpen (storeIncomingLock compiler unitid) gotLock <- fdTryLock fd ExclusiveLock unless gotLock $ do info verbosity $ "Waiting for file lock on store entry " @@ -274,7 +278,7 @@ withIncomingUnitIdLock | otherwise = return () #else takeLock = do - h <- openFile (storeIncomingLock compid unitid) ReadWriteMode + h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then -- log an explanation and do it again in blocking mode. gotlock <- hTryLock h ExclusiveLock diff --git a/changelog.d/pr-9326 b/changelog.d/pr-9326 new file mode 100644 index 00000000000..33350cd86f0 --- /dev/null +++ b/changelog.d/pr-9326 @@ -0,0 +1,10 @@ +synopsis: Include the GHC "Project Unit Id" in the cabal store path +packages: Cabal cabal-install +prs: #9326 +issues: #8114 +description: { +- This allows the use of several **API incompatible builds of the same version + of GHC** without corrupting the cabal store. +- This relies on the "Project Unit Id" which is available since GHC 9.8.1, + older versions of GHC do not benefit from this change. +}