From 3747ae515045adbfd5b54bdd94b46ef0b8c2a789 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 3 Jul 2024 18:23:28 +0000 Subject: [PATCH 1/5] use the type check modsummary --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++++ ghcide/src/Development/IDE/Core/Compile.hs | 7 ++++++- ghcide/src/Development/IDE/Core/Rules.hs | 6 +++++- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 31b1f5965b..18156af0ca 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -125,6 +125,7 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import Debug.Trace (traceM) data Log = LogSettingInitialDynFlags @@ -530,7 +531,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- See Note [Avoiding bad interface files] let hscComponents = sort $ map show uids cacheDirOpts = hscComponents ++ componentOptions opts + let opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack cacheDirOpts) + traceM $ "Setting cache dirs for " ++ show rawComponentUnitId ++ " " ++ opts_hash ++ " " ++ show cacheDirOpts cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs df2 -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3d56ef42d5..76d3d1276f 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -126,6 +126,7 @@ import GHC.Driver.Config.CoreToStg.Prep #if MIN_VERSION_ghc(9,7,0) import Data.Foldable (toList) import GHC.Unit.Module.Warnings +import Development.IDE.Core.WorkerThread (awaitRunInThread) #else import Development.IDE.Core.FileStore (shareFilePath) #endif @@ -196,6 +197,7 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id + -- | Install hooks to capture the splices as well as the runtime module dependencies captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString) captureSplicesAndDeps TypecheckHelpers{..} env k = do @@ -432,6 +434,7 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm + traceM $ "[TRACE] Generating hi file for " ++ show (moduleName $ ms_mod ms) (details, guts) <- do -- write core file -- give variables unique OccNames @@ -724,11 +727,13 @@ addRelativeImport fp modu dflags = dflags -- | Also resets the interface store atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a atomicFileWrite se targetPath write = do + -- awaitRunInThread (restartQueue se) $ do + traceM $ "[TRACE] Writing file: " <> targetPath let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) - `onException` cleanUp + `onException` (cleanUp >> throwIO (userError "atomicFileWrite: write failed")) generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 590fd59da3..f5c11a4337 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -169,6 +169,7 @@ import System.Info.Extra (isWindows) import qualified Data.IntMap as IM import GHC.Fingerprint +import Debug.Trace (traceM) data Log @@ -1039,10 +1040,13 @@ usePropertyByPathAction path plId p = do getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f + -- ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f + tmr <- use_ TypeCheck f + let ms = tmrModSummary tmr HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f let obj_file = ml_obj_file (ms_location ms) core_file = ml_core_file (ms_location ms) + traceM $ "GetLinkable core_file " ++ show core_file case hirCoreFp of Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f Just (bin_core, fileHash) -> do From d5fa10b2a0bbef862f2d497031d1da7534893c59 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 3 Jul 2024 18:31:28 +0000 Subject: [PATCH 2/5] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 4 ---- ghcide/src/Development/IDE/Core/Compile.hs | 7 +------ ghcide/src/Development/IDE/Core/Rules.hs | 6 +----- 3 files changed, 2 insertions(+), 15 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 18156af0ca..31b1f5965b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -125,7 +125,6 @@ import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State -import Debug.Trace (traceM) data Log = LogSettingInitialDynFlags @@ -531,10 +530,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- See Note [Avoiding bad interface files] let hscComponents = sort $ map show uids cacheDirOpts = hscComponents ++ componentOptions opts - let opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack cacheDirOpts) - traceM $ "Setting cache dirs for " ++ show rawComponentUnitId ++ " " ++ opts_hash ++ " " ++ show cacheDirOpts cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs df2 -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 76d3d1276f..3d56ef42d5 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -126,7 +126,6 @@ import GHC.Driver.Config.CoreToStg.Prep #if MIN_VERSION_ghc(9,7,0) import Data.Foldable (toList) import GHC.Unit.Module.Warnings -import Development.IDE.Core.WorkerThread (awaitRunInThread) #else import Development.IDE.Core.FileStore (shareFilePath) #endif @@ -197,7 +196,6 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id - -- | Install hooks to capture the splices as well as the runtime module dependencies captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString) captureSplicesAndDeps TypecheckHelpers{..} env k = do @@ -434,7 +432,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm - traceM $ "[TRACE] Generating hi file for " ++ show (moduleName $ ms_mod ms) (details, guts) <- do -- write core file -- give variables unique OccNames @@ -727,13 +724,11 @@ addRelativeImport fp modu dflags = dflags -- | Also resets the interface store atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a atomicFileWrite se targetPath write = do - -- awaitRunInThread (restartQueue se) $ do - traceM $ "[TRACE] Writing file: " <> targetPath let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) - `onException` (cleanUp >> throwIO (userError "atomicFileWrite: write failed")) + `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index f5c11a4337..6fb130f2a4 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -169,7 +169,6 @@ import System.Info.Extra (isWindows) import qualified Data.IntMap as IM import GHC.Fingerprint -import Debug.Trace (traceM) data Log @@ -1040,13 +1039,10 @@ usePropertyByPathAction path plId p = do getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - -- ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f - tmr <- use_ TypeCheck f - let ms = tmrModSummary tmr + ms <- tmrModSummary <$> use_ TypeCheck f HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f let obj_file = ml_obj_file (ms_location ms) core_file = ml_core_file (ms_location ms) - traceM $ "GetLinkable core_file " ++ show core_file case hirCoreFp of Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f Just (bin_core, fileHash) -> do From 25191c5433c69e25560776804d9cabb2c0072a02 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 3 Jul 2024 18:54:30 +0000 Subject: [PATCH 3/5] direct from HiFileResult --- ghcide/src/Development/IDE/Core/Rules.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6fb130f2a4..b0d61579cc 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1039,10 +1039,9 @@ usePropertyByPathAction path plId p = do getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - ms <- tmrModSummary <$> use_ TypeCheck f - HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f - let obj_file = ml_obj_file (ms_location ms) - core_file = ml_core_file (ms_location ms) + HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f + let obj_file = ml_obj_file (ms_location hirModSummary) + core_file = ml_core_file (ms_location hirModSummary) case hirCoreFp of Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f Just (bin_core, fileHash) -> do @@ -1055,7 +1054,7 @@ getLinkableRule recorder = core_t <- liftIO $ getModTime core_file (warns, hmi) <- case linkableType of -- Bytecode needs to be regenerated from the core file - BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) + BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) -- Object code can be read from the disk ObjectLinkable -> do -- object file is up to date if it is newer than the core file @@ -1068,8 +1067,8 @@ getLinkableRule recorder = else pure Nothing case mobj_time of Just obj_t - | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) - _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time") + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ LM (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) [DotO obj_file])) + _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time") -- Record the linkable so we know not to unload it, and unload old versions whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) $ \(LM time mod _) -> do compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction From 7affbfe5fd93d30116e717dc4a1d1a9c9c0c96e3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 4 Jul 2024 19:00:21 +0800 Subject: [PATCH 4/5] add ModLocation to finger print --- ghcide/src/Development/IDE/Core/Compile.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3d56ef42d5..d9c5d20c08 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -94,7 +94,7 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import GHC (ForeignHValue, GetDocsFailure (..), - parsedSource) + parsedSource, ModLocation (..)) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized import HieDb hiding (withHieDb) @@ -1021,8 +1021,18 @@ getModSummaryFromImports env fp _modTime mContents = do return $! Util.fingerprintFingerprints $ [ Util.fingerprintString fp , fingerPrintImports + , modLocationFingerprint ms_location ] ++ map Util.fingerprintString opts + modLocationFingerprint :: ModLocation -> Util.Fingerprint + modLocationFingerprint ModLocation{..} = Util.fingerprintFingerprints $ + Util.fingerprintString <$> [ fromMaybe "" ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file] + -- | Parse only the module header parseHeader From 2aaf3793068518dbd23ba27fc77222c85ba2d2e1 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 4 Jul 2024 19:52:09 +0800 Subject: [PATCH 5/5] format --- ghcide/src/Development/IDE/Core/Compile.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index d9c5d20c08..cb960dd2c9 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1033,7 +1033,6 @@ getModSummaryFromImports env fp _modTime mContents = do , ml_dyn_obj_file , ml_hie_file] - -- | Parse only the module header parseHeader :: Monad m