From dee94acd2b3773f3745840291d3635f7c4f76ef2 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 27 Sep 2022 06:31:42 +0530 Subject: [PATCH 1/6] 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. --- ghcide/src/Development/IDE/Core/Compile.hs | 63 ++++------ ghcide/src/Development/IDE/Core/RuleTypes.hs | 14 +-- ghcide/src/Development/IDE/Core/Rules.hs | 117 ++++++++++++------ ghcide/src/Development/IDE/GHC/Orphans.hs | 4 + .../IDE/Import/DependencyInformation.hs | 43 +++++-- .../src/Ide/Plugin/Eval/CodeLens.hs | 14 ++- 6 files changed, 152 insertions(+), 103 deletions(-) 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..dbf44c2214 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,7 @@ import GHC.Unit.Env #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo #endif +import GHC (mgModSummaries) data Log = LogShake Shake.Log @@ -212,12 +214,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 +418,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 +447,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,16 +521,10 @@ 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 + DependencyInformation{..} <- useNoFile_ GetModuleGraph let fileId = pathToId depPathIdMap file case IntMap.lookup (getFilePathId fileId) depErrorNodes of Nothing -> pure [] @@ -683,8 +673,34 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - rawDepInfo <- rawDependencyInformation (HashSet.toList fs) - pure $ processDependencyInformation rawDepInfo + dependencyInfoForFiles (HashSet.toList fs) + +dependencyInfoForFiles :: [NormalizedFilePath] -> Action DependencyInformation +dependencyInfoForFiles fs = do + (rawDepInfo, bm) <- rawDependencyInformation fs + let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo + mss <- map (fmap msrModSummary) <$> uses GetModSummaryWithoutTimestamps all_fs +#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 $ 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 +770,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 +793,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 $ uses_ ReportImportCycles deps ms <- msrModSummary <$> if fullModSummary then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file @@ -785,19 +801,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 +1231,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 +1274,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..b4c0f0a367 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 @@ -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: @@ -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/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index f10dd000a4..9bc3abe2f6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -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), @@ -251,8 +253,16 @@ initialiseSessionForEval needs_quickcheck st nfp = do ms <- msrModSummary <$> useE GetModSummary nfp deps_hsc <- hscEnv <$> useE GhcSessionDeps nfp +<<<<<<< HEAD linkables_needed <- reachableModules <$> useE GetDependencyInformation nfp linkables <- usesE GetLinkable linkables_needed +||||||| parent of 075c8d398 (Remove GetDependencyInformation in favour of GetModuleGraph.) + linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp + linkables <- uses_ GetLinkable linkables_needed +======= + linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp + linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) +>>>>>>> 075c8d398 (Remove GetDependencyInformation in favour of GetModuleGraph.) -- 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 From 98912294e8105f3c3308b79f05db8326b1e0620b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 24 Jul 2023 12:04:59 +0530 Subject: [PATCH 2/6] module graph early cutoff early cutoff for eval plugin --- ghcide/src/Development/IDE/Core/Rules.hs | 14 ++++---- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../src/Ide/Plugin/Eval/CodeLens.hs | 26 ++++++--------- .../src/Ide/Plugin/Eval/Rules.hs | 32 ++++++++++++------- .../src/Ide/Plugin/Eval/Types.hs | 12 +++++-- 5 files changed, 49 insertions(+), 36 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index dbf44c2214..0cbec68a76 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -169,6 +169,7 @@ import GHC.Unit.Env import GHC.Unit.Home.ModInfo #endif import GHC (mgModSummaries) +import GHC.Fingerprint data Log = LogShake Shake.Log @@ -523,7 +524,7 @@ rawDependencyInformation fs = do reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = - define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do DependencyInformation{..} <- useNoFile_ GetModuleGraph let fileId = pathToId depPathIdMap file case IntMap.lookup (getFilePathId fileId) depErrorNodes of @@ -671,15 +672,16 @@ 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 dependencyInfoForFiles (HashSet.toList fs) -dependencyInfoForFiles :: [NormalizedFilePath] -> Action DependencyInformation +dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do (rawDepInfo, bm) <- rawDependencyInformation fs let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo - mss <- map (fmap msrModSummary) <$> uses GetModSummaryWithoutTimestamps all_fs + 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 @@ -700,7 +702,7 @@ dependencyInfoForFiles fs = do #endif (catMaybes mss) #endif - pure $ processDependencyInformation rawDepInfo bm mg + 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 @@ -793,7 +795,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do case mbdeps of Nothing -> return Nothing Just deps -> do - when fullModuleGraph $ void $ uses_ ReportImportCycles deps + when fullModuleGraph $ void $ use_ ReportImportCycles file ms <- msrModSummary <$> if fullModSummary then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file 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 9bc3abe2f6..ae63460cca 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, (%~), (<&>), (^.)) @@ -120,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, @@ -217,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 @@ -253,16 +253,8 @@ initialiseSessionForEval needs_quickcheck st nfp = do ms <- msrModSummary <$> useE GetModSummary nfp deps_hsc <- hscEnv <$> useE GhcSessionDeps nfp -<<<<<<< HEAD - linkables_needed <- reachableModules <$> useE GetDependencyInformation nfp - linkables <- usesE GetLinkable linkables_needed -||||||| parent of 075c8d398 (Remove GetDependencyInformation in favour of GetModuleGraph.) - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - linkables <- uses_ GetLinkable linkables_needed -======= linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp - linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) ->>>>>>> 075c8d398 (Remove GetDependencyInformation in favour of GetModuleGraph.) + linkables <- usesE 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 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 From 50914ea17e7653b9ddae774478edf5253366d111 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 24 Jul 2023 13:45:49 +0530 Subject: [PATCH 3/6] allow running benchmarks on examples generated via a script --- ghcide-bench/src/Experiments.hs | 56 +++++++++++++++++++++------ ghcide-bench/src/Experiments/Types.hs | 33 +++++++++++++--- 2 files changed, 72 insertions(+), 17 deletions(-) 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 ] ++ From 62d260c05e4f0de3a6082be022c270d0deec9203 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 24 Jul 2023 16:59:15 +0530 Subject: [PATCH 4/6] Add new benchmarks to config --- bench/MultiLayerModules.sh | 34 ++++++++++++++++++++++++++++ bench/config.yaml | 45 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+) create mode 100755 bench/MultiLayerModules.sh 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" From 88d7f7c5279a7f0e28e297829fdf482f3234e16b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 26 Jul 2023 12:02:31 +0530 Subject: [PATCH 5/6] Allow pathToId to fail --- ghcide/src/Development/IDE/Core/Rules.hs | 25 +++++++++++-------- .../IDE/Import/DependencyInformation.hs | 6 ++--- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 0cbec68a76..13ad47900a 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -526,17 +526,20 @@ reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do DependencyInformation{..} <- useNoFile_ GetModuleGraph - 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 + 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 diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index b4c0f0a367..d255c3ac1e 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs @@ -105,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 @@ -343,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) . From 9aea2f6849be0d89a01c60f52a1531219bbeb95a Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 2 Aug 2023 14:26:31 +0530 Subject: [PATCH 6/6] Errors --- .../hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 ae63460cca..d057a317e5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -246,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 <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp - linkables <- usesE GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) + 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