Cache a ghc session per file of interest

src/Development/IDE/Core/Compile.hs

@@ -24,6 +24,7 @@ module Development.IDE.Core.Compile
   , loadInterface
   , loadDepModule
   , loadModuleHome
+  , setupFinderCache
   ) where
 
 import Development.IDE.Core.RuleTypes
@@ -116,24 +117,16 @@ computePackageDeps env pkg = do
 
 typecheckModule :: IdeDefer
                 -> HscEnv
-                -> [(ModSummary, (ModIface, Maybe Linkable))]
                 -> ParsedModule
                 -> IO (IdeResult (HscEnv, TcModuleResult))
-typecheckModule (IdeDefer defer) hsc depsIn pm = do
+typecheckModule (IdeDefer defer) hsc pm = do
     fmap (either (, Nothing) (second Just . sequence) . sequence) $
       runGhcEnv hsc $
       catchSrcErrors "typecheck" $ do
-        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
-        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
-        -- Long-term we might just want to change the order returned by GetDependencies
-        let deps = reverse depsIn
-
-        setupFinderCache (map fst deps)
 
         let modSummary = pm_mod_summary pm
             dflags = ms_hspp_opts modSummary
 
-        mapM_ (uncurry loadDepModule . snd) deps
         modSummary' <- initPlugins modSummary
         (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
             GHC.typecheckModule $ enableTopLevelWarnings
@@ -481,7 +474,8 @@ getModSummaryFromImports fp contents = do
         -- To avoid silent issues where something is not processed because the date
         -- has not changed, we make sure that things blow up if they depend on the date.
                 , ms_hsc_src      = sourceType
-                , ms_hspp_buf     = Nothing
+                -- The contents are used by the GetModSummary rule
+                , ms_hspp_buf     = Just contents
                 , ms_hspp_file    = fp
                 , ms_hspp_opts    = dflags
                 , ms_iface_date   = Nothing

src/Development/IDE/Core/RuleTypes.hs

@@ -88,6 +88,9 @@ type instance RuleResult GenerateByteCode = Linkable
 -- | A GHC session that we reuse.
 type instance RuleResult GhcSession = HscEnvEq
 
+-- | A GHC session preloaded with all the dependencies
+type instance RuleResult GhcSessionDeps = HscEnvEq
+
 -- | Resolve the imports in a module to the file path of a module
 -- in the same package or the package id of another package.
 type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
@@ -170,6 +173,11 @@ instance Hashable GhcSession
 instance NFData   GhcSession
 instance Binary   GhcSession
 
+data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic)
+instance Hashable GhcSessionDeps
+instance NFData   GhcSessionDeps
+instance Binary   GhcSessionDeps
+
 data GetModIfaceFromDisk = GetModIfaceFromDisk
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetModIfaceFromDisk

src/Development/IDE/Core/Rules.hs

@@ -78,6 +78,8 @@ import Control.Concurrent.Async (concurrently)
 import Control.Monad.State
 import System.IO.Error (isDoesNotExistError)
 import Control.Exception.Safe (IOException, catch)
+import FastString (FastString(uniq))
+import qualified HeaderInfo as Hdr
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -443,30 +445,30 @@ getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
         packageState <- hscEnv <$> use_ GhcSession file
-        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
-        let tdeps = transitiveModuleDeps deps
 
 -- When possible, rely on the haddocks embedded in our interface files
 -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
 #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
         let parsedDeps = []
 #else
+        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
+        let tdeps = transitiveModuleDeps deps
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps
 #endif
 
-        ifaces <- mapMaybe (fmap fst) <$> usesWithStale GetModIface tdeps
         (fileImports, _) <- use_ GetLocatedImports file
         let imports = second (fmap artifactFilePath) <$> fileImports
-        x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
+        x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
         return ([], Just x)
 
 -- Typechecks a module.
 typeCheckRule :: Rules ()
 typeCheckRule = define $ \TypeCheck file -> do
     pm <- use_ GetParsedModule file
+    hsc  <- hscEnv <$> use_ GhcSessionDeps file
     -- do not generate interface files as this rule is called
     -- for files of interest on every keystroke
-    typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles
+    typeCheckRuleDefinition hsc pm SkipGenerationOfInterfaceFiles
 
 data GenerateInterfaceFiles
     = DoGenerateInterfaceFiles
@@ -478,29 +480,16 @@ data GenerateInterfaceFiles
 -- garbage collect all the intermediate typechecked modules rather than
 -- retain the information forever in the shake graph.
 typeCheckRuleDefinition
-    :: NormalizedFilePath     -- ^ Path to source file
+    :: HscEnv
     -> ParsedModule
     -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?
     -> Action (IdeResult TcModuleResult)
-typeCheckRuleDefinition file pm generateArtifacts = do
-  deps <- use_ GetDependencies file
-  hsc  <- hscEnv <$> use_ GhcSession file
-  -- Figure out whether we need TemplateHaskell or QuasiQuotes support
-  let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
-      file_uses_th_qq   = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
-      any_uses_th_qq    = graph_needs_th_qq || file_uses_th_qq
-  mirs      <- uses_ GetModIface (transitiveModuleDeps deps)
-  bytecodes <- if any_uses_th_qq
-    then -- If we use TH or QQ, we must obtain the bytecode
-      fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
-    else
-      pure $ repeat Nothing
-
+typeCheckRuleDefinition hsc pm generateArtifacts = do
   setPriority priorityTypeCheck
   IdeOptions { optDefer = defer } <- getIdeOptions
 
   addUsageDependencies $ liftIO $ do
-    res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm
+    res <- typecheckModule defer hsc pm
     case res of
       (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do
         diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
@@ -509,10 +498,6 @@ typeCheckRuleDefinition file pm generateArtifacts = do
       (diags, res) ->
         return (diags, snd <$> res)
  where
-  unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
-  uses_th_qq dflags =
-    xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
-
   addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
   addUsageDependencies a = do
     r@(_, mtc) <- a
@@ -588,6 +573,43 @@ loadGhcSession = do
                 Nothing -> BS.pack (show (hash (snd val)))
         return (Just cutoffHash, val)
 
+    define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file
+
+ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
+ghcSessionDepsDefinition file = do
+        hsc <- hscEnv <$> use_ GhcSession file
+        (ms,_) <- useWithStale_ GetModSummary file
+        (deps,_) <- useWithStale_ GetDependencies file
+        let tdeps = transitiveModuleDeps deps
+        ifaces <- uses_ GetModIface tdeps
+
+        -- Figure out whether we need TemplateHaskell or QuasiQuotes support
+        let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
+            file_uses_th_qq   = uses_th_qq $ ms_hspp_opts ms
+            any_uses_th_qq    = graph_needs_th_qq || file_uses_th_qq
+
+        bytecodes <- if any_uses_th_qq
+            then -- If we use TH or QQ, we must obtain the bytecode
+            fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
+            else
+            pure $ repeat Nothing
+
+        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
+        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
+        -- Long-term we might just want to change the order returned by GetDependencies
+        let inLoadOrder = reverse (zipWith unpack ifaces bytecodes)
+
+        (session',_) <- liftIO $ runGhcEnv hsc $ do
+            setupFinderCache (map hirModSummary ifaces)
+            mapM_ (uncurry loadDepModule) inLoadOrder
+
+        res <- liftIO $ newHscEnvEq session' []
+        return ([], Just res)
+ where
+  unpack HiFileResult{..} bc = (hirModIface, bc)
+  uses_th_qq dflags =
+    xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
+
 getModIfaceFromDiskRule :: Rules ()
 getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
   -- get all dependencies interface files, to check for freshness
@@ -623,12 +645,33 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
               pure (Nothing, ([], Nothing))
 
 getModSummaryRule :: Rules ()
-getModSummaryRule = define $ \GetModSummary f -> do
+getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
     dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
     (_, mFileContent) <- getFileContents f
     modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
         getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
-    return $ either (,Nothing) (([], ) . Just) modS
+    case modS of
+        Right ms -> do
+            -- Clear the contents as no longer needed
+            let !ms' = ms{ms_hspp_buf=Nothing}
+            return ( Just (computeFingerprint f dflags ms), ([], Just ms'))
+        Left diags -> return (Nothing, (diags, Nothing))
+    where
+        -- Compute a fingerprint from the contents of `ModSummary`,
+        -- eliding the timestamps and other non relevant fields.
+        computeFingerprint f dflags ModSummary{..} =
+            let fingerPrint =
+                    ( moduleNameString (moduleName ms_mod)
+                    , ms_hspp_file
+                    , map unLoc opts
+                    , ml_hs_file ms_location
+                    , fingerPrintImports ms_srcimps
+                    , fingerPrintImports ms_textual_imps
+                    )
+                fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))
+                opts = Hdr.getOptions dflags (fromJust ms_hspp_buf) (fromNormalizedFilePath f)
+                fp = hash fingerPrint
+            in BS.pack (show fp)
 
 getModIfaceRule :: Rules ()
 getModIfaceRule = define $ \GetModIface f -> do
@@ -667,10 +710,16 @@ getModIfaceRule = define $ \GetModIface f -> do
             case mb_pm of
                 Nothing -> return (diags, Nothing)
                 Just pm -> do
-                    (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
-                    -- Bang pattern is important to avoid leaking 'tmr'
-                    let !res = extract tmr
-                    return (diags <> diags', res)
+                    -- We want GhcSessionDeps cache objects only for files of interest
+                    -- As that's no the case here, call the implementation directly
+                    (diags, mb_hsc) <- ghcSessionDepsDefinition f
+                    case mb_hsc of
+                        Nothing -> return (diags, Nothing)
+                        Just hsc -> do
+                            (diags', tmr) <- typeCheckRuleDefinition (hscEnv hsc) pm DoGenerateInterfaceFiles
+                            -- Bang pattern is important to avoid leaking 'tmr'
+                            let !res = extract tmr
+                            return (diags <> diags', res)
     where
       extract Nothing = Nothing
       extract (Just tmr) =

src/Development/IDE/Core/Shake.hs

@@ -28,8 +28,10 @@ module Development.IDE.Core.Shake(
     shakeRestart,
     shakeEnqueue,
     shakeProfile,
-    use, useWithStale, useNoFile, uses, usesWithStale,
+    use, useNoFile, uses,
     use_, useNoFile_, uses_,
+    useWithStale, usesWithStale,
+    useWithStale_, usesWithStale_,
     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
     getDiagnostics, unsafeClearDiagnostics,
     getHiddenDiagnostics,
@@ -556,6 +558,17 @@ useWithStale :: IdeRule k v
     => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
 useWithStale key file = head <$> usesWithStale key [file]
 
+useWithStale_ :: IdeRule k v
+    => k -> NormalizedFilePath -> Action (v, PositionMapping)
+useWithStale_ key file = head <$> usesWithStale_ key [file]
+
+usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
+usesWithStale_ key files = do
+    res <- usesWithStale key files
+    case sequence res of
+        Nothing -> liftIO $ throwIO $ BadDependency (show key)
+        Just v -> return v
+
 useNoFile :: IdeRule k v => k -> Action (Maybe v)
 useNoFile key = use key emptyFilePath
 

src/Development/IDE/Spans/Calculate.hs

@@ -52,21 +52,19 @@ getSrcSpanInfos
     :: HscEnv
     -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
     -> TcModuleResult
-    -> [ParsedModule]   -- ^ Dependencies parsed, optional
-    -> [ModIface]       -- ^ Dependencies module interfaces, required
+    -> [ParsedModule]   -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs
     -> IO SpansInfo
-getSrcSpanInfos env imports tc parsedDeps deps =
+getSrcSpanInfos env imports tc parsedDeps =
     evalGhcEnv env $
-        getSpanInfo imports (tmrModule tc) parsedDeps deps
+        getSpanInfo imports (tmrModule tc) parsedDeps
 
 -- | Get ALL source spans in the module.
 getSpanInfo :: GhcMonad m
             => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
             -> TypecheckedModule
             -> [ParsedModule]
-            -> [ModIface]
             -> m SpansInfo
-getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps =
   do let tcs = tm_typechecked_source
          bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]
          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
@@ -75,8 +73,7 @@ getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
          allModules = tm_parsed_module : parsedDeps
          funBinds = funBindMap tm_parsed_module
 
-     -- Load all modules in HPT to make their interface documentation available
-     mapM_ (`loadDepModule` Nothing) (reverse deps)
+     -- Load this module in HPT to make its interface documentation available
      forM_ (modInfoIface tm_checked_module_info) $ \modIface ->
        modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)