diff --git a/bench/MultiLayerModules.sh b/bench/MultiLayerModules.sh new file mode 100755 index 0000000000..38d85ce9ed --- /dev/null +++ b/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 diff --git a/bench/config.yaml b/bench/config.yaml index 411406fa99..d0433ff2ba 100644 --- a/bench/config.yaml +++ b/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" diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 33e420962a..916631e293 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/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 diff --git a/ghcide-bench/src/Experiments/Types.hs b/ghcide-bench/src/Experiments/Types.hs index 303abaf8cd..db33744912 100644 --- a/ghcide-bench/src/Experiments/Types.hs +++ b/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 ] ++ diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index e34c5323f9..27932497b2 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 491f4d4e0c..252e6cd42f 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 10a7b9c362..13ad47900a 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/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 + nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs) #endif - session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions + 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 diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index b9d1646386..581ae70567 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index cc621764eb..d255c3ac1e 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/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. diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index fa33dd99ff..905ed97673 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index f10dd000a4..d057a317e5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 323e3384ec..e2d38775be 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/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)) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index e6fccc7523..104c1b4615 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/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