diff --git a/cabal.project b/cabal.project index a795f0126b..c7fdf24a59 100644 --- a/cabal.project +++ b/cabal.project @@ -57,3 +57,11 @@ if impl(ghc >= 9.11) allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, + +-- It contains https://github.com/haskell/hie-bios/pull/464 +-- Improves (possibly dramatically) the startup time when looking for cradles +source-repository-package + type: git + location: https://github.com/haskell/hie-bios + -- That's master after the merge of #464 + tag: 24672b0 diff --git a/flake.lock b/flake.lock index 4efe1416b6..1328f2b58d 100644 --- a/flake.lock +++ b/flake.lock @@ -36,11 +36,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1747467164, - "narHash": "sha256-JBXbjJ0t6T6BbVc9iPVquQI9XSXCGQJD8c8SgnUquus=", + "lastModified": 1748186667, + "narHash": "sha256-UQubDNIQ/Z42R8tPCIpY+BOhlxO8t8ZojwC9o2FW3c8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "3fcbdcfc707e0aa42c541b7743e05820472bdaec", + "rev": "bdac72d387dca7f836f6ef1fe547755fb0e9df61", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 934333cff0..15b9041e7c 100644 --- a/flake.nix +++ b/flake.nix @@ -98,6 +98,7 @@ shell-ghc96 = mkDevShell pkgs.haskell.packages.ghc96; shell-ghc98 = mkDevShell pkgs.haskell.packages.ghc98; shell-ghc910 = mkDevShell pkgs.haskell.packages.ghc910; + shell-ghc912 = mkDevShell pkgs.haskell.packages.ghc912; }; packages = { inherit docs; }; diff --git a/ghcide-test/exe/FindDefinitionAndHoverTests.hs b/ghcide-test/exe/FindDefinitionAndHoverTests.hs index e46141df4e..9c493f5751 100644 --- a/ghcide-test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide-test/exe/FindDefinitionAndHoverTests.hs @@ -187,7 +187,8 @@ tests = let holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], if ghcVersion >= GHC94 && ghcVersion < GHC910 then mkL bar 3 5 3 8 else mkL bar 3 0 3 14] + reexported = Position 55 14 + reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], if ghcVersion >= GHC94 && ghcVersion < GHC910 || not isWindows then mkL bar 3 5 3 8 else mkL bar 3 0 3 14] thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] @@ -237,9 +238,9 @@ tests = let , testM yes yes imported importedSig "Imported symbol" , if isWindows then -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 - testM no yes reexported reexportedSig "Imported symbol (reexported)" + testM no yes reexported reexportedSig "Imported symbol reexported" else - testM yes yes reexported reexportedSig "Imported symbol (reexported)" + testM yes yes reexported reexportedSig "Imported symbol reexported" , test no yes thLocL57 thLoc "TH Splice Hover" , test yes yes import310 pkgTxt "show package name and its version" ] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index dcf171c8a1..dc8e6279ad 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -107,6 +107,7 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector + , pretty-simple if os(windows) build-depends: Win32 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a2dbbb1e15..300064083e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -451,6 +451,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject , optExtensions + , optHaddockParse } <- getIdeOptions -- populate the knownTargetsVar with all the @@ -495,7 +496,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- evalGhcEnv hscEnv $ setOptions optHaddockParse cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -1111,12 +1112,13 @@ addUnit unit_str = liftEwM $ do -- | Throws if package flags are unsatisfiable setOptions :: GhcMonad m - => NormalizedFilePath + => OptHaddockParse + -> NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -- ^ root dir, see Note [Root Directory] -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do +setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1177,6 +1179,7 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do dontWriteHieFiles $ setIgnoreInterfacePragmas $ setBytecodeLinkerOptions $ + enableOptHaddock haddockOpt $ disableOptimisation $ Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory @@ -1190,6 +1193,14 @@ setIgnoreInterfacePragmas df = disableOptimisation :: DynFlags -> DynFlags disableOptimisation df = updOptLevel 0 df +-- | We always compile with '-haddock' unless explicitly disabled. +-- +-- This avoids inconsistencies when doing recompilation checking which was +-- observed in https://github.com/haskell/haskell-language-server/issues/4511 +enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags +enableOptHaddock HaddockParse d = gopt_set d Opt_Haddock +enableOptHaddock NoHaddockParse d = d + setHiDir :: FilePath -> DynFlags -> DynFlags setHiDir f d = -- override user settings to avoid conflicts leading to recompilation diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 3de21e175d..ed494e8711 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -264,7 +264,7 @@ typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) pa typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do - revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph + revs <- transitiveReverseDependencies nfp <$> use_ GetFileModuleGraph nfp case revs of Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index c4f88de047..064726f0b6 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -74,6 +74,9 @@ type instance RuleResult GetParsedModuleWithComments = ParsedModule type instance RuleResult GetModuleGraph = DependencyInformation +-- same as GetModuleGraph but only rebuilds if the target file deps changes +type instance RuleResult GetFileModuleGraph = DependencyInformation + data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets @@ -389,6 +392,9 @@ type instance RuleResult GetModSummary = ModSummaryResult -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleResult GetModulesPaths = (M.Map ModuleName (UnitId, NormalizedFilePath), + M.Map ModuleName (UnitId, NormalizedFilePath)) + data GetParsedModule = GetParsedModule deriving (Eq, Show, Generic) instance Hashable GetParsedModule @@ -417,6 +423,11 @@ data GetModuleGraph = GetModuleGraph instance Hashable GetModuleGraph instance NFData GetModuleGraph +data GetFileModuleGraph = GetFileModuleGraph + deriving (Eq, Show, Generic) +instance Hashable GetFileModuleGraph +instance NFData GetFileModuleGraph + data ReportImportCycles = ReportImportCycles deriving (Eq, Show, Generic) instance Hashable ReportImportCycles @@ -486,6 +497,13 @@ data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps +-- | Scan all the import directory for existing modules and build a map from +-- module name to paths +data GetModulesPaths = GetModulesPaths + deriving (Eq, Show, Generic) +instance Hashable GetModulesPaths +instance NFData GetModulesPaths + data GetModSummary = GetModSummary deriving (Eq, Show, Generic) instance Hashable GetModSummary diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 74eddf55f1..1ff2348ead 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PartialTypeSignatures #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -93,7 +94,7 @@ import Data.Proxy import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Utf16.Rope.Mixed as Rope -import Data.Time (UTCTime (..)) +import Data.Time (UTCTime (..), getCurrentTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra import Data.Typeable (cast) @@ -173,8 +174,12 @@ import System.Info.Extra (isWindows) import qualified Data.IntMap as IM import GHC.Fingerprint - -import GHC.Driver.Env (hsc_all_home_unit_ids) +import Text.Pretty.Simple +import qualified Data.Map.Strict as Map +import System.FilePath (takeExtension, takeFileName, normalise, dropTrailingPathSeparator, dropExtension, splitDirectories) +import Data.Char (isUpper) +import System.Directory.Extra (listFilesRecursive, listFilesInside) +import System.IO.Unsafe data Log = LogShake Shake.Log @@ -262,12 +267,10 @@ getParsedModuleRule recorder = let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information - -- but we no longer need to parse with and without Haddocks separately for above GHC90. - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file ms -withOptHaddock :: ModSummary -> ModSummary -withOptHaddock = withOption Opt_Haddock +withoutOptHaddock :: ModSummary -> ModSummary +withoutOptHaddock = withoutOption Opt_Haddock withOption :: GeneralFlag -> ModSummary -> ModSummary withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} @@ -286,7 +289,7 @@ getParsedModuleWithCommentsRule recorder = ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file opt <- getIdeOptions - let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + let ms' = withoutOptHaddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } @@ -315,30 +318,21 @@ getParsedModuleDefinition packageState opt file ms = do getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules () getLocatedImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file - (KnownTargets targets targetsMap) <- useNoFile_ GetKnownTargets + -- TODO: should we reverse this concatenation, there are way less + -- source import than normal import in theory, so it should be faster let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnv env_eq let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env let dflags = hsc_dflags env opt <- getIdeOptions - let getTargetFor modName nfp - | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | Just tt <- HM.lookup (TargetModule modName) targets = do - -- reuse the existing NormalizedFilePath in order to maximize sharing - let ttmap = HM.mapWithKey const (HashSet.toMap tt) - nfp' = HM.lookupDefault nfp nfp ttmap - itExists <- getFileExists nfp' - return $ if itExists then Just nfp' else Nothing - | otherwise = do - itExists <- getFileExists nfp - return $ if itExists then Just nfp else Nothing + + moduleMaps <- use_ GetModulesPaths file (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + + diagOrImp <- locateModule moduleMaps (hscSetFlags dflags env) import_dirs (optExtensions opt) modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -472,7 +466,7 @@ rawDependencyInformation fs = do 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 + DependencyInformation{..} <- use_ GetFileModuleGraph file 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 [] @@ -608,7 +602,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi -- very expensive. when (foi == NotFOI) $ logWith recorder Logger.Warning $ LogTypecheckedFOI file - typeCheckRuleDefinition hsc pm + typeCheckRuleDefinition hsc pm file knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do @@ -628,10 +622,57 @@ getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake rec fs <- toKnownFiles <$> useNoFile_ GetKnownTargets dependencyInfoForFiles (HashSet.toList fs) +{-# NOINLINE cacheVar #-} +cacheVar = unsafePerformIO (newTVarIO mempty) + +getModulesPathsRule :: Recorder (WithPriority Log) -> Rules () +getModulesPathsRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModulesPaths file -> do + env_eq <- use_ GhcSession file + + cache <- liftIO (readTVarIO cacheVar) + case Map.lookup (envUnique env_eq) cache of + Just res -> pure (mempty, ([], Just res)) + Nothing -> do + let env = hscEnv env_eq + let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env + opt <- getIdeOptions + let exts = (optExtensions opt) + let acceptedExtensions = concatMap (\x -> ['.':x, '.':x <> "-boot"]) exts + + (unzip -> (a, b)) <- flip mapM import_dirs $ \(u, dyn) -> do + (unzip -> (a, b)) <- flip mapM (importPaths dyn) $ \dir' -> do + let dir = dropTrailingPathSeparator dir' + let predicate path = pure (path == dir || isUpper (head (takeFileName path))) + let dir_number_directories = length (splitDirectories dir) + let toModule file = mkModuleName (intercalate "." $ drop dir_number_directories (splitDirectories (dropExtension file))) + + -- TODO: we are taking/droping extension, this could be factorized to save a few cpu cycles ;) + -- TODO: do acceptedextensions needs to be a set ? or a vector? + modules <- fmap (\path -> (toModule path, toNormalizedFilePath' path)) . filter (\y -> takeExtension y `elem` acceptedExtensions) <$> liftIO (listFilesInside predicate dir) + let isSourceModule (_, path) = "-boot" `isSuffixOf` fromNormalizedFilePath path + let (sourceModules, notSourceModules) = partition isSourceModule modules + pure $ (Map.fromList notSourceModules, Map.fromList sourceModules) + pure (fmap (u,) $ mconcat a, fmap (u, ) $ mconcat b) + + let res = (mconcat a, mconcat b) + liftIO $ atomically $ modifyTVar' cacheVar (Map.insert (envUnique env_eq) res) + + pure (mempty, ([], Just $ (mconcat a, mconcat b))) + +getModuleGraphSingleFileRule :: Recorder (WithPriority Log) -> Rules () +getModuleGraphSingleFileRule recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileModuleGraph file -> do + di <- useNoFile_ GetModuleGraph + return (fingerprintToBS <$> lookupFingerprint file di, ([], Just di)) + dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do + -- liftIO $ print ("fs length", length fs) (rawDepInfo, bm) <- rawDependencyInformation fs + -- liftIO $ print ("ok with raw deps") + -- liftIO $ pPrint rawDepInfo let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo + -- liftIO $ print ("all_fs length", length all_fs) msrs <- uses GetModSummaryWithoutTimestamps all_fs let mss = map (fmap msrModSummary) msrs let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids @@ -643,7 +684,10 @@ dependencyInfoForFiles fs = do go (Just ms) _ = Just $ ModuleNode [] ms go _ _ = Nothing mg = mkModuleGraph mns - pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg) + let shallowFingers = IntMap.fromList $ foldr' (\(i, m) acc -> case m of + Just x -> (getFilePathId i,msrFingerprint x):acc + Nothing -> acc) [] $ zip _all_ids msrs + pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg shallowFingers) -- 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 @@ -652,14 +696,15 @@ dependencyInfoForFiles fs = do typeCheckRuleDefinition :: HscEnv -> ParsedModule + -> NormalizedFilePath -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm = do +typeCheckRuleDefinition hsc pm fp = do IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO let dets = TypecheckHelpers { getLinkables = unliftIO unlift . uses_ GetLinkable - , getModuleGraph = unliftIO unlift $ useNoFile_ GetModuleGraph + , getModuleGraph = unliftIO unlift $ use_ GetFileModuleGraph fp } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -706,6 +751,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + -- TODO: this is responsible for a LOT of allocations -- add the deps to the Shake graph let addDependency fp = do @@ -758,7 +804,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces mg <- do if fullModuleGraph - then depModuleGraph <$> useNoFile_ GetModuleGraph + then depModuleGraph <$> use_ GetFileModuleGraph file else do let mgs = map hsc_mod_graph depSessions -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph @@ -771,7 +817,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes return $ mkModuleGraph module_graph_nodes - de <- useNoFile_ GetModuleGraph + de <- use_ GetFileModuleGraph file session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new @@ -801,7 +847,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs - , get_module_graph = useNoFile_ GetModuleGraph + , get_module_graph = use_ GetFileModuleGraph f , regenerate = regenerateHiFile session f ms } hsc_env' <- setFileCacheHook (hscEnv session) @@ -971,13 +1017,13 @@ regenerateHiFile sess f ms compNeeded = do opt <- getIdeOptions -- Embed haddocks in the interface file - (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) + (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm + (diags', mtmr) <- typeCheckRuleDefinition hsc pm f case mtmr of Nothing -> pure (diags', Nothing) Just tmr -> do @@ -1135,7 +1181,7 @@ needsCompilationRule file | "boot" `isSuffixOf` fromNormalizedFilePath file = pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do - graph <- useNoFile GetModuleGraph + graph <- use GetFileModuleGraph file res <- case graph of -- Treat as False if some reverse dependency header fails to parse Nothing -> pure Nothing @@ -1226,6 +1272,8 @@ mainRule recorder RulesConfig{..} = do getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder getModuleGraphRule recorder + getModulesPathsRule recorder + getModuleGraphSingleFileRule recorder getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index d6e0f5614c..72baa9ed9a 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs @@ -29,6 +29,7 @@ module Development.IDE.Import.DependencyInformation , lookupModuleFile , BootIdMap , insertBootId + , lookupFingerprint ) where import Control.DeepSeq @@ -49,6 +50,8 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Tuple.Extra hiding (first, second) import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util (Fingerprint) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () import Development.IDE.Import.FindImports (ArtifactsLocation (..)) import Development.IDE.Types.Diagnostics @@ -136,23 +139,31 @@ data RawDependencyInformation = RawDependencyInformation data DependencyInformation = DependencyInformation - { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) + { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModules :: !(FilePathIdMap ShowableModule) - , depModuleDeps :: !(FilePathIdMap FilePathIdSet) + , depModules :: !(FilePathIdMap ShowableModule) + , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. - , depReverseModuleDeps :: !(IntMap IntSet) + , depReverseModuleDeps :: !(IntMap IntSet) -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. - , depPathIdMap :: !PathIdMap + , depPathIdMap :: !PathIdMap -- ^ Map from FilePath to FilePathId - , depBootMap :: !BootIdMap + , depBootMap :: !BootIdMap -- ^ Map from hs-boot file to the corresponding hs file - , depModuleFiles :: !(ShowableModuleEnv FilePathId) + , depModuleFiles :: !(ShowableModuleEnv FilePathId) -- ^ Map from Module to the corresponding non-boot hs file - , depModuleGraph :: !ModuleGraph + , depModuleGraph :: !ModuleGraph + -- ^ Map from Module to the + , depModuleFingerprints :: !(FilePathIdMap Fingerprint) } deriving (Show, Generic) +lookupFingerprint :: NormalizedFilePath -> DependencyInformation -> Maybe Fingerprint +lookupFingerprint fileId DependencyInformation {..} = + do + FilePathId cur_id <- lookupPathToId depPathIdMap fileId + IntMap.lookup cur_id depModuleFingerprints + newtype ShowableModule = ShowableModule {showableModule :: Module} deriving NFData @@ -228,8 +239,8 @@ instance Semigroup NodeResult where SuccessNode _ <> ErrorNode errs = ErrorNode errs SuccessNode a <> SuccessNode _ = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation -processDependencyInformation RawDependencyInformation{..} rawBootMap mg = +processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation +processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap = DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps @@ -239,6 +250,7 @@ processDependencyInformation RawDependencyInformation{..} rawBootMap mg = , depBootMap = rawBootMap , depModuleFiles = ShowableModuleEnv reverseModuleMap , depModuleGraph = mg + , depModuleFingerprints = buildAccFingerFilePathIdMap moduleDeps shallowFingerMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph @@ -398,3 +410,29 @@ instance NFData NamedModuleDep where instance Show NamedModuleDep where show NamedModuleDep{..} = show nmdFilePath + +-- | Build a map from file path to its full fingerprint. +-- The fingerprint is depend on both the fingerprints of the file and all its dependencies. +-- This is used to determine if a file has changed and needs to be reloaded. +buildAccFingerFilePathIdMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint +buildAccFingerFilePathIdMap modulesDeps shallowFingers = go keys IntMap.empty + where + keys = IntMap.keys shallowFingers + go :: [IntSet.Key] -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint + go keys acc = + case keys of + [] -> acc + k : ks -> + if IntMap.member k acc + -- already in the map, so we can skip + then go ks acc + -- not in the map, so we need to add it + else + let -- get the dependencies of the current key + deps = IntSet.toList $ IntMap.findWithDefault IntSet.empty k modulesDeps + -- add fingerprints of the dependencies to the accumulator + depFingerprints = go deps acc + -- combine the fingerprints of the dependencies with the current key + combinedFingerprints = Util.fingerprintFingerprints $ shallowFingers IntMap.! k : map (depFingerprints IntMap.!) deps + in -- add the combined fingerprints to the accumulator + go ks (IntMap.insert k combinedFingerprints depFingerprints) diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 79614f1809..808fe653c1 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -5,7 +5,6 @@ module Development.IDE.Import.FindImports ( locateModule - , locateModuleFile , Import(..) , ArtifactsLocation(..) , modSummaryToArtifactsLocation @@ -14,9 +13,8 @@ module Development.IDE.Import.FindImports ) where import Control.DeepSeq -import Control.Monad.Extra import Control.Monad.IO.Class -import Data.List (find, isSuffixOf) +import Data.List (isSuffixOf) import Data.Maybe import qualified Data.Set as S import Development.IDE.GHC.Compat as Compat @@ -26,7 +24,8 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Types.PkgQual import GHC.Unit.State -import System.FilePath +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map #if MIN_VERSION_ghc(9,11,0) @@ -70,6 +69,7 @@ data LocateResult | LocateFoundReexport UnitId | LocateFoundFile UnitId NormalizedFilePath +{- -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m => [(UnitId, [FilePath], S.Set ModuleName)] @@ -94,6 +94,7 @@ locateModuleFile import_dirss exts targetFor isSource modName = do maybeBoot ext | isSource = ext ++ "-boot" | otherwise = ext +-} -- | This function is used to map a package name to a set of import paths. -- It only returns Just for unit-ids which are possible to import into the @@ -110,36 +111,45 @@ mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules fl -- Haskell locateModule :: MonadIO m - => HscEnv + => (Map ModuleName (UnitId, NormalizedFilePath),Map ModuleName (UnitId, NormalizedFilePath)) + -> HscEnv -> [(UnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions - -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> PkgQual -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule env comp_info exts targetFor modName mbPkgName isSource = do +locateModule moduleMaps@(moduleMap, moduleMapSource) env comp_info exts modName mbPkgName isSource = do case mbPkgName of -- 'ThisPkg' just means some home module, not the current unit ThisPkg uid + -- TODO: there are MANY lookup on import_paths, which is a problem considering that it can be large. | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports + -> lookupLocal moduleMaps uid dirs reexports | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] -- if a package name is given we only go look for a package OtherPkg uid | Just (dirs, reexports) <- lookup uid import_paths - -> lookupLocal uid dirs reexports + -> lookupLocal moduleMaps uid dirs reexports | otherwise -> lookupInPackageDB NoPkgQual -> do -- Reexports for current unit have to be empty because they only apply to other units depending on the -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying -- to find the module from the perspective of the current unit. - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName + ---- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName + -- + -- TODO: handle the other imports, the unit id, ..., reexport. + -- - TODO: should we look for file existence now? If the file was + -- removed from the disk, how will it behaves? How do we invalidate + -- that? + let mbFile = case Map.lookup (unLoc modName) (if isSource then moduleMapSource else moduleMap) of + Nothing -> LocateNotFound + Just (uid, file) -> LocateFoundFile uid file case mbFile of LocateNotFound -> lookupInPackageDB -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource + LocateFoundReexport uid -> locateModule moduleMaps (hscSetActiveUnitId uid env) comp_info exts modName noPkgQual isSource LocateFoundFile uid file -> toModLocation uid file where dflags = hsc_dflags env @@ -180,12 +190,15 @@ locateModule env comp_info exts targetFor modName mbPkgName isSource = do let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) - lookupLocal uid dirs reexports = do - mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName + lookupLocal moduleMaps@(moduleMapSource, moduleMap) uid dirs reexports = do + -- mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName + let mbFile = case Map.lookup (unLoc modName) (if isSource then moduleMapSource else moduleMap) of + Nothing -> LocateNotFound + Just (uid, file) -> LocateFoundFile uid file case mbFile of LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound [] -- Lookup again with the perspective of the unit reexporting the file - LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource + LocateFoundReexport uid' -> locateModule moduleMaps (hscSetActiveUnitId uid' env) comp_info exts modName noPkgQual isSource LocateFoundFile uid' file -> toModLocation uid' file lookupInPackageDB = do diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 1c2ed1732f..075ccfff07 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq ( HscEnvEq, - hscEnv, newHscEnvEq, + hscEnv, newHscEnvEq, envUnique, updateHscEnvEq, envPackageExports, envVisibleModuleNames, diff --git a/ghcide/src/Development/IDE/Types/KnownTargets.hs b/ghcide/src/Development/IDE/Types/KnownTargets.hs index 6ae6d52ba3..a2eed5efff 100644 --- a/ghcide/src/Development/IDE/Types/KnownTargets.hs +++ b/ghcide/src/Development/IDE/Types/KnownTargets.hs @@ -19,49 +19,26 @@ import Development.IDE.Types.Location import GHC.Generics -- | A mapping of module name to known files -data KnownTargets = KnownTargets - { targetMap :: !(HashMap Target (HashSet NormalizedFilePath)) - -- | 'normalisingMap' is a cached copy of `HMap.mapKey const targetMap` - -- - -- At startup 'GetLocatedImports' is called on all known files. Say you have 10000 - -- modules in your project then this leads to 10000 calls to 'GetLocatedImports' - -- running concurrently. - -- - -- In `GetLocatedImports` the known targets are consulted and the targetsMap - -- is created by mapping the known targets. This map is used for introducing - -- sharing amongst filepaths. This operation copies a local copy of the `target` - -- map which is local to the rule. - -- - -- @ - -- let targetsMap = HMap.mapWithKey const targets - -- @ - -- - -- So now each rule has a 'HashMap' of size 10000 held locally to it and depending - -- on how the threads are scheduled there will be 10000^2 elements in total - -- allocated in 'HashMap's. This used a lot of memory. - -- - -- Solution: Return the 'normalisingMap' in the result of the `GetKnownTargets` rule so it is shared across threads. - , normalisingMap :: !(HashMap Target Target) } deriving Show +newtype KnownTargets = KnownTargets + { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) + } deriving (Show, Eq) unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets -unionKnownTargets (KnownTargets tm nm) (KnownTargets tm' nm') = - KnownTargets (HMap.unionWith (<>) tm tm') (HMap.union nm nm') +unionKnownTargets (KnownTargets tm) (KnownTargets tm') = + KnownTargets (HMap.unionWith (<>) tm tm') mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets -mkKnownTargets vs = KnownTargets (HMap.fromList vs) (HMap.fromList [(k,k) | (k,_) <- vs ]) +mkKnownTargets vs = KnownTargets (HMap.fromList vs) instance NFData KnownTargets where - rnf (KnownTargets tm nm) = rnf tm `seq` rnf nm `seq` () - -instance Eq KnownTargets where - k1 == k2 = targetMap k1 == targetMap k2 + rnf (KnownTargets tm) = rnf tm `seq` () instance Hashable KnownTargets where - hashWithSalt s (KnownTargets hm _) = hashWithSalt s hm + hashWithSalt s (KnownTargets hm) = hashWithSalt s hm emptyKnownTargets :: KnownTargets -emptyKnownTargets = KnownTargets HMap.empty HMap.empty +emptyKnownTargets = KnownTargets HMap.empty data Target = TargetModule ModuleName | TargetFile NormalizedFilePath deriving ( Eq, Ord, Generic, Show ) diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index be3ea20932..d098f09031 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -69,9 +69,7 @@ data IdeOptions = IdeOptions -- ^ When to typecheck reverse dependencies of a file , optHaddockParse :: OptHaddockParse -- ^ Whether to return result of parsing module with Opt_Haddock. - -- Otherwise, return the result of parsing without Opt_Haddock, so - -- that the parsed module contains the result of Opt_KeepRawTokenStream, - -- which might be necessary for hlint. + -- Otherwise, return the result of parsing without Opt_Haddock. , optModifyDynFlags :: Config -> DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs index cc80e91f77..737d6ff630 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,14 +41,10 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE.Core.FileStore (getUriContents) +import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod), - TypeCheck (..), - tmrTypechecked) -import Development.IDE.Core.Shake (useNoFile_, use_, - uses_) +import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified)) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import Development.IDE.GHC.Compat.Util (OverridingBool (..)) @@ -76,17 +72,18 @@ import GHC (ClsInst, import Development.IDE.Core.RuleTypes (GetLinkable (GetLinkable), GetModSummary (GetModSummary), - GetModuleGraph (GetModuleGraph), + GetFileModuleGraph (GetFileModuleGraph), GhcSessionDeps (GhcSessionDeps), - ModSummaryResult (msrModSummary)) -import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) + ModSummaryResult (msrModSummary), + LinkableResult (linkableHomeMod), + TypeCheck (..), + tmrTypechecked, GetFileModuleGraph(..)) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (unLoc) import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Data.List.Extra (unsnoc) -import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) @@ -256,7 +253,7 @@ initialiseSessionForEval needs_quickcheck st nfp = do ms <- msrModSummary <$> use_ GetModSummary nfp deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp - linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp + linkables_needed <- transitiveDeps <$> use_ GetFileModuleGraph nfp <*> 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]