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

Author: pepeiborra

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

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

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 _ = "<ModSummaryResult>"
+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)

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))

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

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"