diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 01da7195d51..e2b5435fbb3 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -125,6 +125,7 @@ data StoreDirLayout = StoreDirLayout , storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack , storeIncomingDirectory :: Compiler -> FilePath , storeIncomingLock :: Compiler -> UnitId -> FilePath + , storeGcRootsDirectory :: FilePath } -- TODO: move to another module, e.g. CabalDirLayout? @@ -299,6 +300,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 d38f07037a6..07d51b63af3 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -19,6 +19,9 @@ module Distribution.Client.ProjectPlanOutput , createPackageEnvironment , writePlanGhcEnvironment , argsEquivalentOfGhcEnvironmentFile + + -- * Store garbage collection + , writeGcRoot ) where import Distribution.Client.DistDirLayout @@ -40,7 +43,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 (CompilerFlavor (GHC, GHCJS)) +import Distribution.Compiler (CompilerFlavor (..), AbiTag (..)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package import qualified Distribution.PackageDescription as PD @@ -50,7 +53,7 @@ import Distribution.Simple.BuildPaths , exeExtension ) import Distribution.Simple.Compiler - ( Compiler + ( Compiler (compilerAbiTag) , CompilerId (..) , PackageDB (..) , PackageDBStack @@ -66,6 +69,7 @@ import Distribution.Simple.GHC , simpleGhcEnvironmentFile , writeGhcEnvironmentFile ) +import Distribution.Simple.Program.GHC (packageDbArgsDb) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.Version @@ -75,9 +79,11 @@ import Distribution.Utils.Path hiding ( (<.>) , () ) +import Distribution.Utils.String (encodeStringUtf8) import Distribution.Verbosity import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Directory (createFileLink) import Prelude () import qualified Data.ByteString.Builder as BB @@ -87,8 +93,11 @@ import qualified Data.Set as Set import System.FilePath import System.IO +import System.Directory (removeFile) +import Control.Exception (handleJust) +import System.IO.Error (isDoesNotExistError) +import Data.Containers.ListUtils (nubOrd) -import Distribution.Simple.Program.GHC (packageDbArgsDb) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -1030,3 +1039,49 @@ 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 efc4ebbd1e4..8fa4d0e3849 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -854,6 +854,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