Use a separate build cache for each component of a package

tswelsh · snoyberg · commit e8c2dc31c100 · 2018-01-10T19:04:11.000-08:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -14,7 +14,9 @@ Bug fixes:
 * 1.6.1 introduced a change that made some precompiled cache files use
   longer paths, sometimes causing builds to fail on windows. This has been
   fixed. See [#3649](https://github.com/commercialhaskell/stack/issues/3649)
-
+* 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
 
diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs
@@ -107,10 +107,24 @@ 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 :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env)
-                 => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
-tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir
+                 => Path Abs Dir -> NamedComponent -> m (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 :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
@@ -124,9 +138,9 @@ tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
 
 -- | Write the dirtiness cache for this package's files.
 writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
-                => Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
-writeBuildCache dir times = do
-    fp <- buildCacheFile dir
+                => Path Abs Dir -> NamedComponent -> Map FilePath FileCacheInfo -> m ()
+writeBuildCache dir component times = do
+    fp <- buildCacheFile dir component
     $(versionedEncodeFile buildCacheVC) fp BuildCache
         { buildCacheTimes = times
         }
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -1372,7 +1372,8 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
         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.
@@ -1566,10 +1567,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 []
 
diff --git a/src/Stack/Build/Source.hs b/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)
diff --git a/src/Stack/Constants/Config.hs b/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
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
@@ -308,8 +308,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
diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs
@@ -248,9 +248,9 @@ 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
@@ -303,6 +303,9 @@ isCBench :: NamedComponent -> Bool
 isCBench CBench{} = True
 isCBench _ = False
 
+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)
