Share ModuleGraphs for all files (#3232)

* Remove GetDependencyInformation in favour of GetModuleGraph.

Computing and storing GetDependencyInformation for each file essentially individually means
that we perform downsweep on each file individually, wasting a lot of work and using an excessive
amount of memory to store all these duplicated graphs individually.

However, we already have the `GetModuleGraph` rule, which we need to compute before compiling
files any way due to being depended on by `NeedsCompilation`, which needs to know if any reverse
dependencies of the module we are compiling requires TH, which meant that each file already depends on
the results of downsweep for the whole project.

Instead, we can compute the whole graph once when we execute the `GetModuleGraph` rule and even use this inside `HscEnv.hsc_mod_graph` to avoid reconstructing the `ModuleGraph` on each invocation of `GhcSessionDeps`.

There may be concerns about excessive build churn due to any change to the result of `GetModuleGraph`
invalidating the result of `GhcSessionDeps` too often, but note that this only happens when something
in the header of a module changes, and this could be solved easily be re-introducing
a version of `GetDependencyInformation` with early cutoff that essentially returns the result of `GetModuleGraph`
but includes the hash of only the `ModSummary`s in the downward dependency closure of the file.

* module graph early cutoff

early cutoff for eval plugin

* allow running benchmarks on examples generated via a script

* Add new benchmarks to config

* Allow pathToId to fail

* Errors

---------

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

bench/MultiLayerModules.sh

@@ -0,0 +1,34 @@
+#!/usr/bin/env bash
+# Generate $DEPTH layers of modules with $WIDTH modules on each layer
+# Every module on layer N imports all the modules on layer N-1
+# MultiLayerModules.hs imports all the modules from the last layer
+DEPTH=15
+WIDTH=40
+cat >hie.yaml << EOF
+cradle:
+  direct:
+    arguments:
+EOF
+for i in $(seq -w 1 $WIDTH); do
+  echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs;
+  echo "          - DummyLevel0M$i.hs" >> hie.yaml;
+done
+for l in $(seq 1 $DEPTH); do
+  for i in $(seq -w 1 $WIDTH); do
+    echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs;
+    echo "          - DummyLevel${l}M$i.hs" >> hie.yaml;
+    for j in $(seq -w 1 $WIDTH); do
+      echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs;
+    done
+  done
+done
+case "$1" in
+  '--th')
+    echo "{-# LANGUAGE TemplateHaskell #-}" > MultiLayerModules.hs
+    ;;
+esac
+echo "module MultiLayerModules where" >> MultiLayerModules.hs
+  echo "          - MultiLayerModules.hs" >> hie.yaml;
+for j in $(seq -w 1 $WIDTH); do
+  echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs;
+done

bench/config.yaml

@@ -33,6 +33,50 @@ examples:
     modules:
         - src/Language/LSP/Types/WatchedFiles.hs
         - src/Language/LSP/Types/CallHierarchy.hs
+
+  - name: MultiLayerModules
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - MultiLayerModules.hs
+        - DummyLevel0M01.hs
+        - DummyLevel1M01.hs
+  - name: MultiLayerModulesNoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - MultiLayerModules.hs
+        - DummyLevel0M01.hs
+        - DummyLevel1M01.hs
+
+  - name: DummyLevel0M01
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - DummyLevel0M01.hs
+  - name: DummyLevel0M01NoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - DummyLevel0M01.hs
+
+  - name: DummyLevel1M01
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - DummyLevel1M01.hs
+  - name: DummyLevel1M01NoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - DummyLevel1M01.hs
+
   # Small but heavily multi-component example
   # Disabled as it is far to slow. hie-bios >0.7.2 should help
   # - name: HLS
@@ -47,6 +91,7 @@ examples:
 
 # The set of experiments to execute
 experiments:
+    - "edit-header"
     - "edit"
     - "hover"
     - "hover after edit"

ghcide-bench/src/Experiments.hs

@@ -79,6 +79,12 @@ charEdit p =
                                         .+ #rangeLength .== Nothing
                                         .+ #text .== "a"
 
+headerEdit :: TextDocumentContentChangeEvent
+headerEdit =
+    TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
+                                        .+ #rangeLength .== Nothing
+                                        .+ #text .== "-- header comment \n"
+
 data DocumentPositions = DocumentPositions {
     -- | A position that can be used to generate non null goto-def and completion responses
     identifierP    :: Maybe Position,
@@ -112,6 +118,16 @@ experiments =
         waitForProgressDone
         return True,
       ---------------------------------------------------------------------------------------
+      bench "edit-header" $ \docs -> do
+        forM_ docs $ \DocumentPositions{..} -> do
+          changeDoc doc [headerEdit]
+          -- wait for a fresh build start
+          waitForProgressStart
+        -- wait for the build to be finished
+        output "edit: waitForProgressDone"
+        waitForProgressDone
+        return True,
+      ---------------------------------------------------------------------------------------
       bench "hover after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
@@ -276,23 +292,26 @@ configP =
     <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
     <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
     <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
-    <*> ( Example "name"
-               <$> (Right <$> packageP)
+    <*> ( Example
+               <$> exampleName
+               <*> (ExampleHackage <$> packageP)
                <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
                <*> pure []
-         <|>
-          Example "name"
-                <$> (Left <$> pathP)
-                <*> some moduleOption
-                <*> pure [])
+      <|> Example
+               <$> exampleName
+               <*> pathOrScriptP
+               <*> some moduleOption
+               <*> pure [])
     <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
   where
       moduleOption = strOption (long "example-module" <> metavar "PATH")
+      exampleName = strOption (long "example-name" <> metavar "NAME")
 
       packageP = ExamplePackage
             <$> strOption (long "example-package-name" <> value "Cabal")
             <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
-      pathP = strOption (long "example-path")
+      pathOrScriptP = ExamplePath   <$> strOption (long "example-path")
+                  <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
 
 versionP :: ReadM Version
 versionP = maybeReader $ extract . readP_to_S parseVersion
@@ -581,13 +600,25 @@ setup :: HasConfig => IO SetupResult
 setup = do
 --   when alreadyExists $ removeDirectoryRecursive examplesPath
   benchDir <- case exampleDetails(example ?config) of
-      Left examplePath -> do
+      ExamplePath examplePath -> do
           let hieYamlPath = examplePath </> "hie.yaml"
           alreadyExists <- doesFileExist hieYamlPath
           unless alreadyExists $
                 cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
           return examplePath
-      Right ExamplePackage{..} -> do
+      ExampleScript examplePath' scriptArgs -> do
+          let exampleDir = examplesPath </> exampleName (example ?config)
+          alreadySetup <- doesDirectoryExist exampleDir
+          unless alreadySetup $ do
+            createDirectoryIfMissing True exampleDir
+            examplePath <- makeAbsolute examplePath'
+            cmd_ (Cwd exampleDir) examplePath scriptArgs
+            let hieYamlPath = exampleDir </> "hie.yaml"
+            alreadyExists <- doesFileExist hieYamlPath
+            unless alreadyExists $
+                  cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
+          return exampleDir
+      ExampleHackage ExamplePackage{..} -> do
         let path = examplesPath </> package
             package = packageName <> "-" <> showVersion packageVersion
             hieYamlPath = path </> "hie.yaml"
@@ -633,8 +664,9 @@ setup = do
   whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
 
   let cleanUp = case exampleDetails(example ?config) of
-        Right _ -> removeDirectoryRecursive examplesPath
-        Left _  -> return ()
+        ExampleHackage _  -> removeDirectoryRecursive examplesPath
+        ExampleScript _ _ -> removeDirectoryRecursive examplesPath
+        ExamplePath _     -> return ()
 
       runBenchmarks = runBenchmarksFun benchDir
 

ghcide-bench/src/Experiments/Types.hs

@@ -40,12 +40,20 @@ data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion ::
 
 data Example = Example
     { exampleName      :: !String
-    , exampleDetails   :: Either FilePath ExamplePackage
+    , exampleDetails   :: ExampleDetails
     , exampleModules   :: [FilePath]
     , exampleExtraArgs :: [String]}
   deriving (Eq, Generic, Show)
   deriving anyclass (Binary, Hashable, NFData)
 
+data ExampleDetails
+  = ExamplePath FilePath -- ^ directory where the package is located
+  | ExampleHackage ExamplePackage -- ^ package from hackage
+  | ExampleScript FilePath -- ^ location of the script we are running
+                  [String] -- ^ extra arguments for the script
+  deriving (Eq, Generic, Show)
+  deriving anyclass (Binary, Hashable, NFData)
+
 instance FromJSON Example where
     parseJSON = withObject "example" $ \x -> do
         exampleName <- x .: "name"
@@ -55,24 +63,39 @@ instance FromJSON Example where
         path <- x .:? "path"
         case path of
             Just examplePath -> do
-                let exampleDetails = Left examplePath
+                script <- fromMaybe False <$> x.:? "script"
+                args <- fromMaybe [] <$> x .:? "script-args"
+                let exampleDetails
+                      | script = ExampleScript examplePath args
+                      | otherwise = ExamplePath examplePath
                 return Example{..}
             Nothing -> do
                 packageName <- x .: "package"
                 packageVersion <- x .: "version"
-                let exampleDetails = Right ExamplePackage{..}
+                let exampleDetails = ExampleHackage ExamplePackage{..}
                 return Example{..}
 
 exampleToOptions :: Example -> [String] -> [String]
-exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =
     ["--example-package-name", packageName
     ,"--example-package-version", showVersion packageVersion
+    ,"--example-name", exampleName
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++
     ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
-exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =
     ["--example-path", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-module=" <> m | m <- exampleModules
+    ] ++
+    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
+exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =
+    ["--example-script", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-script-args=" <> o | o <- exampleArgs
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++

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

@@ -137,6 +137,7 @@ import           GHC                               (Anchor (anchor),
 import qualified GHC                               as G
 import           GHC.Hs                            (LEpaComment)
 import qualified GHC.Types.Error                   as Error
+import Development.IDE.Import.DependencyInformation
 #endif
 
 #if MIN_VERSION_ghc(9,5,0)
@@ -1052,25 +1053,19 @@ handleGenerationErrors' dflags source action =
 -- Add the current ModSummary to the graph, along with the
 -- HomeModInfo's of all direct dependencies (by induction hypothesis all
 -- transitive dependencies will be contained in envs)
+mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
+mergeEnvs env mg ms extraMods envs = do
 #if MIN_VERSION_ghc(9,3,0)
-mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
-mergeEnvs env (ms, deps) extraMods envs = do
     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
         ifr = InstalledFound (ms_location ms) im
         curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
-        -- Very important to force this as otherwise the hsc_mod_graph field is not
-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
-        -- this new one, which in turn leads to the EPS referencing the HPT.
-        module_graph_nodes =
-          nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)
-
     newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
+    return $! loadModulesHome extraMods $
       let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
       (hscUpdateHUG (const newHug) env){
           hsc_FC = newFinderCache,
-          hsc_mod_graph = mkModuleGraph module_graph_nodes
-      })
+          hsc_mod_graph = mg
+      }
 
     where
         mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
@@ -1096,30 +1091,16 @@ mergeEnvs env (ms, deps) extraMods envs = do
           pure $ FinderCache fcModules' fcFiles'
 
 #else
-mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
-mergeEnvs env ms extraMods envs = do
     prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
         ifr = InstalledFound (ms_location ms) im
-        -- Very important to force this as otherwise the hsc_mod_graph field is not
-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
-        -- this new one, which in turn leads to the EPS referencing the HPT.
-        module_graph_nodes =
-#if MIN_VERSION_ghc(9,2,0)
-        -- We don't do any instantiation for backpack at this point of time, so it is OK to use
-        -- 'extendModSummaryNoDeps'.
-        -- This may have to change in the future.
-          map extendModSummaryNoDeps $
-#endif
-          nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)
-
     newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
+    return $! loadModulesHome extraMods $
       env{
           hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
           hsc_FC = newFinderCache,
-          hsc_mod_graph = mkModuleGraph module_graph_nodes
-      })
+          hsc_mod_graph = mg
+      }
 
     where
         mergeUDFM = plusUDFM_C combineModules
@@ -1534,8 +1515,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
              let runtime_deps
                    | not (mi_used_th iface) = emptyModuleEnv
                    | otherwise = parseRuntimeDeps (md_anns details)
-             -- Perform the fine grained recompilation check for TH
-             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
+             -- Peform the fine grained recompilation check for TH
+             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
              case maybe_recomp of
                Just msg -> do_regenerate msg
                Nothing
@@ -1572,13 +1553,21 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
 -- 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 :: 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)
+checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
+checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
+#if MIN_VERSION_ghc(9,3,0)
+  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
+#else
+  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
+#endif
+  let go (mod, hash) = do
+        ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
+        case ifr of
+          InstalledFound loc _ -> do
+            hs <- ml_hs_file loc
+            pure (toNormalizedFilePath' hs,hash)
+          _ -> Nothing
+      hs_files = mapM go (moduleEnvToList runtime_deps)
   case hs_files of
     Nothing -> error "invalid module graph"
     Just fs -> do

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

@@ -69,11 +69,6 @@ type instance RuleResult GetParsedModule = ParsedModule
 -- all comments included using Opt_KeepRawTokenStream
 type instance RuleResult GetParsedModuleWithComments = ParsedModule
 
--- | The dependency information produced by following the imports recursively.
--- This rule will succeed even if there is an error, e.g., a module could not be located,
--- a module could not be parsed or an import cycle.
-type instance RuleResult GetDependencyInformation = DependencyInformation
-
 type instance RuleResult GetModuleGraph = DependencyInformation
 
 data GetKnownTargets = GetKnownTargets
@@ -262,8 +257,8 @@ type instance RuleResult GhcSessionDeps = HscEnvEq
 -- | Resolve the imports in a module to the file path of a module in the same package
 type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)]
 
--- | This rule is used to report import cycles. It depends on GetDependencyInformation.
--- We cannot report the cycles directly from GetDependencyInformation since
+-- | This rule is used to report import cycles. It depends on GetModuleGraph.
+-- We cannot report the cycles directly from GetModuleGraph since
 -- we can only report diagnostics for the current file.
 type instance RuleResult ReportImportCycles = ()
 
@@ -401,11 +396,6 @@ data NeedsCompilation = NeedsCompilation
 instance Hashable NeedsCompilation
 instance NFData   NeedsCompilation
 
-data GetDependencyInformation = GetDependencyInformation
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetDependencyInformation
-instance NFData   GetDependencyInformation
-
 data GetModuleGraph = GetModuleGraph
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetModuleGraph

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

@@ -23,7 +23,6 @@ module Development.IDE.Core.Rules(
     defineEarlyCutOffNoFile,
     mainRule,
     RulesConfig(..),
-    getDependencies,
     getParsedModule,
     getParsedModuleWithComments,
     getClientConfigAction,
@@ -34,7 +33,6 @@ module Development.IDE.Core.Rules(
     getParsedModuleRule,
     getParsedModuleWithCommentsRule,
     getLocatedImportsRule,
-    getDependencyInformationRule,
     reportImportCyclesRule,
     typeCheckRule,
     getDocMapRule,
@@ -68,6 +66,7 @@ import           Control.Concurrent.Async                     (concurrently)
 import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Exception.Safe
+import           Control.Exception                            (evaluate)
 import           Control.Monad.Extra
 import           Control.Monad.Reader
 import           Control.Monad.State
@@ -90,6 +89,7 @@ import           Control.Concurrent.STM.TVar
 import           Data.IntMap.Strict                           (IntMap)
 import qualified Data.IntMap.Strict                           as IntMap
 import           Data.List
+import           Data.List.Extra                              (nubOrdOn)
 import qualified Data.Map                                     as M
 import           Data.Maybe
 import           Data.Proxy
@@ -160,6 +160,7 @@ import qualified Development.IDE.Types.Shake as Shake
 import           Development.IDE.GHC.CoreFile
 import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)
 import Control.Monad.IO.Unlift
+import qualified Data.IntMap as IM
 #if MIN_VERSION_ghc(9,3,0)
 import GHC.Unit.Module.Graph
 import GHC.Unit.Env
@@ -167,6 +168,8 @@ import GHC.Unit.Env
 #if MIN_VERSION_ghc(9,5,0)
 import GHC.Unit.Home.ModInfo
 #endif
+import GHC (mgModSummaries)
+import GHC.Fingerprint
 
 data Log
   = LogShake Shake.Log
@@ -212,12 +215,6 @@ toIdeResult = either (, Nothing) (([],) . Just)
 ------------------------------------------------------------
 -- Exposed API
 ------------------------------------------------------------
--- | Get all transitive file dependencies of a given module.
--- Does not include the file itself.
-getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
-getDependencies file =
-    fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file
-
 getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
 getSourceFileSource nfp = do
     (_, msource) <- getFileContents nfp
@@ -422,17 +419,17 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act
 execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
 execRawDepM act =
     execStateT act
-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty
+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
         , IntMap.empty
         )
 
 -- | Given a target file path, construct the raw dependency results by following
 -- imports recursively.
-rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
+rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap)
 rawDependencyInformation fs = do
     (rdi, ss) <- execRawDepM (goPlural fs)
     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
-    return (rdi { rawBootMap = bm })
+    return (rdi, bm)
   where
     goPlural ff = do
         mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff
@@ -451,9 +448,9 @@ rawDependencyInformation fs = do
           fId <- getFreshFid al
           -- Record this module and its location
           whenJust msum $ \ms ->
-            modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)
-                                                                           (ShowableModuleName (moduleName $ ms_mod ms))
-                                                                           (rawModuleNameMap rd)})
+            modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)
+                                                                           (ShowableModule $ ms_mod ms)
+                                                                           (rawModuleMap rd)})
           -- Adding an edge to the bootmap so we can make sure to
           -- insert boot nodes before the real files.
           addBootMap al fId
@@ -525,27 +522,24 @@ rawDependencyInformation fs = do
     dropBootSuffix :: FilePath -> FilePath
     dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src
 
-getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules ()
-getDependencyInformationRule recorder =
-    define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do
-       rawDepInfo <- rawDependencyInformation [file]
-       pure ([], Just $ processDependencyInformation rawDepInfo)
-
 reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
 reportImportCyclesRule recorder =
-    define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
-        DependencyInformation{..} <- use_ GetDependencyInformation file
-        let fileId = pathToId depPathIdMap file
-        case IntMap.lookup (getFilePathId fileId) depErrorNodes of
-            Nothing -> pure []
-            Just errs -> do
-                let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
-                -- Convert cycles of files into cycles of module names
-                forM cycles $ \(imp, files) -> do
-                    modNames <- forM files $ \fileId -> do
-                        let file = idToPath depPathIdMap fileId
-                        getModuleName file
-                    pure $ toDiag imp $ sort modNames
+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do
+        DependencyInformation{..} <- useNoFile_ GetModuleGraph
+        case pathToId depPathIdMap file of
+          -- The header of the file does not parse, so it can't be part of any import cycles.
+          Nothing -> pure []
+          Just fileId ->
+            case IntMap.lookup (getFilePathId fileId) depErrorNodes of
+              Nothing -> pure []
+              Just errs -> do
+                  let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
+                  -- Convert cycles of files into cycles of module names
+                  forM cycles $ \(imp, files) -> do
+                      modNames <- forM files $ \fileId -> do
+                          let file = idToPath depPathIdMap fileId
+                          getModuleName file
+                      pure $ toDiag imp $ sort modNames
     where cycleErrorInFile f (PartOfCycle imp fs)
             | f `elem` fs = Just (imp, fs)
           cycleErrorInFile _ _ = Nothing
@@ -681,10 +675,37 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde
   pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs)
 
 getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
-getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
+getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
-  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)
-  pure $ processDependencyInformation rawDepInfo
+  dependencyInfoForFiles (HashSet.toList fs)
+
+dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)
+dependencyInfoForFiles fs = do
+  (rawDepInfo, bm) <- rawDependencyInformation fs
+  let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo
+  msrs <- uses GetModSummaryWithoutTimestamps all_fs
+  let mss = map (fmap msrModSummary) msrs
+#if MIN_VERSION_ghc(9,3,0)
+  let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
+      nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
+      mns = catMaybes $ zipWith go mss deps
+      go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
+        where this_dep_ids = mapMaybe snd xs
+              this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
+      go (Just ms) _ = Just $ ModuleNode [] ms
+      go _ _ = Nothing
+      mg = mkModuleGraph mns
+#else
+  let mg = mkModuleGraph $
+#if MIN_VERSION_ghc(9,2,0)
+        -- We don't do any instantiation for backpack at this point of time, so it is OK to use
+        -- 'extendModSummaryNoDeps'.
+        -- This may have to change in the future.
+          map extendModSummaryNoDeps $
+#endif
+          (catMaybes mss)
+#endif
+  pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)
 
 -- This is factored out so it can be directly called from the GetModIface
 -- rule. Directly calling this rule means that on the initial load we can
@@ -754,11 +775,11 @@ loadGhcSession recorder ghcSessionDepsConfig = do
         ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file
 
 newtype GhcSessionDepsConfig = GhcSessionDepsConfig
-    { checkForImportCycles :: Bool
+    { fullModuleGraph :: Bool
     }
 instance Default GhcSessionDepsConfig where
   def = GhcSessionDepsConfig
-    { checkForImportCycles = True
+    { fullModuleGraph = True
     }
 
 -- | Note [GhcSessionDeps]
@@ -777,7 +798,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
     case mbdeps of
         Nothing -> return Nothing
         Just deps -> do
-            when checkForImportCycles $ void $ uses_ ReportImportCycles deps
+            when fullModuleGraph $ void $ use_ ReportImportCycles file
             ms <- msrModSummary <$> if fullModSummary
                 then use_ GetModSummary file
                 else use_ GetModSummaryWithoutTimestamps file
@@ -785,19 +806,33 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
             ifaces <- uses_ GetModIface deps
             let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces
+            mg <- do
+              if fullModuleGraph
+              then depModuleGraph <$> useNoFile_ GetModuleGraph
+              else do
+                let mgs = map hsc_mod_graph depSessions
 #if MIN_VERSION_ghc(9,3,0)
-            -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
-            -- also points to all the direct descendants of the current module. To get the keys for the descendants
-            -- we must get their `ModSummary`s
-            !final_deps <- do
-              dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
-             -- Don't want to retain references to the entire ModSummary when just the key will do
-              return $!! map (NodeKey_Module . msKey) dep_mss
-            let moduleNode = (ms, final_deps)
+                -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
+                -- also points to all the direct descendants of the current module. To get the keys for the descendants
+                -- we must get their `ModSummary`s
+                !final_deps <- do
+                  dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
+                  return $!! map (NodeKey_Module . msKey) dep_mss
+                let module_graph_nodes =
+                      nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)
 #else
-            let moduleNode = ms
+                let module_graph_nodes =
+#if MIN_VERSION_ghc(9,2,0)
+                      -- We don't do any instantiation for backpack at this point of time, so it is OK to use
+                      -- 'extendModSummaryNoDeps'.
+                      -- This may have to change in the future.
+                      map extendModSummaryNoDeps $
 #endif
-            session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions
+                      nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs)
+#endif
+                liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes
+                return $ mkModuleGraph module_graph_nodes
+            session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions
 
             -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new
             -- ExportsMap when it is called. We only need to create the ExportsMap once per
@@ -1201,8 +1236,16 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (Mod
 instance IsIdeGlobal CompiledLinkables
 
 data RulesConfig = RulesConfig
-    { -- | Disable import cycle checking for improved performance in large codebases
-      checkForImportCycles :: Bool
+    { -- | Share the computation for the entire module graph
+      -- We usually compute the full module graph for the project
+      -- and share it for all files.
+      -- However, in large projects it might not be desirable to wait
+      -- for computing the entire module graph before starting to
+      -- typecheck a particular file.
+      -- Disabling this drastically decreases sharing and is likely to
+      -- increase memory usage if you have multiple files open
+      -- Disabling this also disables checking for import cycles
+      fullModuleGraph :: Bool
     -- | Disable TH for improved performance in large codebases
     , enableTemplateHaskell :: Bool
     -- | Warning to show when TH is not supported by the current HLS binary
@@ -1236,11 +1279,10 @@ mainRule recorder RulesConfig{..} = do
     getParsedModuleRule recorder
     getParsedModuleWithCommentsRule recorder
     getLocatedImportsRule recorder
-    getDependencyInformationRule recorder
     reportImportCyclesRule recorder
     typeCheckRule recorder
     getDocMapRule recorder
-    loadGhcSession recorder def{checkForImportCycles}
+    loadGhcSession recorder def{fullModuleGraph}
     getModIfaceFromDiskRule recorder
     getModIfaceFromDiskAndIndexRule recorder
     getModIfaceRule recorder

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

@@ -40,6 +40,7 @@ import           Data.String                (IsString (fromString))
 import           Data.Text                  (unpack)
 #if MIN_VERSION_ghc(9,0,0)
 import           GHC.ByteCode.Types
+import GHC (ModuleGraph)
 #else
 import           ByteCodeTypes
 #endif
@@ -216,6 +217,9 @@ instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getU
 
 instance Show HomeModInfo where show = show . mi_module . hm_iface
 
+instance Show ModuleGraph where show _ = "ModuleGraph {..}"
+instance NFData ModuleGraph where rnf = rwhnf
+
 instance NFData HomeModInfo where
   rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link
 

ghcide/src/Development/IDE/Import/DependencyInformation.hs

@@ -10,8 +10,9 @@ module Development.IDE.Import.DependencyInformation
   , TransitiveDependencies(..)
   , FilePathId(..)
   , NamedModuleDep(..)
-  , ShowableModuleName(..)
-  , PathIdMap
+  , ShowableModule(..)
+  , ShowableModuleEnv(..)
+  , PathIdMap (..)
   , emptyPathIdMap
   , getPathId
   , lookupPathToId
@@ -23,7 +24,7 @@ module Development.IDE.Import.DependencyInformation
   , transitiveDeps
   , transitiveReverseDependencies
   , immediateReverseDependencies
-
+  , lookupModuleFile
   , BootIdMap
   , insertBootId
   ) where
@@ -53,6 +54,7 @@ import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 
 import           GHC
+import Development.IDE.GHC.Compat
 
 -- | The imports for a given module.
 newtype ModuleImports = ModuleImports
@@ -103,8 +105,8 @@ getPathId path m@PathIdMap{..} =
 insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
 insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
 
-pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
-pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
+pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path
 
 lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
 lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
@@ -128,15 +130,14 @@ data RawDependencyInformation = RawDependencyInformation
     -- corresponding hs file. It is used when topologically sorting as we
     -- need to add edges between .hs-boot and .hs so that the .hs files
     -- appear later in the sort.
-    , rawBootMap   :: !BootIdMap
-    , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)
+    , rawModuleMap :: !(FilePathIdMap ShowableModule)
     } deriving Show
 
 data DependencyInformation =
   DependencyInformation
     { depErrorNodes        :: !(FilePathIdMap (NonEmpty NodeError))
     -- ^ Nodes that cannot be processed correctly.
-    , depModuleNames       :: !(FilePathIdMap ShowableModuleName)
+    , depModules       :: !(FilePathIdMap ShowableModule)
     , depModuleDeps        :: !(FilePathIdMap FilePathIdSet)
     -- ^ For a non-error node, this contains the set of module immediate dependencies
     -- in the same package.
@@ -146,13 +147,24 @@ data DependencyInformation =
     -- ^ Map from FilePath to FilePathId
     , depBootMap           :: !BootIdMap
     -- ^ Map from hs-boot file to the corresponding hs file
+    , depModuleFiles       :: !(ShowableModuleEnv FilePathId)
+    -- ^ Map from Module to the corresponding non-boot hs file
+    , depModuleGraph       :: !ModuleGraph
     } deriving (Show, Generic)
 
-newtype ShowableModuleName =
-  ShowableModuleName {showableModuleName :: ModuleName}
+newtype ShowableModule =
+  ShowableModule {showableModule :: Module}
   deriving NFData
 
-instance Show ShowableModuleName where show = moduleNameString . showableModuleName
+newtype ShowableModuleEnv a =
+  ShowableModuleEnv {showableModuleEnv :: ModuleEnv a}
+
+instance Show a => Show (ShowableModuleEnv a) where
+  show (ShowableModuleEnv x) = show (moduleEnvToList x)
+instance NFData a => NFData (ShowableModuleEnv a) where
+  rnf = rwhnf
+
+instance Show ShowableModule where show = moduleNameString . moduleName . showableModule
 
 reachableModules :: DependencyInformation -> [NormalizedFilePath]
 reachableModules DependencyInformation{..} =
@@ -215,15 +227,17 @@ instance Semigroup NodeResult where
    SuccessNode _ <> ErrorNode errs   = ErrorNode errs
    SuccessNode a <> SuccessNode _    = SuccessNode a
 
-processDependencyInformation :: RawDependencyInformation -> DependencyInformation
-processDependencyInformation RawDependencyInformation{..} =
+processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation
+processDependencyInformation RawDependencyInformation{..} rawBootMap mg =
   DependencyInformation
     { depErrorNodes = IntMap.fromList errorNodes
     , depModuleDeps = moduleDeps
     , depReverseModuleDeps = reverseModuleDeps
-    , depModuleNames = rawModuleNameMap
+    , depModules = rawModuleMap
     , depPathIdMap = rawPathIdMap
     , depBootMap = rawBootMap
+    , depModuleFiles = ShowableModuleEnv reverseModuleMap
+    , depModuleGraph = mg
     }
   where resultGraph = buildResultGraph rawImports
         (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
@@ -240,6 +254,7 @@ processDependencyInformation RawDependencyInformation{..} =
           foldr (\(p, cs) res ->
             let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))
             in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges
+        reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap
 
 
 -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
@@ -328,7 +343,7 @@ immediateReverseDependencies file DependencyInformation{..} = do
 -- | returns all transitive dependencies in topological order.
 transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
 transitiveDeps DependencyInformation{..} file = do
-  let !fileId = pathToId depPathIdMap file
+  !fileId <- pathToId depPathIdMap file
   reachableVs <-
       -- Delete the starting node
       IntSet.delete (getFilePathId fileId) .
@@ -351,6 +366,10 @@ transitiveDeps DependencyInformation{..} file = do
 
     vs = topSort g
 
+lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath
+lookupModuleFile mod DependencyInformation{..}
+  = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod
+
 newtype TransitiveDependencies = TransitiveDependencies
   { transitiveModuleDeps :: [NormalizedFilePath]
   -- ^ Transitive module dependencies in topological order.

plugins/hls-eval-plugin/hls-eval-plugin.cabal

@@ -55,6 +55,7 @@ library
   build-depends:
     , aeson
     , base                  >=4.12  && <5
+    , bytestring
     , containers
     , data-default
     , deepseq

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -25,7 +25,7 @@ module Ide.Plugin.Eval.CodeLens (
 
 import           Control.Applicative                          (Alternative ((<|>)))
 import           Control.Arrow                                (second, (>>>))
-import           Control.Exception                            (try)
+import           Control.Exception                            (try, bracket_)
 import qualified Control.Exception                            as E
 import           Control.Lens                                 (_1, _3, ix, (%~),
                                                                (<&>), (^.))
@@ -53,6 +53,8 @@ import           Development.IDE.Core.RuleTypes               (LinkableResult (l
                                                                NeedsCompilation (NeedsCompilation),
                                                                TypeCheck (..),
                                                                tmrTypechecked)
+import           Development.IDE.Core.Shake                   (useWithStale_, useNoFile_,
+                                                               use_, uses_)
 import           Development.IDE.GHC.Compat                   hiding (typeKind,
                                                                unitState)
 import           Development.IDE.GHC.Compat.Util              (GhcException,
@@ -60,7 +62,7 @@ import           Development.IDE.GHC.Compat.Util              (GhcException,
 import           Development.IDE.GHC.Util                     (evalGhcEnv,
                                                                modifyDynFlags,
                                                                printOutputable)
-import           Development.IDE.Import.DependencyInformation (reachableModules)
+import           Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps)
 import           Development.IDE.Types.Location               (toNormalizedFilePath',
                                                                uriToFilePath')
 import           GHC                                          (ClsInst,
@@ -80,7 +82,7 @@ import           GHC                                          (ClsInst,
                                                                typeKind)
 
 
-import           Development.IDE.Core.RuleTypes               (GetDependencyInformation (GetDependencyInformation),
+import           Development.IDE.Core.RuleTypes               (GetModuleGraph (GetModuleGraph),
                                                                GetLinkable (GetLinkable),
                                                                GetModSummary (GetModSummary),
                                                                GhcSessionDeps (GhcSessionDeps),
@@ -118,7 +120,7 @@ import           Ide.Plugin.Eval.GHC                          (addImport,
                                                                showDynFlags)
 import           Ide.Plugin.Eval.Parse.Comments               (commentsToSections)
 import           Ide.Plugin.Eval.Parse.Option                 (parseSetFlags)
-import           Ide.Plugin.Eval.Rules                        (queueForEvaluation)
+import           Ide.Plugin.Eval.Rules                        (queueForEvaluation, unqueueForEvaluation)
 import           Ide.Plugin.Eval.Types
 import           Ide.Plugin.Eval.Util                         (gStrictTry,
                                                                isLiterate,
@@ -215,12 +217,12 @@ runEvalCmd plId st EvalParams{..} =
             mdlText <- moduleText _uri
 
             -- enable codegen for the module which we need to evaluate.
-            liftIO $ queueForEvaluation st nfp
-            liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval"
-            -- Setup a session with linkables for all dependencies and GHCi specific options
-            final_hscEnv <- initialiseSessionForEval
-                                      (needsQuickCheck tests)
-                                      st nfp
+            final_hscEnv <- liftIO $ bracket_
+              (do queueForEvaluation st nfp
+                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
+              (do unqueueForEvaluation st nfp
+                  setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
+              (initialiseSessionForEval (needsQuickCheck tests) st nfp)
 
             evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId
 
@@ -244,21 +246,21 @@ runEvalCmd plId st EvalParams{..} =
 -- also be loaded into the environment.
 --
 -- The interactive context and interactive dynamic flags are also set appropiately.
-initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> ExceptT PluginError (LspM Config) HscEnv
+initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv
 initialiseSessionForEval needs_quickcheck st nfp = do
-  (ms, env1) <- runActionE "runEvalCmd" st $ do
+  (ms, env1) <- runAction "runEvalCmd" st $ do
 
-    ms <- msrModSummary <$> useE GetModSummary nfp
-    deps_hsc <- hscEnv <$> useE GhcSessionDeps nfp
+    ms <- msrModSummary <$> use_ GetModSummary nfp
+    deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp
 
-    linkables_needed <- reachableModules <$> useE GetDependencyInformation nfp
-    linkables <- usesE GetLinkable linkables_needed
+    linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp
+    linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed)
     -- We unset the global rdr env in mi_globals when we generate interfaces
     -- See Note [Clearing mi_globals after generating an iface]
     -- However, the eval plugin (setContext specifically) requires the rdr_env
     -- for the current module - so get it from the Typechecked Module and add
     -- it back to the iface for the current module.
-    rdr_env <- tcg_rdr_env . tmrTypechecked <$> useE TypeCheck nfp
+    rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp
     let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc
         addRdrEnv hmi
           | iface <- hm_iface hmi

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs

@@ -5,7 +5,7 @@
 
 -- To avoid warning "Pattern match has inaccessible right hand side"
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where
+module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where
 
 import           Control.Monad.IO.Class               (MonadIO (liftIO))
 import           Data.HashSet                         (HashSet)
@@ -24,7 +24,8 @@ import           Development.IDE                      (GetModSummaryWithoutTimes
                                                        fromNormalizedFilePath,
                                                        msrModSummary,
                                                        realSrcSpanToRange,
-                                                       useWithStale_)
+                                                       useWithStale_,
+                                                       use_)
 import           Development.IDE.Core.PositionMapping (toCurrentRange)
 import           Development.IDE.Core.Rules           (computeLinkableTypeForDynFlags,
                                                        needsCompilationRule)
@@ -46,6 +47,8 @@ import           GHC.Parser.Annotation
 #endif
 import           Ide.Plugin.Eval.Types
 
+import qualified Data.ByteString                      as BS
+
 newtype Log = LogShake Shake.Log deriving Show
 
 instance Pretty Log where
@@ -56,6 +59,7 @@ rules :: Recorder (WithPriority Log) -> Rules ()
 rules recorder = do
     evalParsedModuleRule recorder
     redefinedNeedsCompilation recorder
+    isEvaluatingRule recorder
     addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)
 
 newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
@@ -64,7 +68,13 @@ instance IsIdeGlobal EvaluatingVar
 queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
 queueForEvaluation ide nfp = do
     EvaluatingVar var <- getIdeGlobalState ide
-    modifyIORef var (Set.insert nfp)
+    atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ()))
+
+unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
+unqueueForEvaluation ide nfp = do
+    EvaluatingVar var <- getIdeGlobalState ide
+    -- remove the module from the Evaluating state, so that next time it won't evaluate to True
+    atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ())
 
 #if MIN_VERSION_ghc(9,2,0)
 #if MIN_VERSION_ghc(9,5,0)
@@ -133,6 +143,13 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorde
         fingerPrint = fromString $ if nullComments comments then "" else "1"
     return (Just fingerPrint, Just comments)
 
+isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
+isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do
+    alwaysRerun
+    EvaluatingVar var <- getIdeGlobalAction
+    b <- liftIO $ (f `Set.member`) <$> readIORef var
+    return (Just (if b then BS.singleton 1 else BS.empty), Just b)
+
 -- Redefine the NeedsCompilation rule to set the linkable type to Just _
 -- whenever the module is being evaluated
 -- This will ensure that the modules are loaded with linkables
@@ -140,11 +157,7 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorde
 -- leading to much better performance of the evaluate code lens
 redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
 redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do
-    alwaysRerun
-
-    EvaluatingVar var <- getIdeGlobalAction
-    isEvaluating <- liftIO $ (f `elem`) <$> readIORef var
-
+    isEvaluating <- use_ IsEvaluating f
 
     if not isEvaluating then needsCompilationRule f else do
         ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f
@@ -152,7 +165,4 @@ redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake re
             linkableType = computeLinkableTypeForDynFlags df'
             fp = encodeLinkableType $ Just linkableType
 
-        -- remove the module from the Evaluating state
-        liftIO $ modifyIORef var (Set.delete f)
-
         pure (Just fp, Just (Just linkableType))

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs

@@ -28,8 +28,9 @@ module Ide.Plugin.Eval.Types
       unLoc,
       Txt,
       EvalParams(..),
-      GetEvalComments(..)
-    ,nullComments)
+      GetEvalComments(..),
+      IsEvaluating(..),
+      nullComments)
 where
 
 import           Control.DeepSeq               (deepseq)
@@ -96,6 +97,13 @@ data Test
     | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range}
     deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
 
+data IsEvaluating = IsEvaluating
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable IsEvaluating
+instance NFData   IsEvaluating
+
+type instance RuleResult IsEvaluating = Bool
+
 data GetEvalComments = GetEvalComments
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetEvalComments