Use a separate build cache for each component of a package

Author: tswelsh

ChangeLog.md

@@ -49,6 +49,9 @@ Bug fixes:
   may interfere with benchmarks. It also prevented benchmark output from
   being displayed by default. This is now fixed. See
   [#3663](https://github.com/commercialhaskell/stack/issues/3663).
+* Some unnecessary rebuilds when no files were changed are now avoided, by
+  having a separate build cache for each component of a package. See
+  [#3732](https://github.com/commercialhaskell/stack/issues/3732).
 
 ## v1.6.3
 

src/Stack/Build/Cache.hs

@@ -54,6 +54,7 @@ import           Stack.Types.BuildPlan
 import           Stack.Types.Compiler
 import           Stack.Types.Config
 import           Stack.Types.GhcPkgId
+import           Stack.Types.NamedComponent
 import           Stack.Types.Package
 import           Stack.Types.PackageIdentifier
 import           Stack.Types.Version
@@ -107,10 +108,26 @@ markExeNotInstalled loc ident = do
     ident' <- parseRelFile $ packageIdentifierString ident
     liftIO $ ignoringAbsence (removeFile $ dir </> ident')
 
+buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m)
+               => Path Abs Dir
+               -> NamedComponent
+               -> m (Path Abs File)
+buildCacheFile dir component = do
+    cachesDir <- buildCachesDir dir
+    let nonLibComponent prefix name = prefix <> "-" <> T.unpack name
+    cacheFileName <- parseRelFile $ case component of
+        CLib -> "lib"
+        CExe name -> nonLibComponent "exe" name
+        CTest name -> nonLibComponent "test" name
+        CBench name -> nonLibComponent "bench" name
+    return $ cachesDir </> cacheFileName
+
 -- | Try to read the dirtiness cache for the given package directory.
 tryGetBuildCache :: HasEnvConfig env
-                 => Path Abs Dir -> RIO env (Maybe (Map FilePath FileCacheInfo))
-tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir
+                 => Path Abs Dir
+                 -> NamedComponent
+                 -> RIO env (Maybe (Map FilePath FileCacheInfo))
+tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component
 
 -- | Try to read the dirtiness cache for the given package directory.
 tryGetConfigCache :: HasEnvConfig env
@@ -124,9 +141,11 @@ tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
 
 -- | Write the dirtiness cache for this package's files.
 writeBuildCache :: HasEnvConfig env
-                => Path Abs Dir -> Map FilePath FileCacheInfo -> RIO env ()
-writeBuildCache dir times = do
-    fp <- buildCacheFile dir
+                => Path Abs Dir
+                -> NamedComponent
+                -> Map FilePath FileCacheInfo -> RIO env ()
+writeBuildCache dir component times = do
+    fp <- buildCacheFile dir component
     $(versionedEncodeFile buildCacheVC) fp BuildCache
         { buildCacheTimes = times
         }

src/Stack/Build/Execute.hs

@@ -1393,7 +1393,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
         case taskType of
             TTFiles lp _ -> do -- FIXME should this only be for local packages?
                 when enableTests $ unsetTestSuccess pkgDir
-                writeBuildCache pkgDir $ lpNewBuildCache lp
+                mapM_ (uncurry (writeBuildCache pkgDir))
+                      (Map.toList $ lpNewBuildCaches lp)
             TTIndex{} -> return ()
 
         -- FIXME: only output these if they're in the build plan.
@@ -1595,10 +1596,11 @@ checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do
             (lpPackage lp)
             (lpCabalFile lp)
             (lpComponents lp)
-            (lpNewBuildCache lp)
-    unless (null addBuildCache) $
-        writeBuildCache pkgDir $
-        Map.unions (lpNewBuildCache lp : addBuildCache)
+            (lpNewBuildCaches lp)
+    forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do
+        let cache = Map.findWithDefault Map.empty component (lpNewBuildCaches lp)
+        writeBuildCache pkgDir component $
+            Map.unions (cache : newToCache)
     return warnings
 checkForUnlistedFiles TTIndex{} _ _ = return []
 

src/Stack/Build/Source.hs

@@ -265,28 +265,36 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do
         testpkg = resolvePackage testconfig gpkg
         benchpkg = resolvePackage benchconfig gpkg
 
-    mbuildCache <- tryGetBuildCache $ lpvRoot lpv
-
-    (files,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents
-
-    (dirtyFiles, newBuildCache) <- checkBuildCache
-        (fromMaybe Map.empty mbuildCache)
-        (Set.toList files)
+    (componentFiles,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents
+
+    checkCacheResults <- forM (Map.toList componentFiles) $ \(component, files) -> do
+        mbuildCache <- tryGetBuildCache (lpvRoot lpv) component
+        checkCacheResult <- checkBuildCache
+            (fromMaybe Map.empty mbuildCache)
+            (Set.toList files)
+        return (component, checkCacheResult)
+
+    let allDirtyFiles =
+            Set.unions $
+                map (\(_, (dirtyFiles, _)) -> dirtyFiles) checkCacheResults
+        newBuildCaches =
+            M.fromList $
+                map (\(c, (_, cache)) -> (c, cache)) checkCacheResults
 
     return LocalPackage
         { lpPackage = pkg
         , lpTestDeps = packageDeps testpkg
         , lpBenchDeps = packageDeps benchpkg
         , lpTestBench = btpkg
-        , lpFiles = files
+        , lpComponentFiles = componentFiles
         , lpForceDirty = boptsForceDirty bopts
         , lpDirtyFiles =
-            if not (Set.null dirtyFiles)
+            if not (Set.null allDirtyFiles)
                 then let tryStripPrefix y =
                           fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y)
-                      in Just $ Set.map tryStripPrefix dirtyFiles
+                      in Just $ Set.map tryStripPrefix allDirtyFiles
                 else Nothing
-        , lpNewBuildCache = newBuildCache
+        , lpNewBuildCaches = newBuildCaches
         , lpCabalFile = lpvCabalFP lpv
         , lpDir = lpvRoot lpv
         , lpWanted = isWanted
@@ -394,15 +402,18 @@ addUnlistedToBuildCache
     -> Package
     -> Path Abs File
     -> Set NamedComponent
-    -> Map FilePath a
-    -> RIO env ([Map FilePath FileCacheInfo], [PackageWarning])
-addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCache = do
-    (files,warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents
-    let newFiles =
-            Set.toList $
-            Set.map toFilePath files `Set.difference` Map.keysSet buildCache
-    addBuildCache <- mapM addFileToCache newFiles
-    return (addBuildCache, warnings)
+    -> Map NamedComponent (Map FilePath a)
+    -> RIO env (Map NamedComponent [Map FilePath FileCacheInfo], [PackageWarning])
+addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCaches = do
+    (componentFiles, warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents
+    results <- forM (M.toList componentFiles) $ \(component, files) -> do
+        let buildCache = M.findWithDefault M.empty component buildCaches
+            newFiles =
+                Set.toList $
+                Set.map toFilePath files `Set.difference` Map.keysSet buildCache
+        addBuildCache <- mapM addFileToCache newFiles
+        return ((component, addBuildCache), warnings)
+    return (M.fromList (map fst results), concatMap snd results)
   where
     addFileToCache fp = do
         mmodTime <- getModTimeMaybe fp
@@ -420,16 +431,18 @@ addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCache = d
 --   set of components.
 getPackageFilesForTargets
     :: HasEnvConfig env
-    => Package -> Path Abs File -> Set NamedComponent -> RIO env (Set (Path Abs File), [PackageWarning])
-getPackageFilesForTargets pkg cabalFP components = do
+    => Package
+    -> Path Abs File
+    -> Set NamedComponent
+    -> RIO env (Map NamedComponent (Set (Path Abs File)), [PackageWarning])
+getPackageFilesForTargets pkg cabalFP nonLibComponents = do
     (_,compFiles,otherFiles,warnings) <-
         getPackageFiles (packageFiles pkg) cabalFP
-    let filesForComponent cn = Set.map dotCabalGetPath
-                             $ M.findWithDefault mempty cn compFiles
-        files = Set.unions
-                $ otherFiles
-                : map filesForComponent (Set.toList $ Set.insert CLib components)
-    return (files, warnings)
+    let components = Set.insert CLib nonLibComponents
+        componentsFiles =
+            M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath files)) $
+                M.filterWithKey (\component _ -> component `Set.member` components) compFiles
+    return (componentsFiles, warnings)
 
 -- | Get file modification time, if it exists.
 getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)

src/Stack/Constants/Config.hs

@@ -9,7 +9,7 @@ module Stack.Constants.Config
   , projectDockerSandboxDir
   , configCacheFile
   , configCabalMod
-  , buildCacheFile
+  , buildCachesDir
   , testSuccessFile
   , testBuiltFile
   , hpcRelativeDir
@@ -32,13 +32,13 @@ objectInterfaceDirL = to $ \env -> -- FIXME is this idomatic lens code?
       root = view projectRootL env
    in root </> workDir </> $(mkRelDir "odir/")
 
--- | The filename used for dirtiness check of source files.
-buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
+-- | The directory containing the files used for dirtiness check of source files.
+buildCachesDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
                => Path Abs Dir      -- ^ Package directory.
-               -> m (Path Abs File)
-buildCacheFile dir =
+               -> m (Path Abs Dir)
+buildCachesDir dir = 
     liftM
-        (</> $(mkRelFile "stack-build-cache"))
+        (</> $(mkRelDir "stack-build-caches"))
         (distDirFromDir dir)
 
 -- | The filename used to mark tests as having succeeded

src/Stack/SDist.hs

@@ -307,8 +307,8 @@ readLocalPackage pkgDir = do
         , lpTestBench = Nothing
         , lpForceDirty = False
         , lpDirtyFiles = Nothing
-        , lpNewBuildCache = Map.empty
-        , lpFiles = Set.empty
+        , lpNewBuildCaches = Map.empty
+        , lpComponentFiles = Map.empty
         , lpComponents = Set.empty
         , lpUnbuildable = Set.empty
         , lpLocation = PLFilePath $ toFilePath pkgDir

src/Stack/Types/Package.hs

@@ -13,6 +13,7 @@ import           Stack.Prelude
 import qualified Data.ByteString as S
 import           Data.List
 import qualified Data.Map as M
+import qualified Data.Set as Set
 import           Data.Store.Version (VersionConfig)
 import           Data.Store.VersionTagged (storeVersionConfig)
 import           Distribution.InstalledPackageInfo (PError)
@@ -246,15 +247,18 @@ data LocalPackage = LocalPackage
     -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if
     -- we forced the build to treat packages as dirty. Also, the Set may not
     -- include all modified files.
-    , lpNewBuildCache :: !(Map FilePath FileCacheInfo)
+    , lpNewBuildCaches :: !(Map NamedComponent (Map FilePath FileCacheInfo))
     -- ^ current state of the files
-    , lpFiles         :: !(Set (Path Abs File))
+    , lpComponentFiles :: !(Map NamedComponent (Set (Path Abs File)))
     -- ^ all files used by this package
     , lpLocation      :: !(PackageLocation FilePath)
     -- ^ Where this source code came from
     }
     deriving Show
 
+lpFiles :: LocalPackage -> Set.Set (Path Abs File)
+lpFiles = Set.unions . M.elems . lpComponentFiles
+
 -- | A location to install a package into, either snapshot or local
 data InstallLocation = Snap | Local
     deriving (Show, Eq)