From ef2974d61f2789c744413379a9af5bc2b5c1ca14 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 3 Mar 2021 13:11:42 +0000 Subject: [PATCH 1/2] Faster ModSummary fingerprints The computation of these fingerprints was very suboptimal. This change: - Avoids calling Hdr.getOptions twice - Shares the relevant part of the fingerprint between GetModSummary and GetModSummaryWihoutTimestamps - skips the timestamps altogether, since we already fingerprint the preprocessed - buffer. - Avoids show in the fingerprint computation - Uses efficient fingerprint primitives --- ghcide/src/Development/IDE/Core/Compile.hs | 48 ++++++++++++-- .../src/Development/IDE/Core/Preprocessor.hs | 22 +++---- ghcide/src/Development/IDE/Core/RuleTypes.hs | 20 ++++-- ghcide/src/Development/IDE/Core/Rules.hs | 62 +++++++------------ .../src/Development/IDE/Plugin/Completions.hs | 16 ++--- plugins/default/src/Ide/Plugin/Brittany.hs | 2 +- .../default/src/Ide/Plugin/StylishHaskell.hs | 3 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 5 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 8 +-- .../src/Ide/Plugin/Retrie.hs | 2 +- .../src/Ide/Plugin/Tactic/LanguageServer.hs | 9 +-- 11 files changed, 115 insertions(+), 82 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index a320c38707..1658fcd4ee 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -113,11 +113,14 @@ import TcEnv (tcLookup) import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) import Data.Aeson (toJSON) +import Data.Bits (shiftR) import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Tuple.Extra (dupe) import Data.Unique +import Data.Word +import Foreign.Marshal.Array (withArrayLen) import GHC.Fingerprint import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -691,9 +694,9 @@ getModSummaryFromImports -> FilePath -> UTCTime -> Maybe SB.StringBuffer - -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs]) + -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do - (contents, dflags) <- preprocessor env fp contents + (contents, opts, dflags) <- preprocessor env fp contents -- The warns will hopefully be reported when we actually parse the module (_warns, L main_loc hsmod) <- parseHeader dflags fp contents @@ -720,7 +723,7 @@ getModSummaryFromImports env fp modTime contents = do srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps) - allImps = implicit_imports ++ imps + msrImports = implicit_imports ++ imps -- Force bits that might keep the string buffer and DynFlags alive unnecessarily liftIO $ evaluate $ rnf srcImports @@ -730,7 +733,7 @@ getModSummaryFromImports env fp modTime contents = do let modl = mkModule (thisPackage dflags) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - summary = + msrModSummary = ModSummary { ms_mod = modl #if MIN_GHC_API_VERSION(8,8,0) @@ -749,7 +752,42 @@ getModSummaryFromImports env fp modTime contents = do , ms_srcimps = srcImports , ms_textual_imps = textualImports } - return (summary, allImps) + + msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + return ModSummaryResult{..} + where + -- Compute a fingerprint from the contents of `ModSummary`, + -- eliding the timestamps, the preprocessed source and other non relevant fields + computeFingerprint opts ModSummary{..} = do + let moduleUniques = + [ b + | m <- moduleName ms_mod + : map (unLoc . snd) (ms_srcimps ++ ms_textual_imps) + , b <- toBytes $ uniq $ moduleNameFS m + ] ++ + [ b + | (Just p, _) <- ms_srcimps ++ ms_textual_imps + , b <- toBytes $ uniq p + ] + fingerPrintImports <- withArrayLen moduleUniques $ \len p -> + fingerprintData p len + return $ fingerprintFingerprints $ + [ fingerprintString fp + , fingerPrintImports + ] ++ map fingerprintString opts + + toBytes :: Int -> [Word8] + toBytes w64 = + [ fromIntegral (w64 `shiftR` 56) + , fromIntegral (w64 `shiftR` 48) + , fromIntegral (w64 `shiftR` 40) + , fromIntegral (w64 `shiftR` 32) + , fromIntegral (w64 `shiftR` 24) + , fromIntegral (w64 `shiftR` 16) + , fromIntegral (w64 `shiftR` 8) + , fromIntegral w64 + ] + -- | Parse only the module header parseHeader diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index b8873347ef..a09a379ba3 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -37,7 +37,7 @@ import System.IO.Extra -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags) +preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags) preprocessor env filename mbContents = do -- Perform unlit (isOnDisk, contents) <- @@ -51,10 +51,10 @@ preprocessor env filename mbContents = do return (isOnDisk, contents) -- Perform cpp - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - (isOnDisk, contents, dflags) <- + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (isOnDisk, contents, opts, dflags) <- if not $ xopt LangExt.Cpp dflags then - return (isOnDisk, contents, dflags) + return (isOnDisk, contents, opts, dflags) else do cppLogs <- liftIO $ newIORef [] contents <- ExceptT @@ -67,16 +67,16 @@ preprocessor env filename mbContents = do [] -> throw e diags -> return $ Left diags ) - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - return (False, contents, dflags) + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + return (False, contents, opts, dflags) -- Perform preprocessor if not $ gopt Opt_Pp dflags then - return (contents, dflags) + return (contents, opts, dflags) else do contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents - dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents - return (contents, dflags) + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogAction logAction cppLogs dflags _reason severity srcSpan _style msg = do @@ -135,7 +135,7 @@ parsePragmasIntoDynFlags :: HscEnv -> FilePath -> SB.StringBuffer - -> IO (Either [FileDiagnostic] DynFlags) + -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do let opts = Hdr.getOptions dflags0 contents fp @@ -144,7 +144,7 @@ parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do (dflags, _, _) <- parseDynamicFilePragma dflags0 opts dflags' <- initializePlugins env dflags - return $ disableWarningsAsErrors dflags' + return (map unLoc opts, disableWarningsAsErrors dflags') where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 3ff3d0e86e..f557cb63bf 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -44,6 +44,7 @@ import Development.IDE.Import.FindImports (ArtifactsLocation import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Options (IdeGhcSession) +import Fingerprint import GHC.Serialized (Serialized) import Language.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) @@ -316,13 +317,24 @@ instance Binary IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult +data ModSummaryResult = ModSummaryResult + { msrModSummary :: !ModSummary + , msrImports :: [LImportDecl GhcPs] + , msrFingerprint :: !Fingerprint + } + +instance Show ModSummaryResult where + show _ = "" +instance NFData ModSummaryResult where + rnf ModSummaryResult{..} = + rnf msrModSummary `seq` rnf msrImports `seq` rnf msrFingerprint + -- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. -- without needing to parse the entire source -type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs]) +type instance RuleResult GetModSummary = ModSummaryResult --- | Generate a ModSummary with the timestamps elided, --- for more successful early cutoff -type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs]) +-- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff +type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index c307a9c1b0..adeb4b473b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -143,9 +143,7 @@ import Data.Hashable import Data.IORef import qualified Data.Rope.UTF16 as Rope import Data.Time (UTCTime (..)) -import FastString (FastString (uniq)) import GHC.IO.Encoding -import qualified HeaderInfo as Hdr import Module import TcRnMonad (tcg_dependent_files) @@ -311,7 +309,7 @@ priorityFilesOfInterest = Priority (-2) -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations getParsedModuleRule :: Rules () getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do - (ms, _) <- use_ GetModSummary file + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess opt <- getIdeOptions @@ -376,7 +374,7 @@ mergeParseErrorsHaddock normal haddock = normal ++ -- So it is suitable for use cases where you need a perfect edit. getParsedModuleWithCommentsRule :: Rules () getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithComments file -> do - (ms, _) <- use_ GetModSummary file + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -397,7 +395,7 @@ getParsedModuleDefinition packageState opt file ms = do getLocatedImportsRule :: Rules () getLocatedImportsRule = define $ \GetLocatedImports file -> do - (ms,_) <- use_ GetModSummaryWithoutTimestamps file + ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file @@ -442,7 +440,7 @@ rawDependencyInformation fs = do return (rdi { rawBootMap = bm }) where goPlural ff = do - mss <- lift $ (fmap.fmap) fst <$> uses GetModSummaryWithoutTimestamps ff + mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff zipWithM go ff mss go :: NormalizedFilePath -- ^ Current module being processed @@ -563,7 +561,7 @@ reportImportCyclesRule = where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do - ms <- fst <$> use_ GetModSummaryWithoutTimestamps file + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) @@ -769,7 +767,7 @@ ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) ghcSessionDepsDefinition file = do env <- use_ GhcSession file let hsc = hscEnv env - (ms,_) <- use_ GetModSummaryWithoutTimestamps file + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file deps <- use_ GetDependencies file let tdeps = transitiveModuleDeps deps uses_th_qq = @@ -793,7 +791,7 @@ ghcSessionDepsDefinition file = do -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. getModIfaceFromDiskRule :: Rules () getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do - (ms,_) <- use_ GetModSummary f + ms <- msrModSummary <$> use_ GetModSummary f (diags_session, mb_session) <- ghcSessionDepsDefinition f case mb_session of Nothing -> return (Nothing, (diags_session, Nothing)) @@ -850,7 +848,7 @@ getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndInd isHiFileStableRule :: Rules () isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do - (ms,_) <- use_ GetModSummaryWithoutTimestamps f + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' $ ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile @@ -873,47 +871,30 @@ getModSummaryRule :: Rules () getModSummaryRule = do defineEarlyCutoff $ \GetModSummary f -> do session <- hscEnv <$> use_ GhcSession f - let dflags = hsc_dflags session (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) case modS of - Right res@(ms,_) -> do - let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime) - return ( Just (BS.pack $ show fingerPrint) , ([], Just res)) + Right res -> do + bufFingerPrint <- liftIO $ + fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res + let fingerPrint = fingerprintFingerprints + [ msrFingerprint res, bufFingerPrint ] + return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of - Just res@(msWithTimestamps,_) -> do - let ms = msWithTimestamps { + Just res@ModSummaryResult{..} -> do + let ms = msrModSummary { ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } - dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f - let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms) - return (Just fp, ([], Just res)) + fp = fingerprintToBS msrFingerprint + return (Just fp, ([], Just res{msrModSummary = ms})) Nothing -> return (Nothing, ([], Nothing)) - where - -- Compute a fingerprint from the contents of `ModSummary`, - -- eliding the timestamps and other non relevant fields. - computeFingerprint f sb dflags ModSummary{..} = - let fingerPrint = - ( moduleNameString (moduleName ms_mod) - , ms_hspp_file - , map unLoc opts - , ml_hs_file ms_location - , fingerPrintImports ms_srcimps - , fingerPrintImports ms_textual_imps - ) - fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc)) - opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f) - in fingerPrint - - hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime) - generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do @@ -1074,9 +1055,10 @@ needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do -- that we just threw away, and thus have to recompile all dependencies once -- again, this time keeping the object code. -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled - (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file - (modsums,needsComps) <- par (map (fmap (fst . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) - (uses NeedsCompilation revdeps) + ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps file + (modsums,needsComps) <- + par (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) + (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) pure (Just $ BS.pack $ show $ hash res, ([], Just res)) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 9f4e89a1b9..aab13448f4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -67,14 +67,14 @@ produceCompletions = do sess <- fmap fst <$> useWithStale GhcSessionDeps file case (ms, sess) of - (Just (ms,imps), Just sess) -> do + (Just ModSummaryResult{..}, Just sess) -> do let env = hscEnv sess -- We do this to be able to provide completions of items that are not restricted to the explicit list - (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps) `concurrently` tcRnImportDecls env imps + (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps + cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports return ([], Just cdata) (_diag, _) -> return ([], Nothing) @@ -172,17 +172,17 @@ extendImportHandler' ideState ExtendImport {..} | Just fp <- uriToFilePath doc, nfp <- toNormalizedFilePath' fp = do - (ms, ps, imps) <- MaybeT $ liftIO $ + (ModSummaryResult {..}, ps) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do -- We want accurate edits, so do not use stale data here - (ms, imps) <- MaybeT $ use GetModSummaryWithoutTimestamps nfp + msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp ps <- MaybeT $ use GetAnnotatedParsedSource nfp - return (ms, ps, imps) - let df = ms_hspp_opts ms + return (msr, ps) + let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual - imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) imps + imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) msrImports fmap (nfp,) $ liftEither $ rewriteToWEdit df doc (annsA ps) $ extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp diff --git a/plugins/default/src/Ide/Plugin/Brittany.hs b/plugins/default/src/Ide/Plugin/Brittany.hs index d61397cbe1..ff90bfecda 100644 --- a/plugins/default/src/Ide/Plugin/Brittany.hs +++ b/plugins/default/src/Ide/Plugin/Brittany.hs @@ -38,7 +38,7 @@ provider ide typ contents nfp opts = liftIO $ do let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractRange r contents) - (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp + modsum <- fmap msrModSummary $ runAction "brittany" ide $ use_ GetModSummaryWithoutTimestamps nfp let dflags = ms_hspp_opts modsum let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) where key = "GHC_EXACTPRINT_GHC_LIBDIR" diff --git a/plugins/default/src/Ide/Plugin/StylishHaskell.hs b/plugins/default/src/Ide/Plugin/StylishHaskell.hs index cfa3156d0c..5f610b3c8b 100644 --- a/plugins/default/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/default/src/Ide/Plugin/StylishHaskell.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.StylishHaskell ( descriptor @@ -33,7 +32,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- If the provider fails an error is returned that can be displayed to the user. provider :: FormattingHandler IdeState provider ide typ contents fp _opts = do - (ms_hspp_opts -> dyn, _) <- liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp + dyn <- fmap (ms_hspp_opts . msrModSummary) $ liftIO $ runAction "stylish-haskell" ide $ use_ GetModSummary fp let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file mergedConfig <- liftIO $ getMergedConfig dyn config 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 381b7b387e..3ffa267a3a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -68,7 +68,8 @@ import Development.IDE prettyPrint, use_, useNoFile_, uses_, GhcSessionIO(..), GetDependencies(..), GetModIface(..), - HiFileResult (hirHomeMod, hirModSummary) + HiFileResult (hirHomeMod, hirModSummary), + ModSummaryResult(..) ) import Development.IDE.Core.Rules (TransitiveDependencies(transitiveModuleDeps)) import Development.IDE.Core.Compile (setupFinderCache, loadModulesHome) @@ -289,7 +290,7 @@ runEvalCmd st EvalParams{..} = session <- runGetSession st nfp - (ms, _) <- + ms <- fmap msrModSummary $ liftIO $ runAction "runEvalCmd.getModSummary" st $ use_ GetModSummary nfp diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 8f83618617..34a6b4b1b0 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -234,8 +234,8 @@ getExtensions pflags nfp = do return hlintExts where getFlags :: Action DynFlags getFlags = do - (modsum, _) <- use_ GetModSummary nfp - return $ ms_hspp_opts modsum + modsum <- use_ GetModSummary nfp + return $ ms_hspp_opts $ msrModSummary modsum #endif -- --------------------------------------------------------------------- @@ -378,8 +378,8 @@ applyHint ide nfp mhint = let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent - (modsum, _) <- liftIO $ runAction' $ use_ GetModSummary nfp - let dflags = ms_hspp_opts modsum + modsum <- liftIO $ runAction' $ use_ GetModSummary nfp + let dflags = ms_hspp_opts $ msrModSummary modsum -- Setting a environment variable with the libdir used by ghc-exactprint. -- It is a workaround for an error caused by the use of a hadcoded at compile time libdir -- in ghc-exactprint that makes dependent executables non portables. diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 9038ee9a52..d5690a4547 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -359,7 +359,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do getCPPmodule t = do nt <- toNormalizedFilePath' <$> makeAbsolute t let getParsedModule f contents = do - (modSummary, _) <- + modSummary <- msrModSummary <$> useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt let ms' = modSummary diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs index bd8c5e8038..be30033000 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs @@ -43,8 +43,9 @@ import Ide.Plugin.Tactic.FeatureSet import Ide.Plugin.Tactic.GHC import Ide.Plugin.Tactic.Judgements import Ide.Plugin.Tactic.Range -import Ide.Plugin.Tactic.TestTypes (TacticCommand, - cfg_feature_set, emptyConfig, Config) +import Ide.Plugin.Tactic.TestTypes (Config, TacticCommand, + cfg_feature_set, + emptyConfig) import Ide.Plugin.Tactic.Types import Language.LSP.Server (MonadLsp) import Language.LSP.Types @@ -104,8 +105,8 @@ getIdeDynflags getIdeDynflags state nfp = do -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' -- which don't change very often. - ((modsum,_), _) <- runStaleIde state nfp GetModSummaryWithoutTimestamps - pure $ ms_hspp_opts modsum + (msr, _) <- runStaleIde state nfp GetModSummaryWithoutTimestamps + pure $ ms_hspp_opts $ msrModSummary msr ------------------------------------------------------------------------------ From 115d0639caf8533837f053b8b7bb6640ee8e6dd1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 3 Mar 2021 16:30:39 +0000 Subject: [PATCH 2/2] remove 64 bits assumption --- ghcide/src/Development/IDE/Core/Compile.hs | 33 ++++++---------------- ghcide/src/Development/IDE/GHC/Util.hs | 6 ++++ 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 1658fcd4ee..f5a9b6a2a4 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -113,7 +113,10 @@ import TcEnv (tcLookup) import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) import Data.Aeson (toJSON) +import Data.Binary +import Data.Binary.Put import Data.Bits (shiftR) +import qualified Data.ByteString.Lazy as LBS import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap @@ -759,35 +762,17 @@ getModSummaryFromImports env fp modTime contents = do -- Compute a fingerprint from the contents of `ModSummary`, -- eliding the timestamps, the preprocessed source and other non relevant fields computeFingerprint opts ModSummary{..} = do - let moduleUniques = - [ b - | m <- moduleName ms_mod - : map (unLoc . snd) (ms_srcimps ++ ms_textual_imps) - , b <- toBytes $ uniq $ moduleNameFS m - ] ++ - [ b - | (Just p, _) <- ms_srcimps ++ ms_textual_imps - , b <- toBytes $ uniq p - ] - fingerPrintImports <- withArrayLen moduleUniques $ \len p -> - fingerprintData p len + let moduleUniques = runPut $ do + put $ uniq $ moduleNameFS $ moduleName ms_mod + forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do + put $ uniq $ moduleNameFS $ unLoc m + whenJust mb_p $ put . uniq + fingerPrintImports <- fingerprintFromByteString $ LBS.toStrict moduleUniques return $ fingerprintFingerprints $ [ fingerprintString fp , fingerPrintImports ] ++ map fingerprintString opts - toBytes :: Int -> [Word8] - toBytes w64 = - [ fromIntegral (w64 `shiftR` 56) - , fromIntegral (w64 `shiftR` 48) - , fromIntegral (w64 `shiftR` 40) - , fromIntegral (w64 `shiftR` 32) - , fromIntegral (w64 `shiftR` 24) - , fromIntegral (w64 `shiftR` 16) - , fromIntegral (w64 `shiftR` 8) - , fromIntegral w64 - ] - -- | Parse only the module header parseHeader diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index e737efee53..014907da7d 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -19,6 +19,7 @@ module Development.IDE.GHC.Util( moduleImportPath, cgGutsToCoreModule, fingerprintToBS, + fingerprintFromByteString, fingerprintFromStringBuffer, -- * General utilities readFileUtf8, @@ -200,6 +201,11 @@ fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint fingerprintFromStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len +fingerprintFromByteString :: ByteString -> IO Fingerprint +fingerprintFromByteString bs = do + let (fptr, offset, len) = BS.toForeignPtr bs + withForeignPtr fptr $ \ptr -> + fingerprintData (ptr `plusPtr` offset) len -- | A slightly modified version of 'hDuplicateTo' from GHC. -- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.