diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 64140152453..cc8f650b2f4 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -126,6 +126,7 @@ data StoreDirLayout = StoreDirLayout , storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD , storeIncomingDirectory :: Compiler -> FilePath , storeIncomingLock :: Compiler -> UnitId -> FilePath + , storeGcRootsDirectory :: FilePath } -- TODO: move to another module, e.g. CabalDirLayout? @@ -300,6 +301,10 @@ defaultStoreDirLayout storeRoot = storeIncomingLock compiler unitid = storeIncomingDirectory compiler prettyShow unitid <.> "lock" + storeGcRootsDirectory :: FilePath + storeGcRootsDirectory = + storeRoot "gc-roots" + defaultCabalDirLayout :: IO CabalDirLayout defaultCabalDirLayout = mkCabalDirLayout Nothing Nothing diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index b6b5dc8dd79..f17bc6fdde8 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -15,6 +15,9 @@ module Distribution.Client.ProjectPlanOutput , createPackageEnvironment , writePlanGhcEnvironment , argsEquivalentOfGhcEnvironmentFile + + -- * Store garbage collection + , writeGcRoot ) where import Distribution.Client.DistDirLayout @@ -36,6 +39,7 @@ import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Graph as Graph +import Distribution.Compiler (AbiTag (..), CompilerFlavor (..)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package import qualified Distribution.PackageDescription as PD @@ -45,6 +49,20 @@ import Distribution.Simple.BuildPaths , exeExtension ) import Distribution.Simple.Compiler + ( Compiler (compilerAbiTag) + , CompilerId (..) + , GlobalPackageDB + , PackageDB (..) + , PackageDBCWD + , PackageDBStack + , PackageDBStackCWD + , SpecificPackageDB + , UserPackageDB + , compilerFlavor + , compilerId + , compilerVersion + , showCompilerId + ) import Distribution.Simple.GHC ( GhcEnvironmentFileEntry (..) , GhcImplInfo (supportsPkgEnvFiles) @@ -52,6 +70,7 @@ import Distribution.Simple.GHC , simpleGhcEnvironmentFile , writeGhcEnvironmentFile ) +import Distribution.Simple.Program.GHC (packageDbArgsDb) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.Version @@ -61,8 +80,10 @@ import Distribution.Utils.Path hiding ( (<.>) , () ) +import Distribution.Utils.String (encodeStringUtf8) import Distribution.Verbosity +import Distribution.Client.Compat.Directory (createFileLink) import Distribution.Client.Compat.Prelude import Prelude () @@ -71,10 +92,12 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Map as Map import qualified Data.Set as Set +import Control.Exception (handleJust) +import Data.Containers.ListUtils (nubOrd) +import System.Directory (removeFile) import System.FilePath import System.IO - -import Distribution.Simple.Program.GHC (packageDbArgsDb) +import System.IO.Error (isDoesNotExistError) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -1016,3 +1039,50 @@ relativePackageDBPath relroot pkgdb = SpecificPackageDB path -> SpecificPackageDB relpath where relpath = makeRelative (normalise relroot) path + +-- | Establish backlinks for garbage collection of the store +writeGcRoot + :: Verbosity + -> StoreDirLayout + -> DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO () +writeGcRoot verbosity storeDirLayout distDirLayout elaboratedSharedConfig elaboratedInstallPlan = do + -- NOTE: this needs some thinking + -- We need to establish backlinks for the store so that we can collect garbage later on. + -- We have the whole build graph here so, to be pragmatic we are going to list all the + -- non-inplace units in the plan, irrespectively of whether they are direct or transitive + -- dependencies. + let refsUnitIds = + [ elabUnitId elab + | InstallPlan.Configured elab <- InstallPlan.toList elaboratedInstallPlan + , not (isInplaceBuildStyle (elabBuildStyle elab)) + ] + writeFile referencesFile $ unlines $ map unUnitId $ nubOrd refsUnitIds + + -- Write the gc root + createDirectoryIfMissingVerbose verbosity True storeGcRootsDir + + -- To avoid collision we name the link with the hash of the dist directory. + let gcRootPath = storeGcRootsDir showHashValue (hashValue (encodePath distDir)) + + handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) mempty $ + removeFile gcRootPath + + createFileLink distDir gcRootPath + where + storeGcRootsDir = storeGcRootsDirectory storeDirLayout + distDir = distDirectory distDirLayout + referencesFile = distProjectCacheFile distDirLayout "store-refs-" <> compilerTag + compiler = pkgConfigCompiler elaboratedSharedConfig + -- NOTE: It would be a good idea to expose this in StoreDirLayoyt + compilerTag = case compilerAbiTag compiler of + NoAbiTag -> prettyShow (compilerId compiler) + AbiTag tag -> prettyShow (compilerId compiler) <> "-" <> tag + + -- NOTE: A FilePath should never represented as a String as we should never + -- have to do this. Nevetheless we do not need this to be stable as changes + -- will only mean a new root is created in place of the old one. Two roots + -- pointing to the same directory should never be a problem. + encodePath = BS.pack . encodeStringUtf8 diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 582e526af53..f82b39b955b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -861,6 +861,9 @@ rebuildInstallPlan elaboratedPlan elaboratedShared + debug verbosity "Creating store garbage-collection root" + writeGcRoot verbosity cabalStoreDirLayout distDirLayout elaboratedShared elaboratedPlan + -- Improve the elaborated install plan. The elaborated plan consists -- mostly of source packages (with full nix-style hashed ids). Where -- corresponding installed packages already exist in the store, replace