FinderCache: Also cache file hashing in interface file checkswip/hash-file-cache

Now that we hash object files to decide when to recompile due to TH,
this can make a big difference as each interface file in a project will
contain reference to the object files of all package dependencies.
Especially when these are statically linked, hashing them can add up.

The cache is invalidated when `depanalPartial` is called, like the
normal finder cache.

3 files changed, 39 insertions, 17 deletions

diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 68ca5bfdbe..7759aea72d 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -271,7 +271,7 @@ checkVersions hsc_env mod_summary iface
        when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
           ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ (dep_boot_mods (mi_deps iface)) }
        }
-       ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u
+       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u
                              | u <- mi_usages iface]
        ; return (recomp, Just iface)
     }}}}}}}}}}}
@@ -550,8 +550,8 @@ getFromModIface doc_msg mod getter
 -- | Given the usage information extracted from the old
 -- M.hi file for the module being compiled, figure out
 -- whether M needs to be recompiled.
-checkModUsage :: Unit -> Usage -> IfG RecompileRequired
-checkModUsage _this_pkg UsagePackageModule{
+checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired
+checkModUsage _ _this_pkg UsagePackageModule{
                                 usg_mod = mod,
                                 usg_mod_hash = old_mod_hash } = do
   logger <- getLogger
@@ -563,19 +563,19 @@ checkModUsage _this_pkg UsagePackageModule{
         -- recompile.  This is safe but may entail more recompilation when
         -- a dependent package has changed.
 
-checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
+checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
   logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
     checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
-checkModUsage this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do
+checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do
   let mod = mkModule this_pkg mod_name
   logger <- getLogger
   needInterface mod $ \iface -> do
     let reason = moduleNameString (moduleName mod) ++ " changed (interface)"
     checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))
 
-checkModUsage this_pkg UsageHomeModule{
+checkModUsage _ this_pkg UsageHomeModule{
                                 usg_mod_name = mod_name,
                                 usg_mod_hash = old_mod_hash,
                                 usg_exports = maybe_old_export_hash,
@@ -602,19 +602,18 @@ checkModUsage this_pkg UsageHomeModule{
                (text "  Export list changed") $ do
 
                  -- CHECK ITEMS ONE BY ONE
-                 recompile <- checkList [ checkEntityUsage logger reason new_decl_hash u
-                                        | u <- old_decl_hash]
+                 !recompile <- checkList [ checkEntityUsage logger reason new_decl_hash u
+                                          | u <- old_decl_hash]
                  if recompileRequired recompile
                    then return recompile     -- This one failed, so just bail out now
                    else up_to_date logger (text "  Great!  The bits I use are up to date")
 
-
-checkModUsage _this_pkg UsageFile{ usg_file_path = file,
+checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,
                                    usg_file_hash = old_hash,
                                    usg_file_label = mlabel } =
   liftIO $
     handleIO handler $ do
-      new_hash <- getFileHash file
+      new_hash <- lookupFileCache fc file
       if (old_hash /= new_hash)
          then return recomp
          else return UpToDate
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index 0a42149a42..57e458af79 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -30,6 +30,9 @@ module GHC.Unit.Finder (
     findObjectLinkableMaybe,
     findObjectLinkable,
 
+    -- Hash cache
+    lookupFileCache
+
   ) where
 
 import GHC.Prelude
@@ -56,11 +59,13 @@ import GHC.Utils.Panic
 
 import GHC.Linker.Types
 
+import GHC.Fingerprint
 import Data.IORef
 import System.Directory
 import System.FilePath
 import Control.Monad
 import Data.Time
+import qualified Data.Map as M
 
 
 type FileExt = String   -- Filename extension
@@ -82,28 +87,41 @@ type BaseName = String  -- Basename of file
 
 initFinderCache :: IO FinderCache
 initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv
+                              <*> newIORef M.empty
 
 -- remove all the home modules from the cache; package modules are
--- assumed to not move around during a session.
+-- assumed to not move around during a session; also flush the file hash
+-- cache
 flushFinderCaches :: FinderCache -> HomeUnit -> IO ()
-flushFinderCaches (FinderCache ref) home_unit =
+flushFinderCaches (FinderCache ref file_ref) home_unit = do
   atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+  atomicModifyIORef' file_ref $ \_ -> (M.empty, ())
  where
   is_ext mod _ = not (isHomeInstalledModule home_unit mod)
 
 addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
-addToFinderCache (FinderCache ref) key val =
+addToFinderCache (FinderCache ref _) key val =
   atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
 
 removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()
-removeFromFinderCache (FinderCache ref) key =
+removeFromFinderCache (FinderCache ref _) key =
   atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
 
 lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
-lookupFinderCache (FinderCache ref) key = do
+lookupFinderCache (FinderCache ref _) key = do
    c <- readIORef ref
    return $! lookupInstalledModuleEnv c key
 
+lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint
+lookupFileCache (FinderCache _ ref) key = do
+   c <- readIORef ref
+   case M.lookup key c of
+     Nothing -> do
+       hash <- getFileHash key
+       atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())
+       return hash
+     Just fp -> return fp
+
 -- -----------------------------------------------------------------------------
 -- The three external entry points
 
diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs
index 06f4ea8aae..c48b7d9789 100644
--- a/compiler/GHC/Unit/Finder/Types.hs
+++ b/compiler/GHC/Unit/Finder/Types.hs
@@ -9,6 +9,8 @@ where
 import GHC.Prelude
 import GHC.Unit
 import GHC.Unit.State
+import qualified Data.Map as M
+import GHC.Fingerprint
 
 import Data.IORef
 
@@ -18,7 +20,10 @@ import Data.IORef
 -- contents of this cache.
 --
 type FinderCacheState = InstalledModuleEnv InstalledFindResult
-newtype FinderCache = FinderCache (IORef FinderCacheState)
+type FileCacheState   = M.Map FilePath Fingerprint
+data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
+                               , fcFileCache   :: (IORef FileCacheState)
+                               }
 
 data InstalledFindResult
   = InstalledFound ModLocation InstalledModule