Generate bytecode/object code on demand

Adds a new rule `GetLinkable` which is called on demand by
hscCompileCoreExprHook whenever a linkable is required for a splice.

Adds a MonadUnliftIO instance for Action to faciliate the above

We write Core Files whenever a linkable could potentially be required for a file
(i.e it is in the transitive closure of a module that uses TH/compile time code
execution)

However, we only generate byte/object code when such a linkable is
really required by a splice (i.e. the module is in the transitive closure
of any symbol called from a splice).

No linkables are stored in `HiFileResult`. If a linkable is required, then
it must be obtained via a call to `GetLinkable`.

Also use hashes to do fine grained recompilation checking for TH instead of
mod times. This simplifies recompilation checking quite a bit.

ghcide/src/Development/IDE/Core/Compile.hs

@@ -31,6 +31,9 @@ module Development.IDE.Core.Compile
   , getDocsBatch
   , lookupName
   , mergeEnvs
+  , ml_core_file
+  , coreFileToLinkable
+  , TypecheckHelpers(..)
   ) where
 
 import           Control.Concurrent.Extra
@@ -45,9 +48,7 @@ import           Control.Monad.Trans.Except
 import           Data.Aeson                        (toJSON)
 import           Data.Bifunctor                    (first, second)
 import           Data.Binary
-import qualified Data.Binary                       as B
 import qualified Data.ByteString                   as BS
-import qualified Data.ByteString.Lazy              as LBS
 import           Data.Coerce
 import qualified Data.DList                        as DL
 import           Data.Functor
@@ -60,9 +61,7 @@ import           Data.Map                          (Map)
 import qualified Data.Map.Strict                   as Map
 import           Data.Maybe
 import qualified Data.Text                         as T
-import           Data.Time                         (UTCTime (..),
-                                                    getCurrentTime)
-import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import           Data.Time                         (UTCTime (..))
 import           Data.Tuple.Extra                  (dupe)
 import           Data.Unique                       as Unique
 import           Debug.Trace
@@ -81,14 +80,12 @@ import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.Orphans       ()
 import           Development.IDE.GHC.Util
 import           Development.IDE.GHC.Warnings
-import           Development.IDE.Spans.Common
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.IDE.GHC.CoreFile
 import           GHC                               (ForeignHValue,
                                                     GetDocsFailure (..),
-                                                    mgModSummaries,
                                                     parsedSource)
 import qualified GHC.LanguageExtensions            as LangExt
 import           GHC.Serialized
@@ -121,8 +118,6 @@ import           TcSplice
 import           HscTypes
 #endif
 
-import           Development.IDE.GHC.Compat.Util   (emptyUDFM, fsLit,
-                                                    plusUDFM_C)
 #if MIN_VERSION_ghc(9,2,0)
 import           GHC                               (Anchor (anchor),
                                                     EpaComment (EpaComment),
@@ -133,6 +128,7 @@ import qualified GHC                               as G
 import           GHC.Hs                            (LEpaComment)
 import qualified GHC.Types.Error                   as Error
 #endif
+import GHC (ModuleGraph, mgLookupModule, mgModSummaries)
 import qualified Control.Monad.Trans.State.Strict as S
 import Data.Generics.Schemes
 import Data.Generics.Aliases
@@ -162,12 +158,18 @@ computePackageDeps env pkg = do
             T.pack $ "unknown package: " ++ show pkg]
         Just pkgInfo -> return $ Right $ unitDepends pkgInfo
 
+data TypecheckHelpers
+  = TypecheckHelpers
+  { getLinkablesToKeep :: !(IO (ModuleEnv UTCTime))
+  , getLinkables :: !([NormalizedFilePath] -> IO [LinkableResult])
+  }
+
 typecheckModule :: IdeDefer
                 -> HscEnv
-                -> ModuleEnv UTCTime -- ^ linkables not to unload
+                -> TypecheckHelpers
                 -> ParsedModule
                 -> IO (IdeResult TcModuleResult)
-typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
+typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
         let modSummary = pm_mod_summary pm
             dflags = ms_hspp_opts modSummary
         mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"
@@ -182,7 +184,7 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
                   mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
                 in
                   catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
-                    tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
+                    tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
             let errorPipeline = unDefer . hideDiag dflags . tagDiag
                 diags = map errorPipeline warnings
                 deferedError = any fst diags
@@ -193,16 +195,16 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 
 -- | Install hooks to capture the splices as well as the runtime module dependencies
-captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)
-captureSplicesAndDeps env k = do
+captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)
+captureSplicesAndDeps TypecheckHelpers{..} env k = do
   splice_ref <- newIORef mempty
-  dep_ref <- newIORef emptyUniqSet
+  dep_ref <- newIORef emptyModuleEnv
   res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)
   splices <- readIORef splice_ref
   needed_mods <- readIORef dep_ref
   return (res, splices, needed_mods)
   where
-    addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks
+    addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks
     addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }
 
     -- We want to record exactly which linkables/modules the typechecker needed at runtime
@@ -215,12 +217,7 @@ captureSplicesAndDeps env k = do
     -- names in the compiled bytecode, recording the modules that those names
     -- come from in the IORef,, as these are the modules on whose implementation
     -- we depend.
-    --
-    -- Only compute direct dependencies instead of transitive dependencies.
-    -- It is much cheaper to store the direct dependencies, we can compute
-    -- the transitive ones when required.
-    -- Also only record dependencies from the home package
-    compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
+    compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
     compile_bco_hook var hsc_env srcspan ds_expr
       = do { let dflags = hsc_dflags hsc_env
 
@@ -257,41 +254,76 @@ captureSplicesAndDeps env k = do
                        (icInteractiveModule ictxt)
                        stg_expr
                        [] Nothing
-           ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
-                                         , Just mod <- [nameModule_maybe n] -- Names from other modules
-                                         , not (isWiredInName n) -- Exclude wired-in names
-                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package
-                                         ]
-            -- Exclude wired-in names because we may not have read
-            -- their interface files, so getLinkDeps will fail
-            -- All wired-in names are in the base package, which we link
-            -- by default, so we can safely ignore them here.
-
-             {- load it -}
-           ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
-           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
 #else
              {- Convert to BCOs -}
            ; bcos <- coreExprToBCOs hsc_env
                        (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+#endif
 
-           ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)
-                                         , Just mod <- [nameModule_maybe n] -- Names from other modules
-                                         , not (isWiredInName n) -- Exclude wired-in names
-                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package
-                                         ]
             -- Exclude wired-in names because we may not have read
             -- their interface files, so getLinkDeps will fail
             -- All wired-in names are in the base package, which we link
             -- by default, so we can safely ignore them here.
 
+            -- Find the linkables for the modules we need
+           ; let needed_mods = mkUniqSet [ moduleName mod
+#if MIN_VERSION_ghc(9,2,0)
+                                         | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
+#else
+                                         | n <- uniqDSetToList (bcoFreeNames bcos)
+#endif
+                                         , Just mod <- [nameModule_maybe n] -- Names from other modules
+                                         , not (isWiredInName n) -- Exclude wired-in names
+                                         , moduleUnitId mod == uid -- Only care about stuff from the home package
+                                         ]
+                 hpt = hsc_HPT hsc_env
+                 uid = homeUnitId_ dflags
+                 mods_transitive = getTransitiveMods hpt needed_mods
+                  -- Non det OK as we will put it into maps later anyway
+                 mods_transitive_list = nonDetEltsUniqSet mods_transitive
+
+           ; lbs <- getLinkables [toNormalizedFilePath' file | mod <- mkHomeModule
+#if MIN_VERSION_ghc(9,0,0)
+                                                                      (hscHomeUnit hsc_env)
+#else
+                                                                      uid
+#endif
+                                                                      <$> mods_transitive_list
+                                                             , let ms   = fromJust $ mgLookupModule (hsc_mod_graph hsc_env) mod
+                                                             , let file = fromJust $ ml_hs_file $ ms_location ms
+                                                             ]
+           ; let hsc_env' = hsc_env { hsc_HPT = addListToHpt hpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
+
+             -- Essential to do this here after we load the linkables
+           ; keep_lbls <- getLinkablesToKeep
+
+           ; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls
+
+#if MIN_VERSION_ghc(9,2,0)
+             {- load it -}
+           ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
+           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
+#else
              {- link it -}
-           ; hval <- linkExpr hsc_env srcspan bcos
+           ; hval <- linkExpr hsc_env' srcspan bcos
 #endif
 
-           ; modifyIORef' var (unionUniqSets needed_mods)
+           ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])
            ; return hval }
 
+    -- Compute the transitive set of linkables required
+    getTransitiveMods hpt needed_mods = go emptyUniqSet needed_mods
+      where
+        go seen new
+          | isEmptyUniqSet new = seen
+          | otherwise = go seen' new'
+            where
+              seen' = seen `unionUniqSets` new
+              new'  = new_deps `minusUniqSet` seen'
+              new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info
+                                           | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]
+
+
 
     -- | Add a Hook to the DynFlags which captures and returns the
     -- typechecked splices before they are run. This information
@@ -325,18 +357,15 @@ captureSplicesAndDeps env k = do
 
 tcRnModule
   :: HscEnv
-  -> ModuleEnv UTCTime -- ^ Program linkables not to unload
+  -> TypecheckHelpers -- ^ Program linkables not to unload
   -> ParsedModule
   -> IO TcModuleResult
-tcRnModule hsc_env keep_lbls pmod = do
+tcRnModule hsc_env tc_helpers pmod = do
   let ms = pm_mod_summary pmod
       hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
-      hpt = hsc_HPT hsc_env
 
-  unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls
-
-  ((tc_gbl_env', mrn_info), splices, mods)
-      <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp ->
+  ((tc_gbl_env', mrn_info), splices, mod_env)
+      <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp ->
              do  hscTypecheckRename hsc_env_tmp ms $
                           HsParsedModule { hpm_module = parsedSource pmod,
                                            hpm_src_files = pm_extra_src_files pmod,
@@ -345,25 +374,8 @@ tcRnModule hsc_env keep_lbls pmod = do
         Just x  -> x
         Nothing -> error "no renamed info tcRnModule"
 
-      -- Compute the transitive set of linkables required
-      mods_transitive = go emptyUniqSet mods
-        where
-          go seen new
-            | isEmptyUniqSet new = seen
-            | otherwise = go seen' new'
-              where
-                seen' = seen `unionUniqSets` new
-                new'  = new_deps `minusUniqSet` seen'
-                new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info
-                                             | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]
-
-      -- The linkables we depend on at runtime are the transitive closure of 'mods'
-      -- restricted to the home package
-      -- See Note [Recompilation avoidance in the presence of TH]
-      mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported
-
       -- Serialize mod_env so we can read it from the interface
-      mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time))
+      mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
                          (moduleEnvToList mod_env)
       tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
   pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
@@ -380,36 +392,30 @@ mkHiFileResultNoCompile session tcm = do
 #else
   (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv
 #endif
-  let mod_info = HomeModInfo iface details Nothing
-  pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)
+  pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing
 
 mkHiFileResultCompile
     :: ShakeExtras
     -> HscEnv
     -> TcModuleResult
     -> ModGuts
-    -> LinkableType -- ^ use object code or byte code?
     -> IO (IdeResult HiFileResult)
-mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
+mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
   let session = hscSetFlags (ms_hspp_opts ms) session'
       ms = pm_mod_summary $ tmrParsed tcm
       tcGblEnv = tmrTypechecked tcm
 
-  let genLinkable = case ltype of
-        ObjectLinkable -> generateObjectCode
-        BCOLinkable    -> generateByteCode se WriteCoreFile
-
-  (linkable, details, mguts, diags) <-
+  (details, mguts) <-
     if mg_hsc_src simplified_guts == HsBootFile
     then do
-        -- give variables unique OccNames
         details <- mkBootModDetailsTc session tcGblEnv
-        pure (Nothing, details, Nothing, [])
+        pure (details, Nothing)
     else do
+        -- write core file
         -- give variables unique OccNames
         (guts, details) <- tidyProgram session simplified_guts
-        (diags, linkable) <- genLinkable session ms guts
-        pure (linkable, details, Just guts, diags)
+        pure (details, Just guts)
+
 #if MIN_VERSION_ghc(9,0,1)
   let !partial_iface = force (mkPartialIface session details simplified_guts)
   final_iface <- mkFullIface session partial_iface Nothing
@@ -419,53 +425,73 @@ mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
 #else
   (final_iface,_) <- mkIface session Nothing details simplified_guts
 #endif
-  let mod_info = HomeModInfo final_iface details linkable
+
+  -- Write the core file now
+  core_file <- case mguts of
+    Nothing -> pure Nothing -- no guts, likely boot file
+    Just guts -> do
+        let core_fp  = ml_core_file $ ms_location ms
+            core_file = codeGutsToCoreFile iface_hash guts
+            iface_hash = getModuleHash final_iface
+        core_hash1 <- atomicFileWrite se core_fp $ \fp ->
+          writeBinCoreFile fp core_file
+        -- We want to drop references to guts and read in a serialized, compact version
+        -- of the core file from disk (as it is deserialised lazily)
+        -- This is because we don't want to keep the guts in memeory for every file in
+        -- the project as it becomes prohibitively expensive
+        -- The serialized file however is much more compact and only requires a few
+        -- hundred megabytes of memory total even in a large project with 1000s of
+        -- modules
+        (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
+        pure $ assert (core_hash1 == core_hash2)
+             $ Just (core_file, fingerprintToBS core_hash2)
 
   -- Verify core file by rountrip testing and comparison
   IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se
-  when (maybe False (not . isObjectLinkable) linkable && optVerifyCoreFile) $ do
-    let core_fp = ml_core_file $ ms_location ms
-    traceIO $ "Verifying " ++ core_fp
-    core <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
-    let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
-          Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists)"
-          Just g -> g
-        mod = ms_mod ms
-        data_tycons = filter isDataTyCon tycons
-    CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
+  case core_file of
+    Just (core, _) | optVerifyCoreFile -> do
+      let core_fp = ml_core_file $ ms_location ms
+      traceIO $ "Verifying " ++ core_fp
+      let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
+            Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists"
+            Just g -> g
+          mod = ms_mod ms
+          data_tycons = filter isDataTyCon tycons
+      CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
 
-    -- Run corePrep first as we want to test the final version of the program that will
-    -- get translated to STG/Bytecode
-    (prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
-    (prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
-    let binds  = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
-        binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
+      -- Run corePrep first as we want to test the final version of the program that will
+      -- get translated to STG/Bytecode
+      (prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
+      (prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
+      let binds  = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
+          binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
 
-        -- diffBinds is unreliable, sometimes it goes down the wrong track.
-        -- This fixes the order of the bindings so that it is less likely to do so.
-        diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
-        -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
-        -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
+          -- diffBinds is unreliable, sometimes it goes down the wrong track.
+          -- This fixes the order of the bindings so that it is less likely to do so.
+          diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
+          -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
+          -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
 
-        diffs = diffs2
-        go x y = S.state $ \s -> diffBinds True s x y
+          diffs = diffs2
+          go x y = S.state $ \s -> diffBinds True s x y
 
-        -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
-        -- are used for generate core or bytecode, so we can safely ignore them
-        -- SYB is slow but fine given that this is only used for testing
-        noUnfoldings = everywhere $ mkT $ \v -> if isId v
-          then
-            let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
-              in setIdOccInfo v' noOccInfo
-          else v
-        isOtherUnfolding (OtherCon _) = True
-        isOtherUnfolding _ = False
+          -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
+          -- are used for generate core or bytecode, so we can safely ignore them
+          -- SYB is slow but fine given that this is only used for testing
+          noUnfoldings = everywhere $ mkT $ \v -> if isId v
+            then
+              let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
+                in setIdOccInfo v' noOccInfo
+            else v
+          isOtherUnfolding (OtherCon _) = True
+          isOtherUnfolding _ = False
 
 
-    when (not $ null diffs) $
-      panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))
+      when (not $ null diffs) $
+        panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))
+    _ -> pure ()
 
-  pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm))
+  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)
 
   where
     dflags = hsc_dflags session'
@@ -544,10 +570,10 @@ generateObjectCode session summary guts = do
 
               pure (map snd warnings, linkable)
 
-data WriteCoreFile = WriteCoreFile | CoreFileExists !UTCTime
+newtype CoreFileTime = CoreFileTime UTCTime
 
-generateByteCode :: ShakeExtras -> WriteCoreFile -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
-generateByteCode se write_core hscEnv summary guts = do
+generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
+generateByteCode (CoreFileTime time) hscEnv summary guts = do
     fmap (either (, Nothing) (second Just)) $
           catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do
               (warnings, (_, bytecode, sptEntries)) <-
@@ -562,16 +588,7 @@ generateByteCode se write_core hscEnv summary guts = do
                                 summary'
 #endif
               let unlinked = BCOs bytecode sptEntries
-              time <- case write_core of
-                CoreFileExists time -> pure time
-                WriteCoreFile -> liftIO $ do
-                  let core_fp = ml_core_file $ ms_location summary
-                      core_file = codeGutsToCoreFile guts
-                  atomicFileWrite se core_fp $ \fp ->
-                    writeBinCoreFile fp core_file
-                  getModificationTime core_fp
               let linkable = LM time (ms_mod summary) [unlinked]
-
               pure (map snd warnings, linkable)
 
 demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
@@ -653,12 +670,12 @@ addRelativeImport fp modu dflags = dflags
     {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
 
 -- | Also resets the interface store
-atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO ()
+atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
 atomicFileWrite se targetPath write = do
   let dir = takeDirectory targetPath
   createDirectoryIfMissing True dir
   (tempFilePath, cleanUp) <- newTempFileWithin dir
-  (write tempFilePath >> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)))
+  (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)
     `onException` cleanUp
 
 generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
@@ -681,12 +698,14 @@ generateHieAsts hscEnv tcm =
 #endif
   where
     dflags = hsc_dflags hscEnv
+#if MIN_VERSION_ghc(9,0,0)
     run ts =
 #if MIN_VERSION_ghc(9,2,0)
         fmap (join . snd) . liftIO . initDs hscEnv ts
 #else
         id
 #endif
+#endif
 
 spliceExpresions :: Splices -> [LHsExpr GhcTc]
 spliceExpresions Splices{..} =
@@ -851,7 +870,7 @@ writeHiFile se hscEnv tc =
     atomicFileWrite se targetPath $ \fp ->
       writeIfaceFile hscEnv fp modIface
   where
-    modIface = hm_iface $ hirHomeMod tc
+    modIface = hirModIface tc
     targetPath = ml_hi_file $ ms_location $ hirModSummary tc
     dflags = hsc_dflags hscEnv
 
@@ -1193,6 +1212,7 @@ data RecompilationInfo m
   { source_version :: FileVersion
   , old_value   :: Maybe (HiFileResult, FileVersion)
   , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)
+  , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]
   , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface
   }
 
@@ -1213,18 +1233,16 @@ ml_core_file ml = ml_hi_file ml <.> "core"
 -- See Note [Recompilation avoidance in the presence of TH]
 loadInterface
   :: (MonadIO m, MonadMask m)
-  => ShakeExtras
-  -> HscEnv
+  => HscEnv
   -> ModSummary
   -> Maybe LinkableType
   -> RecompilationInfo m
   -> m ([FileDiagnostic], Maybe HiFileResult)
-loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
+loadInterface session ms linkableNeeded RecompilationInfo{..} = do
     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session
-        mb_old_iface = hm_iface    . hirHomeMod . fst <$> old_value
+        mb_old_iface = hirModIface . fst <$> old_value
         mb_old_version = snd <$> old_value
 
-        obj_file = ml_obj_file (ms_location ms)
         core_file = ml_core_file (ms_location ms)
         iface_file = ml_hi_file (ms_location ms)
 
@@ -1232,14 +1250,10 @@ loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
 
     mb_dest_version <- case mb_old_version of
       Just ver -> pure $ Just ver
-      Nothing ->  do
-        let file = case linkableNeeded of
-              Just ObjectLinkable -> obj_file
-              Just BCOLinkable    -> core_file
-              Nothing             -> iface_file
-        get_file_version (toNormalizedFilePath' file)
+      Nothing -> get_file_version (toNormalizedFilePath' iface_file)
 
-    -- The source is modified if it is newer than the destination
+    -- The source is modified if it is newer than the destination (iface file)
+    -- A more precise check for the core file is performed later
     let sourceMod = case mb_dest_version of
           Nothing -> SourceModified -- desitination file doesn't exist, assume modified source
           Just dest_version
@@ -1247,135 +1261,89 @@ loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
             | otherwise -> SourceModified
 
     -- If mb_old_iface is nothing then checkOldIface will load it for us
+    -- given that the source is unmodified
     (recomp_iface_reqd, mb_checked_iface)
       <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface
 
-
-    (recomp_obj_reqd, mb_linkable) <- case linkableNeeded of
-      Nothing -> pure (UpToDate, Nothing)
-      Just linkableType -> case old_value of
-        -- We don't have an old result
-        Nothing -> recompMaybeBecause "missing"
-        -- We have an old result
-        Just (old_hir, old_file_version) ->
-          case hm_linkable $ hirHomeMod old_hir of
-            Nothing -> recompMaybeBecause "missing [not needed before]"
-            Just old_lb
-              | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used
-              , old_file_version /= source_version -> recompMaybeBecause "out of date"
-
-              -- Check if it is the correct type
-              -- Ideally we could use object-code in case we already have
-              -- it when we are generating bytecode, but this is difficult because something
-              -- below us may be bytecode, and object code can't depend on bytecode
-              | ObjectLinkable <- linkableType, isObjectLinkable old_lb
-              -> pure (UpToDate, Just $ GhcLinkable old_lb)
-
-              | BCOLinkable    <- linkableType , not (isObjectLinkable old_lb)
-              -> pure (UpToDate, Just $ GhcLinkable old_lb)
-
-              | otherwise -> recompMaybeBecause "missing [wrong type]"
-        where
-          recompMaybeBecause msg =
-            case mb_dest_version of -- The destination file should be the object code or the core file
-              Nothing -> pure (RecompBecause msg', Nothing)
-              Just disk_obj_version@(ModificationTime t) ->
-                if (disk_obj_version >= source_version)
-                then case linkableType of
-                  ObjectLinkable -> pure (UpToDate, Just $ GhcLinkable $ LM (posixSecondsToUTCTime t) mod [DotO obj_file])
-                  BCOLinkable -> liftIO $ do
-                    core <- readBinCoreFile (mkUpdater $ hsc_NC session)  core_file
-                    pure (UpToDate, Just $ CoreLinkable (posixSecondsToUTCTime t) core)
-                else pure (RecompBecause msg', Nothing)
-              Just (VFSVersion _) -> pure (RecompBecause msg', Nothing)
-           where
-             msg' = case linkableType of
-               BCOLinkable -> "bytecode " ++ msg
-               ObjectLinkable -> "Object code " ++ msg
-
     let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do
           setTag "Module" $ moduleNameString $ moduleName mod
           setTag "Reason" $ showReason _reason
           liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)
           regenerate linkableNeeded
 
-    case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of
+    case (mb_checked_iface, recomp_iface_reqd) of
       (Just iface, UpToDate) -> do
-         -- Force it because we don't want to retain old modsummaries or linkables
-         lb <- liftIO $ evaluate $ force mb_linkable
-
          -- If we have an old value, just return it
          case old_value of
            Just (old_hir, _)
-             | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir)
-             -> do_regenerate msg
-             | otherwise -> return ([], Just old_hir)
-           Nothing -> do
-             (warns, hmi) <- liftIO $ mkDetailsFromIface se sessionWithMsDynFlags ms iface lb
+             | if isJust linkableNeeded then isJust (hirCoreFp old_hir) else True
+             -> do
+             -- Peform the fine grained recompilation check for TH
+             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir)
+             case maybe_recomp of
+               Just msg -> do_regenerate msg
+               Nothing -> return ([], Just old_hir)
+           -- Otherwise use the value from disk, provided the core file is up to date if required
+           _ -> do
+             details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface
              -- parse the runtime dependencies from the annotations
              let runtime_deps
                    | not (mi_used_th iface) = emptyModuleEnv
-                   | otherwise = parseRuntimeDeps (md_anns (hm_details hmi))
-             return (warns, Just $ mkHiFileResult ms hmi runtime_deps)
+                   | otherwise = parseRuntimeDeps (md_anns details)
+             -- Peform the fine grained recompilation check for TH
+             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
+             case maybe_recomp of
+               Just msg -> do_regenerate msg
+               Nothing
+                 | isJust linkableNeeded -> do
+                   (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ readBinCoreFile (mkUpdater $ hsc_NC session) core_file
+                   if cf_iface_hash == getModuleHash iface
+                   then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash)))
+                   else do_regenerate (RecompBecause "Core file out of date (doesn't match iface hash)")
+                 | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)
       (_, _reason) -> do_regenerate _reason
 
--- | ModDepTime is stored as an annotation in the iface to
--- keep track of runtime dependencies
-newtype ModDepTime = ModDepTime UTCTime
-
-deserializeModDepTime :: [Word8] -> ModDepTime
-deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of
-  (a,b) -> UTCTime (toEnum a) (toEnum b)
-
-serializeModDepTime :: ModDepTime -> [Word8]
-serializeModDepTime (ModDepTime l) = LBS.unpack $
-  B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)
-
 -- | Find the runtime dependencies by looking at the annotations
 -- serialized in the iface
-parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime
+parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString
 parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
   where
     go (Annotation (ModuleTarget mod) payload)
-      | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload
-      = Just (mod, t)
+      | Just bs <- fromSerialized BS.pack payload
+      = Just (mod, bs)
     go _ = Nothing
 
--- | checkLinkableDependencies compares the linkables in the home package to
+-- | checkLinkableDependencies compares the core files in the shake store to
 -- the runtime dependencies of the module, to check if any of them are out of date
 -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
 -- See Note [Recompilation avoidance in the presence of TH]
-checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired
-checkLinkableDependencies hpt runtime_deps
-  | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile
-  | otherwise = Just $
-      RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date))
-  where
-    out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of
-                                                  Nothing -> False
-                                                  Just hm -> case hm_linkable hm of
-                                                    Nothing -> False
-                                                    Just lm -> linkableTime lm /= time)
-                                  runtime_deps
+checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
+checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
+  let hs_files = mapM go (moduleEnvToList runtime_deps)
+      go (mod, hash) = do
+        ms <- mgLookupModule graph mod
+        let hs = fromJust $ ml_hs_file $ ms_location ms
+        pure (toNormalizedFilePath' hs, hash)
+  case hs_files of
+    Nothing -> error "invalid module graph"
+    Just fs -> do
+      store_hashes <- get_linkable_hashes (map fst fs)
+      let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]
+      case out_of_date of
+        [] -> pure Nothing
+        _ -> pure $ Just $
+          RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)
 
 showReason :: RecompileRequired -> String
 showReason UpToDate          = "UpToDate"
 showReason MustCompile       = "MustCompile"
 showReason (RecompBecause s) = s
 
-mkDetailsFromIface :: ShakeExtras -> HscEnv -> ModSummary -> ModIface -> Maybe IdeLinkable -> IO ([FileDiagnostic], HomeModInfo)
-mkDetailsFromIface se session ms iface ide_linkable = do
-  details <- liftIO $ fixIO $ \details -> do
+mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
+mkDetailsFromIface session iface = do
+  fixIO $ \details -> do
     let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details Nothing) }
     initIfaceLoad hsc' (typecheckIface iface)
-  (warns, linkable) <- liftIO $ case ide_linkable of
-    Nothing -> pure ([], Nothing)
-    Just (GhcLinkable lb) -> pure ([], Just lb)
-    Just (CoreLinkable t core_file) -> do
-      cgi_guts <- coreFileToCgGuts session iface details core_file
-      generateByteCode se (CoreFileExists t) session ms cgi_guts
-
-  return (warns, HomeModInfo iface details linkable)
 
 coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
 coreFileToCgGuts session iface details core_file = do
@@ -1392,6 +1360,24 @@ coreFileToCgGuts session iface details core_file = do
       tyCons = typeEnvTyCons (md_types details)
   pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
 
+coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)
+coreFileToLinkable linkableType session ms iface details core_file t = do
+  let act hpt = addToHpt hpt (moduleName this_mod)
+                             (HomeModInfo iface details Nothing)
+      this_mod = mi_module iface
+  types_var <- newIORef (md_types details)
+  let kv = Just (this_mod, types_var)
+      hsc_env' = session { hsc_HPT = act (hsc_HPT session)
+                         , hsc_type_env_var = kv }
+  core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file
+  let implicit_binds = concatMap getImplicitBinds tyCons
+      tyCons = typeEnvTyCons (md_types details)
+  let cgi_guts = CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
+  (warns, lb) <- case linkableType of
+    BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts
+    ObjectLinkable -> generateObjectCode session ms cgi_guts
+  pure (warns, HomeModInfo iface details . Just <$> lb)
+
 -- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
 --   The interactive paths create problems in ghc-lib builds
 --- and leads to fun errors like "Cannot continue after interface file error".

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -35,9 +35,7 @@ import           GHC.Generics                                 (Generic)
 
 import qualified Data.Binary                                  as B
 import           Data.ByteString                              (ByteString)
-import qualified Data.ByteString.Lazy                         as LBS
 import           Data.Text                                    (Text)
-import           Data.Time
 import           Development.IDE.Import.FindImports           (ArtifactsLocation)
 import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
@@ -45,6 +43,8 @@ import           Development.IDE.Types.Diagnostics
 import           GHC.Serialized                               (Serialized)
 import           Language.LSP.Types                           (Int32,
                                                                NormalizedFilePath)
+import           Development.IDE.GHC.CoreFile
+import           Control.Exception                            (assert)
 
 data LinkableType = ObjectLinkable | BCOLinkable
   deriving (Eq,Ord,Show, Generic)
@@ -91,6 +91,26 @@ data GenerateCore = GenerateCore
 instance Hashable GenerateCore
 instance NFData   GenerateCore
 
+type instance RuleResult GetLinkable = LinkableResult
+
+data LinkableResult
+  = LinkableResult
+  { linkableHomeMod :: !HomeModInfo
+  , linkableHash    :: !ByteString
+  -- ^ The hash of the core file
+  }
+
+instance Show LinkableResult where
+    show = show . mi_module . hm_iface . linkableHomeMod
+
+instance NFData LinkableResult where
+    rnf = rwhnf
+
+data GetLinkable = GetLinkable
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetLinkable
+instance NFData   GetLinkable
+
 data GetImportMap = GetImportMap
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetImportMap
@@ -138,9 +158,10 @@ data TcModuleResult = TcModuleResult
     -- ^ Typechecked splice information
     , tmrDeferedError    :: !Bool
     -- ^ Did we defer any type errors for this module?
-    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)
+    , tmrRuntimeModules  :: !(ModuleEnv ByteString)
         -- ^ Which modules did we need at runtime while compiling this file?
         -- Used for recompilation checking in the presence of TH
+        -- Stores the hash of their core file
     }
 instance Show TcModuleResult where
     show = show . pm_mod_summary . tmrParsed
@@ -155,30 +176,29 @@ data HiFileResult = HiFileResult
     { hirModSummary :: !ModSummary
     -- Bang patterns here are important to stop the result retaining
     -- a reference to a typechecked module
-    , hirHomeMod    :: !HomeModInfo
-    -- ^ Includes the Linkable iff we need object files
-    , hirIfaceFp    :: ByteString
+    , hirModIface   :: !ModIface
+    , hirModDetails :: ModDetails
+    -- ^ Populated lazily
+    , hirIfaceFp    :: !ByteString
     -- ^ Fingerprint for the ModIface
-    , hirLinkableFp :: ByteString
-    -- ^ Fingerprint for the Linkable
-    , hirRuntimeModules :: !(ModuleEnv UTCTime)
+    , hirRuntimeModules :: !(ModuleEnv ByteString)
     -- ^ same as tmrRuntimeModules
+    , hirCoreFp     :: !(Maybe (CoreFile, ByteString))
+    -- ^ If we wrote a core file for this module, then its contents (lazily deserialised)
+    -- along with its hash
     }
 
 hiFileFingerPrint :: HiFileResult -> ByteString
-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp
+hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp
 
-mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
-mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}
+mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult
+mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =
+    assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _)
+                                -> getModuleHash hirModIface == cf_iface_hash
+                              _ -> True)
+    HiFileResult{..}
   where
-    hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes
-    hirLinkableFp = case hm_linkable hirHomeMod of
-      Nothing -> ""
-      Just (linkableTime -> l)  -> LBS.toStrict $
-        B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)
-
-hirModIface :: HiFileResult -> ModIface
-hirModIface = hm_iface . hirHomeMod
+    hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes
 
 instance NFData HiFileResult where
     rnf = rwhnf

ghcide/src/Development/IDE/Core/Rules.hs

@@ -99,7 +99,7 @@ import           Data.Tuple.Extra
 import           Development.IDE.Core.Compile
 import           Development.IDE.Core.FileExists hiding (LogShake, Log)
 import           Development.IDE.Core.FileStore               (getFileContents,
-                                                               resetInterfaceStore)
+                                                               getModTime)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest hiding (LogShake, Log)
 import           Development.IDE.Core.PositionMapping
@@ -135,7 +135,7 @@ import           Ide.Plugin.Config
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types                           (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo))
 import           Language.LSP.VFS
-import           System.Directory                             (makeAbsolute)
+import           System.Directory                             (makeAbsolute, doesFileExist)
 import           Data.Default                                 (def, Default)
 import           Ide.Plugin.Properties                        (HasProperty,
                                                                KeyNameProxy,
@@ -154,6 +154,9 @@ import qualified Development.IDE.Core.Shake as Shake
 import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)
 import qualified Development.IDE.Types.Logger as Logger
 import qualified Development.IDE.Types.Shake as Shake
+import           Development.IDE.GHC.CoreFile
+import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Control.Monad.IO.Unlift
 
 data Log
   = LogShake Shake.Log
@@ -673,9 +676,13 @@ typeCheckRuleDefinition hsc pm = do
   setPriority priorityTypeCheck
   IdeOptions { optDefer = defer } <- getIdeOptions
 
-  linkables_to_keep <- currentLinkables
+  unlift <- askUnliftIO
+  let dets = TypecheckHelpers
+           { getLinkablesToKeep = unliftIO unlift $ currentLinkables
+           , getLinkables = unliftIO unlift . uses_ GetLinkable
+           }
   addUsageDependencies $ liftIO $
-    typecheckModule defer hsc linkables_to_keep pm
+    typecheckModule defer hsc dets pm
   where
     addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
     addUsageDependencies a = do
@@ -752,7 +759,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
             ifaces <- uses_ GetModIface deps
 
-            let inLoadOrder = map hirHomeMod ifaces
+            let            inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
             session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
 
             Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
@@ -768,7 +775,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
     Just session -> do
       linkableType <- getLinkableType f
       ver <- use_ GetModificationTime f
-      se@ShakeExtras{ideNc} <- getShakeExtras
+      ShakeExtras{ideNc} <- getShakeExtras
       let m_old = case old of
             Shake.Succeeded (Just old_version) v -> Just (v, old_version)
             Shake.Stale _   (Just old_version) v -> Just (v, old_version)
@@ -777,9 +784,10 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
+            , get_linkable_hashes = \fs -> map linkableHash <$> uses_ GetLinkable fs
             , regenerate = regenerateHiFile session f ms
             }
-      r <- loadInterface se (hscEnv session) ms linkableType recompInfo
+      r <- loadInterface (hscEnv session) ms linkableType recompInfo
       case r of
         (diags, Nothing) -> return (Nothing, (diags, Nothing))
         (diags, Just x) -> do
@@ -899,7 +907,7 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       hsc <- hscEnv <$> use_ GhcSessionDeps f
       let compile = fmap ([],) $ use GenerateCore f
       se <- getShakeExtras
-      (diags, !hiFile) <- compileToObjCodeIfNeeded se hsc linkableType compile tmr
+      (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr
       let fp = hiFileFingerPrint <$> hiFile
       hiDiags <- case hiFile of
         Just hiFile
@@ -912,10 +920,6 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       let fp = hiFileFingerPrint <$> hiFile
       return (fp, ([], hiFile))
 
-  -- Record the linkable so we know not to unload it
-  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do
-      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-      liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
   pure res
 
 -- | Count of total times we asked GHC to recompile
@@ -960,13 +964,12 @@ regenerateHiFile sess f ms compNeeded = do
               Nothing -> pure (diags', Nothing)
               Just tmr -> do
 
-                -- compile writes .o file
                 let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
 
                 se <- getShakeExtras
 
                 -- Bang pattern is important to avoid leaking 'tmr'
-                (diags'', !res) <- compileToObjCodeIfNeeded se hsc compNeeded compile tmr
+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr
 
                 -- Write hi file
                 hiDiags <- case res of
@@ -994,18 +997,20 @@ regenerateHiFile sess f ms compNeeded = do
 
 
 -- | HscEnv should have deps included already
-compileToObjCodeIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
-compileToObjCodeIfNeeded _ hsc Nothing _ tmr = do
+-- This writes the core file if a linkable is required
+-- The actual linkable will be generated on demand when required by `GetLinkable`
+writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
+writeCoreFileIfNeeded _ hsc Nothing _ tmr = do
   incrementRebuildCount
   res <- liftIO $ mkHiFileResultNoCompile hsc tmr
   pure ([], Just $! res)
-compileToObjCodeIfNeeded se hsc (Just linkableType) getGuts tmr = do
+writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do
   incrementRebuildCount
   (diags, mguts) <- getGuts
   case mguts of
     Nothing -> pure (diags, Nothing)
     Just guts -> do
-      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts linkableType
+      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts
       pure (diags++diags', res)
 
 getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
@@ -1037,6 +1042,48 @@ usePropertyAction kn plId p = do
 
 -- ---------------------------------------------------------------------
 
+getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
+getLinkableRule recorder =
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do
+    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f
+    HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f
+    let obj_file  = ml_obj_file (ms_location ms)
+        core_file = ml_core_file (ms_location ms)
+    -- Can't use `GetModificationTime` rule because the core file was possibly written in this
+    -- very session, so the results aren't reliable
+    core_t <- liftIO $ getModTime core_file
+    case hirCoreFp of
+      Nothing -> error "called GetLinkable for a file without a linkable"
+      Just (bin_core, hash) -> do
+        session <- use_ GhcSessionDeps f
+        ShakeExtras{ideNc} <- getShakeExtras
+        let namecache_updater = mkUpdater ideNc
+        linkableType <- getLinkableType f >>= \case
+          Nothing -> error "called GetLinkable for a file which doesn't need compilation"
+          Just t -> pure t
+        (warns, hmi) <- case linkableType of
+          -- Bytecode needs to be regenerated from the core file
+          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)
+          -- Object code can be read from the disk
+          ObjectLinkable -> do
+            -- object file is up to date if it is newer than the core file
+            -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and
+            -- thus bump its modification time, forcing this rule to be rerun every time.
+            exists <- liftIO $ doesFileExist obj_file
+            mobj_time <- liftIO $
+              if exists
+              then Just <$> getModTime obj_file
+              else pure Nothing
+            case mobj_time of
+              Just obj_t
+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))
+              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")
+        -- Record the linkable so we know not to unload it
+        whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do
+            compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
+            liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
+        return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash))
+
 -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
 getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
 getLinkableType f = use_ NeedsCompilation f
@@ -1069,7 +1116,6 @@ needsCompilationRule file = do
             (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)
                 (uses NeedsCompilation revdeps)
         pure $ computeLinkableType ms modsums (map join needsComps)
-
   pure (Just $ encodeLinkableType res, Just res)
   where
     computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
@@ -1170,3 +1216,4 @@ mainRule recorder RulesConfig{..} = do
     persistentHieFileRule recorder
     persistentDocMapRule
     persistentImportMapRule
+    getLinkableRule recorder

ghcide/src/Development/IDE/GHC/CoreFile.hs

@@ -5,13 +5,14 @@
 -- | CoreFiles let us serialize Core to a file in order to later recover it
 -- without reparsing or retypechecking
 module Development.IDE.GHC.CoreFile
-  ( CoreFile
+  ( CoreFile(..)
   , codeGutsToCoreFile
   , typecheckCoreFile
   , readBinCoreFile
   , writeBinCoreFile
   , getImplicitBinds) where
 
+import GHC.Fingerprint
 import Data.IORef
 import Data.Foldable
 import Data.List (isPrefixOf)
@@ -29,6 +30,7 @@ import GHC.IfaceToCore
 import GHC.Iface.Env
 import GHC.Iface.Binary
 import GHC.Types.Id.Make
+import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
 
 #if MIN_VERSION_ghc(9,2,0)
 import GHC.Types.TypeEnv
@@ -48,13 +50,21 @@ import IdInfo
 import Var
 import Unique
 import MkId
+import BinFingerprint ( fingerprintBinMem )
 #endif
 
+import qualified Development.IDE.GHC.Compat.Util as Util
+
 -- | Initial ram buffer to allocate for writing interface files
 initBinMemSize :: Int
 initBinMemSize = 1024 * 1024
 
-newtype CoreFile = CoreFile { cf_bindings :: [TopIfaceBinding IfaceId] }
+data CoreFile
+  = CoreFile
+  { cf_bindings :: [TopIfaceBinding IfaceId]
+  -- ^ The actual core file bindings, deserialized lazily
+  , cf_iface_hash :: !Fingerprint
+  }
 
 -- | Like IfaceBinding, but lets us serialize internal names as well
 data TopIfaceBinding v
@@ -84,19 +94,21 @@ instance Binary (TopIfaceBinding IfaceId) where
       _ -> error "Binary TopIfaceBinding"
 
 instance Binary CoreFile where
-  put_ bh (CoreFile a) = put_ bh a
-  get bh = CoreFile <$> get bh
+  put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp
+  get bh = CoreFile <$> lazyGet bh <*> get bh
 
 readBinCoreFile
   :: NameCacheUpdater
   -> FilePath
-  -> IO CoreFile
+  -> IO (CoreFile, Fingerprint)
 readBinCoreFile name_cache fat_hi_path = do
     bh <- readBinMem fat_hi_path
-    getWithUserData name_cache bh
+    file <- getWithUserData name_cache bh
+    !fp <- Util.getFileHash fat_hi_path
+    return (file, fp)
 
 -- | Write a core file
-writeBinCoreFile :: FilePath -> CoreFile -> IO ()
+writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint
 writeBinCoreFile core_path fat_iface = do
     bh <- openBinMem initBinMemSize
 
@@ -112,11 +124,17 @@ writeBinCoreFile core_path fat_iface = do
     -- And send the result to the file
     writeBinMem bh core_path
 
+    !fp <- fingerprintBinMem bh
+    pure fp
+
 -- Implicit binds aren't tidied, so we can't serialise them.
 -- This isn't a problem however since we can regenerate them from the
 -- original ModIface
-codeGutsToCoreFile :: CgGuts -> CoreFile
-codeGutsToCoreFile CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds)
+codeGutsToCoreFile
+  :: Fingerprint -- ^ Hash of the interface this was generated from
+  -> CgGuts
+  -> CoreFile
+codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash
 
 -- | Implicit binds can be generated from the interface and are not tidied,
 -- so we must filter them out
@@ -157,7 +175,7 @@ toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIface
 toIfaceTopBind mod (Rec prs)    = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs]
 
 typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
-typecheckCoreFile this_mod type_var (CoreFile prepd_binding) =
+typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =
   initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do
     tcTopIfaceBindings type_var prepd_binding
 

ghcide/src/Development/IDE/GHC/Orphans.hs

@@ -210,3 +210,8 @@ instance (NFData (HsModule a)) where
 
 instance Show OccName where show = unpack . printOutputable
 instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)
+
+instance Show HomeModInfo where show = show . mi_module . hm_iface
+
+instance NFData HomeModInfo where
+  rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link

hls-graph/hls-graph.cabal

@@ -81,6 +81,7 @@ library
     , stm-containers
     , time
     , transformers
+    , unliftio
     , unordered-containers
 
   if flag(embed-files)

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -38,6 +38,7 @@ import qualified StmContainers.Map             as SMap
 import           System.Time.Extra             (Seconds)
 import qualified Data.HashSet as Set
 import Data.List (intercalate)
+import UnliftIO (MonadUnliftIO)
 
 
 unwrapDynamic :: forall a . Typeable a => Dynamic -> a
@@ -64,7 +65,7 @@ data SRules = SRules {
 -- ACTIONS
 
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
-    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
+    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
 
 data SAction = SAction {
     actionDatabase :: !Database,

plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs

@@ -458,9 +458,9 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
             let fs = occNameFS n
         ]
     fixFixities f pm = do
-      HiFileResult {hirHomeMod} <-
+      HiFileResult {hirModIface} <-
         useOrFail "GetModIface" NoTypeCheck GetModIface f
-      let fixities = fixityEnvFromModIface $ hm_iface hirHomeMod
+      let fixities = fixityEnvFromModIface hirModIface
       res <- transformA pm (fix fixities)
       return (fixities, res)
     fixAnns ParsedModule {..} =