From 58b8b687ad578f1ee305ae0e549a6198928582e3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 2 Nov 2024 09:44:33 +0800 Subject: [PATCH 001/107] Refactor session loading to manage pending files so we can batch load them to improve performance fix #4381 --- .../session-loader/Development/IDE/Session.hs | 55 +++++++++++-------- 1 file changed, 33 insertions(+), 22 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a1d778ab0e..dab01c982f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -424,7 +424,7 @@ getHieDbLoc dir = do loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - cradle_files <- newIORef [] + cradle_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -434,6 +434,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) + pendingFilesTQueue <- newTQueueIO + -- Pending files waiting to be loaded -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) @@ -550,7 +552,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) + -> IO ((IdeResult HscEnvEq,[FilePath]), HashSet FilePath) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -562,13 +564,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let new_cache = newComponentCache recorder optExtensions _cfp hscEnv all_target_details <- new_cache old_deps new_deps + let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + all_targets' = concat all_target_details + newLoaded = HM.keys flags_map' this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + where this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) @@ -580,27 +584,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + -- Typecheck all files in the project on startup + checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - keys2 <- invalidateShakeCache restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache keys1 <- extendKnownTargets all_targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - - return $ second Map.keys this_options + + return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do @@ -615,11 +619,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" + + pendingFiles <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ pendingFiles <> old_files) addTag "result" (show res) return res @@ -633,8 +639,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - atomicModifyIORef' cradle_files (\xs -> (cfp:xs,())) - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + (results, newLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + -- put back to pending que if not listed in the results + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` newLoaded + atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + atomicModifyIORef' cradle_files (\xs -> (pendingFiles `Set.intersection` newLoaded <> xs,())) + return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do @@ -708,6 +718,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do + atomically $ writeTQueue pendingFilesTQueue $ toAbsolutePath file -- see Note [Serializing runs in separate thread] awaitRunInThread que $ getOptions file From ea002d7ef8f2c8be8663e2689bced7e67b8884ac Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 3 Nov 2024 15:28:16 +0800 Subject: [PATCH 002/107] distribute errors to all pending files are being loading --- .../session-loader/Development/IDE/Session.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dab01c982f..8683b5ada1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -425,6 +425,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef (Set.fromList []) +-- error_loading_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -606,6 +607,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + let makeError hieYaml cradle err cfp = do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) + void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) + void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + return (fst res) + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp @@ -648,13 +658,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + errors <- mapM (makeError hieYaml cradle err) $ Set.toList pendingFiles + return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let -- | We allow users to specify a loading strategy. From c78b197000c093e76f5277b7814b81ec32a85564 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 3 Nov 2024 16:15:57 +0800 Subject: [PATCH 003/107] better filter loading files --- cabal.project | 6 ++++++ ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- .../session-loader/Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 08d743c24e..3cae5e5181 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,7 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils +-- ../hiebios index-state: 2024-10-21T00:00:00Z @@ -46,3 +47,8 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False + +source-repository-package + type: git + location: https://github.com/soulomoon/hie-bios.git + tag: 7dd19b547ba30b760053b5f796c439cba6ac6a07 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8683b5ada1..a4e8678d43 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -658,7 +658,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - errors <- mapM (makeError hieYaml cradle err) $ Set.toList pendingFiles + let failedLoadingFiles = nub $ cfp:concatMap cradleErrorLoadingFiles err + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` Set.fromList failedLoadingFiles + atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + errors <- mapM (makeError hieYaml cradle err) $ failedLoadingFiles return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index a8e35e5965..ac18ff2025 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp +renderCradleError (CradleError deps _ec ms _fps) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From b87937580e8239024b58d3013cb12f38ec50d0d8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:20:25 +0800 Subject: [PATCH 004/107] fallback to non-batch load --- cabal.project | 6 -- .../session-loader/Development/IDE/Session.hs | 64 ++++++++++++------- .../Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 43 insertions(+), 29 deletions(-) diff --git a/cabal.project b/cabal.project index 3cae5e5181..08d743c24e 100644 --- a/cabal.project +++ b/cabal.project @@ -6,7 +6,6 @@ packages: ./ghcide ./hls-plugin-api ./hls-test-utils --- ../hiebios index-state: 2024-10-21T00:00:00Z @@ -47,8 +46,3 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False - -source-repository-package - type: git - location: https://github.com/soulomoon/hie-bios.git - tag: 7dd19b547ba30b760053b5f796c439cba6ac6a07 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a4e8678d43..1dc4135923 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -146,10 +146,13 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogSessionNewLoadedFiles ![FilePath] deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionNewLoadedFiles files -> + "New loaded files:" <+> pretty files LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -425,7 +428,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef (Set.fromList []) --- error_loading_files <- newIORef (Set.fromList []) + error_loading_files <- newIORef (Set.fromList []) -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -603,19 +606,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - - return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) - let makeError hieYaml cradle err cfp = do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (fst res) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp @@ -630,12 +622,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + -- remove the file from error loading files + errorFiles <- readIORef error_loading_files + -- remove error files from pending files since error loading need to load one by one + let pendingFiles = pendingFiles' `Set.difference` errorFiles + -- if the file is in error loading files, we fall back to single loading mode + let toLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ pendingFiles <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ toLoads <> old_files) addTag "result" (show res) return res @@ -649,20 +648,37 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (results, newLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) + (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- put back to pending que if not listed in the results - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` newLoaded + -- delete cfp even if ew report No cradle target found for cfp + let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded + let newLoadedT = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) - atomicModifyIORef' cradle_files (\xs -> (pendingFiles `Set.intersection` newLoaded <> xs,())) + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT + atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) + atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - let failedLoadingFiles = nub $ cfp:concatMap cradleErrorLoadingFiles err - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` Set.fromList failedLoadingFiles - atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) - errors <- mapM (makeError hieYaml cradle err) $ failedLoadingFiles - return ((concat errors, Nothing), maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + if (length toLoads > 1) + then do + succLoaded_files <- readIORef cradle_files + -- mark as less loaded files as failedLoadingFiles possible + let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files + atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) + -- retry without other files + atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) + consultCradle hieYaml cfp + else do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) + void $ modifyVar' fileToFlags $ + Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) + void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let -- | We allow users to specify a loading strategy. @@ -703,6 +719,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do deps_ok <- checkDependencyInfo old_di if not deps_ok then do + -- todo invoke the action to recompile the file + -- if deps are old, we can try to load the error files again + atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) + atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) -- If the dependencies are out of date then clear both caches and start -- again. modifyVar_ fileToFlags (const (return Map.empty)) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index ac18ff2025..a8e35e5965 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms _fps) cradle nfp +renderCradleError (CradleError deps _ec ms) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From 8953aec8f4eac9f8c87b6ddf955eeb383ebcf959 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:23:51 +0800 Subject: [PATCH 005/107] typo --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1dc4135923..9eac2ce279 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -665,7 +665,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do if (length toLoads > 1) then do succLoaded_files <- readIORef cradle_files - -- mark as less loaded files as failedLoadingFiles possible + -- mark as less loaded files as failedLoadingFiles as possible let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files From 4bdc2c87c8aead0b14a988e9c0b19b8d2d735558 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:24:59 +0800 Subject: [PATCH 006/107] update inline doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 9eac2ce279..7df8fc0240 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -623,7 +623,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do <> " (for " <> T.pack lfpLog <> ")" pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) - -- remove the file from error loading files errorFiles <- readIORef error_loading_files -- remove error files from pending files since error loading need to load one by one let pendingFiles = pendingFiles' `Set.difference` errorFiles @@ -656,6 +655,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT + -- remove the file from error loading files atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results From c4bb53a267c5173394ce330f33e84d6da497541a Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:26:22 +0800 Subject: [PATCH 007/107] update inline doc --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7df8fc0240..70a882b337 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -438,8 +438,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. filesMap <- newVar HM.empty :: IO (Var FilesMap) - pendingFilesTQueue <- newTQueueIO -- Pending files waiting to be loaded + pendingFilesTQueue <- newTQueueIO -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) From 112bc951555bf0c1e542ad05586457d351e079af Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 21:36:03 +0800 Subject: [PATCH 008/107] add LogSessionReloadOnError to log errors during file reloads; cleanup error loading and cradle files --- ghcide/session-loader/Development/IDE/Session.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 70a882b337..793c6b3669 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -147,10 +147,13 @@ data Log | LogHieBios HieBios.Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] + | LogSessionReloadOnError FilePath ![FilePath] deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionReloadOnError path files -> + "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files LogSessionNewLoadedFiles files -> "New loaded files:" <+> pretty files LogNoneCradleFound path -> @@ -649,14 +652,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do | compileTime == runTime -> do (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) -- put back to pending que if not listed in the results - -- delete cfp even if ew report No cradle target found for cfp + -- delete cfp even if we report No cradle target found for the cfp let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded let newLoadedT = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT - -- remove the file from error loading files atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) + -- remove the file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) @@ -711,6 +714,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do modifyVar_ filesMap (const (return HM.empty)) -- Don't even keep the name cache, we start from scratch here! modifyVar_ hscEnvs (const (return Map.empty)) + -- cleanup error loading files and cradle files + atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) + atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags let cfp = toAbsolutePath file From 6e04d289fe57145153128b44bf1aacb42992456b Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 4 Nov 2024 23:35:57 +0800 Subject: [PATCH 009/107] refactor loadSessionWithOptions to improve error handling and clarify variable names --- ghcide/session-loader/Development/IDE/Session.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 793c6b3669..bcf29f85b4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -630,13 +630,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- remove error files from pending files since error loading need to load one by one let pendingFiles = pendingFiles' `Set.difference` errorFiles -- if the file is in error loading files, we fall back to single loading mode - let toLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + let extraToLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog old_files <- readIORef cradle_files - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ toLoads <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) addTag "result" (show res) return res @@ -660,16 +660,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) -- remove the file from error loading files - atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` newLoadedT, ())) + atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do - if (length toLoads > 1) + if (not $ null extraToLoads) then do succLoaded_files <- readIORef cradle_files -- mark as less loaded files as failedLoadingFiles as possible - let failedLoadingFiles = (Set.insert cfp toLoads) `Set.difference` succLoaded_files + let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` succLoaded_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) @@ -681,6 +681,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) let From 67aebc42b01d46c9f699cd4a4f045c548c0960c2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 02:03:00 +0800 Subject: [PATCH 010/107] refactor loadSessionWithOptions to improve pending file handling and error management --- .../session-loader/Development/IDE/Session.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index bcf29f85b4..cb2571e046 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -625,17 +625,18 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles' <- Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) errorFiles <- readIORef error_loading_files - -- remove error files from pending files since error loading need to load one by one - let pendingFiles = pendingFiles' `Set.difference` errorFiles + old_files <- readIORef cradle_files -- if the file is in error loading files, we fall back to single loading mode - let extraToLoads = if cfp `Set.member` errorFiles then Set.empty else pendingFiles + let extraToLoads = if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else Set.delete cfp $ pendingFiles `Set.difference` errorFiles eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - old_files <- readIORef cradle_files res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) addTag "result" (show res) return res @@ -654,22 +655,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- put back to pending que if not listed in the results -- delete cfp even if we report No cradle target found for the cfp let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded - let newLoadedT = pendingFiles `Set.intersection` allNewLoaded + let newLoaded = pendingFiles `Set.intersection` allNewLoaded atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoadedT - atomicModifyIORef' cradle_files (\xs -> (newLoadedT <> xs,())) - -- remove the file from error loading files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) + atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) return results | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) -- Failure case, either a cradle error or the none cradle Left err -> do if (not $ null extraToLoads) then do - succLoaded_files <- readIORef cradle_files -- mark as less loaded files as failedLoadingFiles as possible - let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` succLoaded_files + let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) From 98ae44677d0f4295ed2e461b838f5f938e1f4a50 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 02:25:56 +0800 Subject: [PATCH 011/107] add doc about limitation --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cb2571e046..127af00f2d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -669,6 +669,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do if (not $ null extraToLoads) then do -- mark as less loaded files as failedLoadingFiles as possible + -- limitation is that when we are loading files, and the dependencies of old_files + -- are changed, and old_files are not valid anymore. + -- but they will still be in the old_files, and will not move to error_loading_files. + -- And make other files failed to load in batch mode. let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files @@ -726,7 +730,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do deps_ok <- checkDependencyInfo old_di if not deps_ok then do - -- todo invoke the action to recompile the file -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) From f3eb580d1217f8fde81d2dc334df22482b6588a3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 5 Nov 2024 16:51:10 +0800 Subject: [PATCH 012/107] absolute file at the beginning --- ghcide/session-loader/Development/IDE/Session.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 127af00f2d..57c9a73024 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -677,6 +677,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) consultCradle hieYaml cfp else do dep_info <- getDependencyInfo (maybeToList hieYaml) @@ -724,8 +725,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - let cfp = toAbsolutePath file - case HM.lookup (toNormalizedFilePath' cfp) v of + case HM.lookup (toNormalizedFilePath' file) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di if not deps_ok @@ -739,9 +739,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do modifyVar_ filesMap (const (return HM.empty)) -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) - consultCradle hieYaml cfp + consultCradle hieYaml file else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp + Nothing -> consultCradle hieYaml file -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try @@ -749,16 +749,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- before attempting to do so. let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do - let ncfp = toNormalizedFilePath' (toAbsolutePath file) + let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do - atomically $ writeTQueue pendingFilesTQueue $ toAbsolutePath file + let absFile = toAbsolutePath file + atomically $ writeTQueue pendingFilesTQueue absFile -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions file + awaitRunInThread que $ getOptions absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From e7bd3d42045fb9680c23f995ff8b98c63a4772c8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 01:45:56 +0800 Subject: [PATCH 013/107] run session loader and worker in sperate --- ghcide/ghcide.cabal | 2 + .../session-loader/Development/IDE/Session.hs | 137 +++++++++++++----- .../Development/IDE/Session/OrderedSet.hs | 39 +++++ 3 files changed, 141 insertions(+), 37 deletions(-) create mode 100644 ghcide/session-loader/Development/IDE/Session/OrderedSet.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index bf88a55ed3..81e33aa2fa 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -110,6 +110,7 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector + , ListT if os(windows) build-depends: Win32 @@ -204,6 +205,7 @@ library Development.IDE.GHC.CPP Development.IDE.GHC.Warnings Development.IDE.Types.Action + Development.IDE.Session.OrderedSet if flag(pedantic) ghc-options: diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 57c9a73024..6cbf6ea370 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -25,6 +25,7 @@ import Control.Exception.Safe as Safe import Control.Monad import Control.Monad.Extra as Extra import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H import Data.Aeson hiding (Error) import Data.Bifunctor @@ -103,8 +104,7 @@ import qualified Data.HashSet as Set import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (awaitRunInThread, - withWorkerQueue) +import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -119,12 +119,17 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) +import Control.Concurrent.STM (STM) +import qualified Control.Monad.STM as STM +import qualified Development.IDE.Session.OrderedSet as S +import qualified Focus import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State +import qualified StmContainers.Map as STM data Log = LogSettingInitialDynFlags @@ -148,10 +153,14 @@ data Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] | LogSessionReloadOnError FilePath ![FilePath] + | LogGetOptionsLoop !FilePath + | LogGetSessionRetry !FilePath deriving instance Show Log instance Pretty Log where pretty = \case + LogGetSessionRetry path -> "Retrying get session for" <+> pretty path + LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files LogSessionNewLoadedFiles files -> @@ -435,14 +444,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + fileToFlags <- STM.newIO :: IO FlagsMap -- Mapping from a Filepath to its 'hie.yaml' location. -- Should hold the same Filepaths as 'fileToFlags', otherwise -- they are inconsistent. So, everywhere you modify 'fileToFlags', -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) + filesMap <- STM.newIO :: IO FilesMap -- Pending files waiting to be loaded - pendingFilesTQueue <- newTQueueIO + pendingFileSet <- S.newIO :: IO (S.OrderedSet FilePath) -- Version of the mappings above version <- newVar 0 biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) @@ -559,7 +568,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,[FilePath]), HashSet FilePath) + -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -589,8 +598,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" ] - void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) + let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs + atomically $ do + STM.insert this_flags_map hieYaml fileToFlags + insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -609,9 +621,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return $ (second Map.keys this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + return $ (this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog @@ -625,7 +637,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ flushTQueue pendingFilesTQueue) + pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ S.toUnOrderedList pendingFileSet) errorFiles <- readIORef error_loading_files old_files <- readIORef cradle_files -- if the file is in error loading files, we fall back to single loading mode @@ -652,18 +664,20 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ((runTime, _):_) | compileTime == runTime -> do (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- put back to pending que if not listed in the results -- delete cfp even if we report No cradle target found for the cfp - let remainPendingFiles = Set.delete cfp $ pendingFiles `Set.difference` allNewLoaded let newLoaded = pendingFiles `Set.intersection` allNewLoaded - atomically $ forM_ remainPendingFiles (writeTQueue pendingFilesTQueue) + -- delete all new loaded + atomically $ forM_ allNewLoaded $ flip S.delete pendingFileSet -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) return results - | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) + | otherwise -> do + -- delete cfp from pending files + atomically $ S.delete cfp pendingFileSet + return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) -- Failure case, either a cradle error or the none cradle Left err -> do if (not $ null extraToLoads) @@ -676,18 +690,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files - atomically $ forM_ pendingFiles (writeTQueue pendingFilesTQueue) logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) consultCradle hieYaml cfp else do - dep_info <- getDependencyInfo (maybeToList hieYaml) + dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml + -- remove cfp from pending files + atomically $ S.delete cfp pendingFileSet + atomically $ do + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags + STM.insert hieYaml ncfp filesMap atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) + return (res, dep_info) let -- | We allow users to specify a loading strategy. @@ -710,21 +725,22 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) + -> IO (IdeResult HscEnvEq, DependencyInfo) sessionOpts (hieYaml, file) = do Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ do + STM.reset filesMap + STM.reset fileToFlags -- Don't even keep the name cache, we start from scratch here! modifyVar_ hscEnvs (const (return Map.empty)) -- cleanup error loading files and cradle files atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags + v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags case HM.lookup (toNormalizedFilePath' file) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di @@ -735,31 +751,77 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) -- If the dependencies are out of date then clear both caches and start -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - modifyVar_ filesMap (const (return HM.empty)) + atomically $ do + STM.reset filesMap + STM.reset fileToFlags -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file - else return (opts, Map.keys old_di) + else return (opts, old_di) Nothing -> consultCradle hieYaml file + let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) + checkInCache ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp filesMap + m <- MaybeT $ STM.lookup cachedHieYamlLocation fileToFlags + MaybeT $ pure $ HM.lookup ncfp m + -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) + let getOptions :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) getOptions file = do let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap + cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - + let hieLoc = join cachedHieYamlLocation <|> hieYaml + result <- sessionOpts (hieLoc, file) `Safe.catch` \e -> do + dep <- getDependencyInfo $ maybe [] pure hieYaml + return (([renderPackageSetupException file e], Nothing), dep) + atomically $ STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp result)) hieLoc fileToFlags + return result + + let getOptionsLoop :: IO () + getOptionsLoop = do + -- Get the next file to load + absFile <- atomically $ S.readQueue pendingFileSet + logWith recorder Info (LogGetOptionsLoop absFile) + void $ getOptions absFile + getOptionsLoop + + let getSessionRetry :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + getSessionRetry absFile = do + let ncfp = toNormalizedFilePath' absFile + -- check if in the cache + res <- atomically $ checkInCache ncfp + logWith recorder Info $ LogGetSessionRetry absFile + updateDateRes <- case res of + Just r -> do + depOk <- checkDependencyInfo (snd r) + if depOk + then return $ Just r + else return Nothing + _ -> return Nothing + case updateDateRes of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ do + S.insert absFile pendingFileSet + atomically $ do + -- wait until pendingFiles is not in pendingFiles + Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + getSessionRetry absFile + + -- Start the getOptionsLoop if the queue is empty + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file - atomically $ writeTQueue pendingFilesTQueue absFile + second Map.keys <$> getSessionRetry absFile + -- atomically $ writeTQueue pendingFiles absFile -- see Note [Serializing runs in separate thread] - awaitRunInThread que $ getOptions absFile + -- awaitRunInThread que $ second Map.keys <$> getOptions absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -1034,10 +1096,11 @@ setCacheDirs recorder CacheDirs{..} dflags = do type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) -- | Maps a Filepath to its respective "hie.yaml" location. -- It aims to be the reverse of 'FlagsMap'. -type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) +type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) + -- This is pristine information about a component data RawComponentInfo = RawComponentInfo diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs new file mode 100644 index 0000000000..e1a5f123c2 --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -0,0 +1,39 @@ +module Development.IDE.Session.OrderedSet where + +import Control.Concurrent.STM (STM, TQueue, newTQueueIO) +import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Data.Hashable (Hashable) +import qualified ListT as LT +import qualified StmContainers.Set as S +import StmContainers.Set (Set) + + +type OrderedSet a = (TQueue a, Set a) + +insert :: Hashable a => a -> OrderedSet a -> STM () +insert a (que, s) = do + S.insert a s + writeTQueue que a + return () + +newIO :: Hashable a => IO (OrderedSet a) +newIO = do + que <- newTQueueIO + s <- S.newIO + return (que, s) + +readQueue :: Hashable a => OrderedSet a -> STM a +readQueue rs@(que, s) = do + f <- readTQueue que + b <- S.lookup f s + -- retry if the file is already in done + if b then return f else readQueue rs + +lookup :: Hashable a => a -> OrderedSet a -> STM Bool +lookup a (_, s) = S.lookup a s + +delete :: Hashable a => a -> OrderedSet a -> STM () +delete a (_, s) = S.delete a s + +toUnOrderedList :: Hashable a => OrderedSet a -> STM [a] +toUnOrderedList (_, s) = LT.toList $ S.listT s From 1f97c401b5aa5cc86c1e52d397bcd91154662a88 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 02:26:23 +0800 Subject: [PATCH 014/107] cleanup --- .../session-loader/Development/IDE/Session.hs | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6cbf6ea370..99ca786506 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -790,8 +790,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do void $ getOptions absFile getOptionsLoop - let getSessionRetry :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) - getSessionRetry absFile = do + -- | Given a file, this function will return the HscEnv and the dependencies + -- it would look up the cache first, if the cache is not available, it would + -- submit a request to the getOptionsLoop to get the options for the file + -- and wait until the options are available + let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + lookupOrWaitCache absFile = do let ncfp = toNormalizedFilePath' absFile -- check if in the cache res <- atomically $ checkInCache ncfp @@ -807,21 +811,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Just r -> return r Nothing -> do -- if not ok, we need to reload the session - atomically $ do - S.insert absFile pendingFileSet - atomically $ do - -- wait until pendingFiles is not in pendingFiles - Extra.whenM (S.lookup absFile pendingFileSet) STM.retry - getSessionRetry absFile + atomically $ S.insert absFile pendingFileSet + -- wait until pendingFiles is not in pendingFiles + atomically $ Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + lookupOrWaitCache absFile + -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file - second Map.keys <$> getSessionRetry absFile - -- atomically $ writeTQueue pendingFiles absFile - -- see Note [Serializing runs in separate thread] - -- awaitRunInThread que $ second Map.keys <$> getOptions absFile + second Map.keys <$> lookupOrWaitCache absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From 4c998bd487e48dcf85abbb14cc58d217c5dafd6a Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 8 Nov 2024 15:24:17 +0800 Subject: [PATCH 015/107] rename LogGetSessionRetry to LogLookupSessionCache for clarity in logging --- ghcide/session-loader/Development/IDE/Session.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 99ca786506..c6d2dcbb84 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -154,12 +154,12 @@ data Log | LogSessionNewLoadedFiles ![FilePath] | LogSessionReloadOnError FilePath ![FilePath] | LogGetOptionsLoop !FilePath - | LogGetSessionRetry !FilePath + | LogLookupSessionCache !FilePath deriving instance Show Log instance Pretty Log where pretty = \case - LogGetSessionRetry path -> "Retrying get session for" <+> pretty path + LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files @@ -799,7 +799,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile -- check if in the cache res <- atomically $ checkInCache ncfp - logWith recorder Info $ LogGetSessionRetry absFile + logWith recorder Info $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do depOk <- checkDependencyInfo (snd r) From 79a43a0cbfa32a226c831a7eb9da0279d9049ab7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 9 Nov 2024 18:34:13 +0800 Subject: [PATCH 016/107] extract attempt to load files from errors --- cabal.project | 5 +++++ ghcide/session-loader/Development/IDE/Session.hs | 8 +++++--- .../session-loader/Development/IDE/Session/Diagnostics.hs | 2 +- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 2c872ed46f..2b46365f1f 100644 --- a/cabal.project +++ b/cabal.project @@ -46,3 +46,8 @@ constraints: if impl(ghc >= 9.9) -- https://github.com/haskell/haskell-language-server/issues/4324 benchmarks: False + +source-repository-package + type: git + location: https://github.com/soulomoon/hie-bios.git + tag: 93582c21372af573e5103bad198777a3317a2df2 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c6d2dcbb84..f3bbc4d899 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -680,17 +680,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) -- Failure case, either a cradle error or the none cradle Left err -> do - if (not $ null extraToLoads) + let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) + `Set.difference` old_files + if (not $ null attemptToLoadFiles) then do -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - let failedLoadingFiles = (Set.insert cfp extraToLoads) `Set.difference` old_files + let failedLoadingFiles = (Set.insert cfp attemptToLoadFiles) atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) -- retry without other files - logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList pendingFiles) + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index a8e35e5965..8b1136c0c8 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,7 +27,7 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp +renderCradleError (CradleError deps _ec ms _attemptToLoadFiles) cradle nfp | HieBios.isCabalCradle cradle = let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) From beb1764608b01d8e659ce38ad914474f98880f50 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 12 Nov 2024 19:53:35 +0800 Subject: [PATCH 017/107] refactor session loading to wait for pending files before cache check --- ghcide/session-loader/Development/IDE/Session.hs | 9 +++++---- .../session-loader/Development/IDE/Session/OrderedSet.hs | 7 ++++--- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f3bbc4d899..c47cb7b381 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -799,8 +799,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) lookupOrWaitCache absFile = do let ncfp = toNormalizedFilePath' absFile - -- check if in the cache - res <- atomically $ checkInCache ncfp + res <- atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + -- check if in the cache + checkInCache ncfp logWith recorder Info $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do @@ -814,8 +817,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet - -- wait until pendingFiles is not in pendingFiles - atomically $ Extra.whenM (S.lookup absFile pendingFileSet) STM.retry lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index e1a5f123c2..ff67abd8b1 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -2,7 +2,9 @@ module Development.IDE.Session.OrderedSet where import Control.Concurrent.STM (STM, TQueue, newTQueueIO) import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Control.Monad (when) import Data.Hashable (Hashable) +import qualified Focus import qualified ListT as LT import qualified StmContainers.Set as S import StmContainers.Set (Set) @@ -12,9 +14,8 @@ type OrderedSet a = (TQueue a, Set a) insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do - S.insert a s - writeTQueue que a - return () + (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s + when inserted $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do From 61395222f11eb3c1751daf437b936f41ef712961 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 19 Nov 2024 05:18:13 +0800 Subject: [PATCH 018/107] add LogTime to logging for improved time tracking during session loading --- .../session-loader/Development/IDE/Session.hs | 58 +++++++++++-------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c47cb7b381..2b75329c1b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -155,10 +155,12 @@ data Log | LogSessionReloadOnError FilePath ![FilePath] | LogGetOptionsLoop !FilePath | LogLookupSessionCache !FilePath + | LogTime !String deriving instance Show Log instance Pretty Log where pretty = \case + LogTime s -> "Time:" <+> pretty s LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp LogSessionReloadOnError path files -> @@ -582,7 +584,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details - newLoaded = HM.keys flags_map' this_dep_info <- getDependencyInfo $ maybeToList hieYaml let (all_targets, this_flags_map, this_options) = case HM.lookup _cfp flags_map' of @@ -599,9 +600,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ] let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs + newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map atomically $ do STM.insert this_flags_map hieYaml fileToFlags insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete pendingFileSet -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -621,9 +624,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return $ (this_options, Set.fromList $ fromNormalizedFilePath <$> newLoaded) + return $ (this_options, newLoaded) - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog @@ -658,32 +661,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do + let ncfp = toNormalizedFilePath' cfp let compileTime = fullCompilerVersion case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (results, allNewLoaded) <- session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- delete cfp even if we report No cradle target found for the cfp + (_results, allNewLoaded) <- session (hieYaml, ncfp, opts, libDir) let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- delete all new loaded - atomically $ forM_ allNewLoaded $ flip S.delete pendingFileSet -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) - return results | otherwise -> do -- delete cfp from pending files - atomically $ S.delete cfp pendingFileSet - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),Map.empty) + atomically $ do + STM.focus (Focus.insertOrMerge HM.union + (HM.singleton ncfp (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty))) + hieYaml fileToFlags + STM.insert hieYaml ncfp filesMap + S.delete cfp pendingFileSet -- Failure case, either a cradle error or the none cradle Left err -> do let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) `Set.difference` old_files if (not $ null attemptToLoadFiles) + then do + -- we are loading more files and failed, we need to retry + -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. @@ -695,16 +702,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do + -- we are only loading this file and it failed dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) -- remove cfp from pending files - atomically $ S.delete cfp pendingFileSet + atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) atomically $ do STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - return (res, dep_info) + STM.insert hieYaml ncfp filesMap + S.delete cfp pendingFileSet let -- | We allow users to specify a loading strategy. @@ -727,7 +734,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, DependencyInfo) + -> IO () sessionOpts (hieYaml, file) = do Extra.whenM didSessionLoadingPreferenceConfigChange $ do logWith recorder Info LogSessionLoadingChanged @@ -744,10 +751,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags case HM.lookup (toNormalizedFilePath' file) v of - Just (opts, old_di) -> do + Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do + when (not deps_ok) $ do -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) @@ -759,7 +765,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file - else return (opts, old_di) Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) @@ -772,24 +777,27 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) + let getOptions :: FilePath -> IO () getOptions file = do let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file let hieLoc = join cachedHieYamlLocation <|> hieYaml - result <- sessionOpts (hieLoc, file) `Safe.catch` \e -> do + sessionOpts (hieLoc, file) `Safe.catch` \e -> do dep <- getDependencyInfo $ maybe [] pure hieYaml - return (([renderPackageSetupException file e], Nothing), dep) - atomically $ STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp result)) hieLoc fileToFlags - return result + let errorResult = (([renderPackageSetupException file e], Nothing), dep) + atomically $ do + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp errorResult)) hieLoc fileToFlags + STM.insert hieYaml ncfp filesMap + -- delete file from pending files + S.delete file pendingFileSet let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load absFile <- atomically $ S.readQueue pendingFileSet logWith recorder Info (LogGetOptionsLoop absFile) - void $ getOptions absFile + getOptions absFile getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From 73145097fbff80f27d7d8d6411411a96de97bf22 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 19 Nov 2024 18:13:49 +0800 Subject: [PATCH 019/107] refactor session loading to handle dependency checks more clearly --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2b75329c1b..02f3988f29 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -753,7 +753,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do case HM.lookup (toNormalizedFilePath' file) v of Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - when (not deps_ok) $ do + if (not deps_ok) + then do -- if deps are old, we can try to load the error files again atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) @@ -765,6 +766,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- Keep the same name cache modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) consultCradle hieYaml file + -- if deps are ok, we can just remove the file from pending files + else atomically $ S.delete file pendingFileSet Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) From cddcc55b9bbe40659ba5e7f25a3584ce20c41c8a Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 20 Nov 2024 07:14:55 +0800 Subject: [PATCH 020/107] Refactors session loading logic Renames getOptions to getOptionsWorker for clarity Removes redundant getOptionsLoop function Ensures session loading is called under the same `Action` context --- ghcide/session-loader/Development/IDE/Session.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 02f3988f29..74eabcc021 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -780,8 +780,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO () - getOptions file = do + let getOptionsWorker :: FilePath -> IO () + getOptionsWorker file = do + logWith recorder Info (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -795,14 +796,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- delete file from pending files S.delete file pendingFileSet - let getOptionsLoop :: IO () - getOptionsLoop = do - -- Get the next file to load - absFile <- atomically $ S.readQueue pendingFileSet - logWith recorder Info (LogGetOptionsLoop absFile) - getOptions absFile - getOptionsLoop - -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file @@ -828,11 +821,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet + -- line up the session to load + atomically $ writeTQueue que (getOptionsWorker absFile) lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty - liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file second Map.keys <$> lookupOrWaitCache absFile From bb78a36f473aa7439203d6e33e71d2b3a9a7fada Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 7 Dec 2024 03:52:07 +0800 Subject: [PATCH 021/107] delay the restart --- .../session-loader/Development/IDE/Session.hs | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 74eabcc021..9b31bb0188 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -570,7 +570,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath) + -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath, IO ()) session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -610,21 +610,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - restartShakeSession VFSUnmodified "new component" [] $ do - keys2 <- invalidateShakeCache - keys1 <- extendKnownTargets all_targets - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return [keys1, keys2] - return $ (this_options, newLoaded) + let restart = restartShakeSession VFSUnmodified "new component" [] $ do + keys2 <- invalidateShakeCache + keys1 <- extendKnownTargets all_targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] + return (this_options, newLoaded, restart) let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do @@ -667,13 +667,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, allNewLoaded) <- session (hieYaml, ncfp, opts, libDir) + (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) let newLoaded = pendingFiles `Set.intersection` allNewLoaded -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) + restart | otherwise -> do -- delete cfp from pending files atomically $ do @@ -782,7 +783,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- before attempting to do so. let getOptionsWorker :: FilePath -> IO () getOptionsWorker file = do - logWith recorder Info (LogGetOptionsLoop file) + logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -808,7 +809,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Extra.whenM (S.lookup absFile pendingFileSet) STM.retry -- check if in the cache checkInCache ncfp - logWith recorder Info $ LogLookupSessionCache absFile + logWith recorder Debug $ LogLookupSessionCache absFile updateDateRes <- case res of Just r -> do depOk <- checkDependencyInfo (snd r) From 58ec7eac149a4504d4084519a97bb3ffa255595b Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 18 Feb 2025 05:16:01 +0800 Subject: [PATCH 022/107] re-inline the old file instead of loading it twice --- ghcide/session-loader/Development/IDE/Session.hs | 16 +++++++++++----- .../Development/IDE/Session/OrderedSet.hs | 14 +++++++++++--- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1b19561c54..3ec7db2e6c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -772,9 +772,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptionsWorker :: FilePath -> IO () - getOptionsWorker file = do - logWith recorder Debug (LogGetOptionsLoop file) + let getOptions :: FilePath -> IO () + getOptions file = do let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap hieYaml <- cradleLoc file @@ -788,6 +787,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- delete file from pending files S.delete file pendingFileSet + let getOptionsLoop :: IO () + getOptionsLoop = do + -- Get the next file to load + absFile <- atomically $ S.readQueue pendingFileSet + logWith recorder Debug (LogGetOptionsLoop absFile) + getOptions absFile + getOptionsLoop + -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file @@ -813,12 +820,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing -> do -- if not ok, we need to reload the session atomically $ S.insert absFile pendingFileSet - -- line up the session to load - atomically $ writeTQueue que (getOptionsWorker absFile) lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop returnWithVersion $ \file -> do let absFile = toAbsolutePath file second Map.keys <$> lookupOrWaitCache absFile diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index ff67abd8b1..a2b0a76565 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -1,6 +1,7 @@ module Development.IDE.Session.OrderedSet where -import Control.Concurrent.STM (STM, TQueue, newTQueueIO) +import Control.Concurrent.STM (STM, TQueue, flushTQueue, + newTQueueIO) import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) import Control.Monad (when) import Data.Hashable (Hashable) @@ -15,7 +16,14 @@ type OrderedSet a = (TQueue a, Set a) insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s - when inserted $ writeTQueue que a + -- if already in the set + -- update the position of the element in the queue + when (not inserted) $ do + items <- filter (==a) <$> flushTQueue que + mapM_ (writeTQueue que) items + return () + writeTQueue que a + -- when que $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do @@ -27,7 +35,7 @@ readQueue :: Hashable a => OrderedSet a -> STM a readQueue rs@(que, s) = do f <- readTQueue que b <- S.lookup f s - -- retry if the file is already in done + -- retry if no files are left in the queue if b then return f else readQueue rs lookup :: Hashable a => a -> OrderedSet a -> STM Bool From d9439637ec7f5ccee4491bb9fb396aef4d3a44f3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 19 Feb 2025 01:05:49 +0800 Subject: [PATCH 023/107] update upload artifact action version --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 659352e4e6..b9d6d49059 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 5d015001976a1562b0f9ca612ab44a494656c081 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 26 Feb 2025 05:01:54 +0800 Subject: [PATCH 024/107] update hie-bios tag --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 2e32d6715f..b45f1ba86d 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/soulomoon/hie-bios.git - tag: 93582c21372af573e5103bad198777a3317a2df2 \ No newline at end of file + tag: 84febb04ba152b03fd42b551ffb2ea6e7506cf9b From 10a6f7e7c69dfc150aff34e0c6cebc37a127eca6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 27 Feb 2025 05:17:54 +0800 Subject: [PATCH 025/107] Update hie-bios tag to latest commit --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index b45f1ba86d..54c46e6eca 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/soulomoon/hie-bios.git - tag: 84febb04ba152b03fd42b551ffb2ea6e7506cf9b + tag: 3351cfc5becee6a09df47df4772598fb2207b746 From 45b124137d7111274bcb06470ed855bb0377b8eb Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 3 Mar 2025 00:18:43 +0800 Subject: [PATCH 026/107] update hie-bios --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 54c46e6eca..794ccb4fb2 100644 --- a/cabal.project +++ b/cabal.project @@ -65,5 +65,5 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git - location: https://github.com/soulomoon/hie-bios.git - tag: 3351cfc5becee6a09df47df4772598fb2207b746 + location: https://github.com/haskell/hie-bios + tag: bc502c94b891719f07e5ada9f6f59ca4ba8e08ff From 219db463049bfac6408f6cde3f9a0b3262a9e059 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 3 Mar 2025 01:19:42 +0800 Subject: [PATCH 027/107] update index-state to reflect the latest project state --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 794ccb4fb2..4c9d2b25e0 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2024-12-02T00:00:00Z +index-state: 2025-03-02T16:10:12Z tests: True test-show-details: direct From 2f86db0b0abd5f86af42ec96a0b2e7f4da077a1f Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 4 Mar 2025 00:13:35 +0800 Subject: [PATCH 028/107] update index-state to reflect the new date --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 4c9d2b25e0..794ccb4fb2 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2025-03-02T16:10:12Z +index-state: 2024-12-02T00:00:00Z tests: True test-show-details: direct From de98232569ab0104b5ad34a7fbf1e49316e63375 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:08:57 +0800 Subject: [PATCH 029/107] update fourmolu dependency version constraints --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index dcbb546733..eece96f992 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1497,7 +1497,7 @@ library hls-fourmolu-plugin build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 + , fourmolu ^>= 0.14 || ^>= 0.15 || >= 0.16 && < 0.16.2 , ghc-boot-th , ghcide == 2.9.0.1 , hls-plugin-api == 2.9.0.1 From f0a881d1a5b24ca648230e53ef63d28c14524a49 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:23:24 +0800 Subject: [PATCH 030/107] remove ListT from library dependencies --- ghcide/ghcide.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3b88a2024c..1468128d9a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -111,7 +111,6 @@ library , unliftio-core , unordered-containers >=0.2.10.0 , vector - , ListT if os(windows) build-depends: Win32 From 14f6a3b93a693e1daf141a2f9172c32509fcb166 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:23:46 +0800 Subject: [PATCH 031/107] update hie-bios to a new tag --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 794ccb4fb2..66fa8a3ff8 100644 --- a/cabal.project +++ b/cabal.project @@ -66,4 +66,4 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) source-repository-package type: git location: https://github.com/haskell/hie-bios - tag: bc502c94b891719f07e5ada9f6f59ca4ba8e08ff + tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 From 8b0e246a9be0f513813ac8728801ecd3b3a81873 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:24:01 +0800 Subject: [PATCH 032/107] update fourmolu dependency version constraints to allow 0.16 --- haskell-language-server.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index eece96f992..dcbb546733 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1497,7 +1497,7 @@ library hls-fourmolu-plugin build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>= 0.14 || ^>= 0.15 || >= 0.16 && < 0.16.2 + , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 , ghc-boot-th , ghcide == 2.9.0.1 , hls-plugin-api == 2.9.0.1 From 2dd71c00f30032d30e339f250c6c334e5a978f29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:34:50 +0800 Subject: [PATCH 033/107] add allow-newer constraint for Cabal-syntax --- cabal.project | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cabal.project b/cabal.project index 66fa8a3ff8..f46df91127 100644 --- a/cabal.project +++ b/cabal.project @@ -63,6 +63,8 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) constraints: ghc-lib-parser==9.8.4.20241130 +allow-newer: + Cabal-syntax source-repository-package type: git location: https://github.com/haskell/hie-bios From b8406d60b991a8d92435405579a77ff6f80bbf5b Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:37:53 +0800 Subject: [PATCH 034/107] remove allow-newer constraint for Cabal-syntax --- cabal.project | 2 -- 1 file changed, 2 deletions(-) diff --git a/cabal.project b/cabal.project index f46df91127..66fa8a3ff8 100644 --- a/cabal.project +++ b/cabal.project @@ -63,8 +63,6 @@ if impl(ghc >= 9.8.4) && impl(ghc < 9.8.5) constraints: ghc-lib-parser==9.8.4.20241130 -allow-newer: - Cabal-syntax source-repository-package type: git location: https://github.com/haskell/hie-bios From 5ea3d87b8ef711949a4fb73eab2472bc21dc19cd Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:50:27 +0800 Subject: [PATCH 035/107] bump actions/checkout and actions/upload-artifact to v3 --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index b9d6d49059..659352e4e6 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v3 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v3 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v3 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v3 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 3e0c27b1de952c84cd4f8598907be79d0be4d735 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 06:53:05 +0800 Subject: [PATCH 036/107] Revert "bump actions/checkout and actions/upload-artifact to v3" This reverts commit 5ea3d87b8ef711949a4fb73eab2472bc21dc19cd. --- .github/workflows/bench.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 659352e4e6..b9d6d49059 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -62,7 +62,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 with: # By default, the `pull_request` event has a `GITHUB_SHA` env variable @@ -101,14 +101,14 @@ jobs: tar -czf cabal.tar.gz * - name: Upload workspace - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 path: workspace.tar.gz - name: Upload .cabal - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} retention-days: 1 @@ -134,13 +134,13 @@ jobs: enable-stack: false - name: Download cabal home - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: cabal-home-${{ matrix.ghc }}-${{ matrix.os }} path: . - name: Download workspace - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: workspace-${{ matrix.ghc }}-${{ matrix.os }} path: . @@ -165,7 +165,7 @@ jobs: run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz - name: Archive benchmarking artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-results-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-artifacts.tar.gz @@ -175,7 +175,7 @@ jobs: run: find bench-results -name "*.log" -or -name "*.hp" | xargs tar -czf benchmark-logs.tar.gz - name: Archive benchmark logs - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: bench-logs-${{ matrix.example }}-${{ runner.os }}-${{ matrix.ghc }} path: benchmark-logs.tar.gz From 8c27e3479bd4ba7fd699ba76396a8f4419d60ce6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 7 Mar 2025 22:21:37 +0800 Subject: [PATCH 037/107] add allow-older constraint for optparse-applicative in cabal.project --- cabal.project | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cabal.project b/cabal.project index 66fa8a3ff8..efc8e3a895 100644 --- a/cabal.project +++ b/cabal.project @@ -67,3 +67,5 @@ source-repository-package type: git location: https://github.com/haskell/hie-bios tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 +-- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 +allow-older: hie-bios:optparse-applicative From b0af63434ea35f4c40911a630f043c4eb51215cf Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 24 Apr 2025 19:03:06 +0800 Subject: [PATCH 038/107] update hie-bios --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index c69496e295..e54c7f4bfe 100644 --- a/cabal.project +++ b/cabal.project @@ -56,7 +56,7 @@ allow-newer: source-repository-package type: git location: https://github.com/haskell/hie-bios - tag: 65df091a4464b43043661d70c1dcfed1ed1fa9a9 + tag: e372a62b780b1314a35238a698a9e3813096b122 -- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 allow-older: hie-bios:optparse-applicative From 06fa5de52bd4b10e28bab42c9c076f409b356d43 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 27 Apr 2025 16:19:26 +0800 Subject: [PATCH 039/107] introduce SessionState --- .../session-loader/Development/IDE/Session.hs | 259 ++++++++++++------ 1 file changed, 173 insertions(+), 86 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fd50fa5bc0..76d10c9d66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -418,6 +418,125 @@ getHieDbLoc dir = do createDirectoryIfMissing True cDir pure (cDir db) +data SessionState = SessionState + { cradle_files :: !(IORef (HashSet FilePath)) + , error_loading_files :: !(IORef (HashSet FilePath)) + , hscEnvs :: !(Var HieMap) + , fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))) + , filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)) + , pendingFileSet :: !(S.OrderedSet FilePath) + , version :: !(Var Int) + } + +-- | Helper functions for SessionState management +-- These functions encapsulate common operations on the SessionState + +-- | Add a file to the set of files with errors during loading +addErrorLoadingFile :: SessionState -> FilePath -> IO () +addErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.insert file xs, ())) + +addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () +addErrorLoadingFiles = mapM_ . addErrorLoadingFile + +-- | Remove a file from the set of files with errors during loading +removeErrorLoadingFile :: SessionState -> FilePath -> IO () +removeErrorLoadingFile state file = + atomicModifyIORef' (error_loading_files state) (\xs -> (Set.delete file xs, ())) + +addCradleFiles :: SessionState -> HashSet FilePath -> IO () +addCradleFiles state files = + atomicModifyIORef' (cradle_files state) (\xs -> (files <> xs, ())) + +-- | Remove a file from the cradle files set +removeCradleFile :: SessionState -> FilePath -> IO () +removeCradleFile state file = + atomicModifyIORef' (cradle_files state) (\xs -> (Set.delete file xs, ())) + +-- | Clear error loading files and reset to empty set +clearErrorLoadingFiles :: SessionState -> IO () +clearErrorLoadingFiles state = + atomicModifyIORef' (error_loading_files state) (\_ -> (Set.empty, ())) + +-- | Clear cradle files and reset to empty set +clearCradleFiles :: SessionState -> IO () +clearCradleFiles state = + atomicModifyIORef' (cradle_files state) (\_ -> (Set.empty, ())) + +-- | Reset the file maps in the session state +resetFileMaps :: SessionState -> STM () +resetFileMaps state = do + STM.reset (filesMap state) + STM.reset (fileToFlags state) + +-- | Insert or update file flags for a specific hieYaml and normalized file path +insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM () +insertFileFlags state hieYaml ncfp flags = + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state) + +-- | Insert a file mapping from normalized path to hieYaml location +insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMapping state hieYaml ncfp = + STM.insert hieYaml ncfp (filesMap state) + +-- | Remove a file from the pending file set +removeFromPending :: SessionState -> FilePath -> STM () +removeFromPending state file = + S.delete file (pendingFileSet state) + +-- | Add a file to the pending file set +addToPending :: SessionState -> FilePath -> STM () +addToPending state file = + S.insert file (pendingFileSet state) + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +completeFileProcessing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> FilePath -> (IdeResult HscEnvEq, DependencyInfo) -> IO () +completeFileProcessing state hieYaml ncfp file flags = do +-- remove cfp from pending files + addErrorLoadingFile state file + removeCradleFile state file + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + removeFromPending state file + +-- | Insert multiple file mappings at once +insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () +insertAllFileMappings state mappings = + mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings + +-- | Increment the version counter +incrementVersion :: SessionState -> IO Int +incrementVersion state = modifyVar' (version state) succ + +-- | Get files from the pending file set +getPendingFiles :: SessionState -> IO (HashSet FilePath) +getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFileSet state) + +-- | Handle errors during session loading by recording file as having error and removing from pending +handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSessionError state hieYaml file e = do + dep <- getDependencyInfo $ maybe [] pure hieYaml + let ncfp = toNormalizedFilePath' file + let errorResult = (([renderPackageSetupException file e], Nothing), dep) + completeFileProcessing state hieYaml ncfp file errorResult + +-- | Get the set of extra files to load based on the current file path +-- If the current file is in error loading files, we fallback to single loading mode (empty set) +-- Otherwise, we remove error files from pending files and also exclude the current file +getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] +getExtraFilesToLoad state cfp = do + pendingFiles <- getPendingFiles state + errorFiles <- readIORef (error_loading_files state) + old_files <- readIORef (cradle_files state) + -- if the file is in error loading files, we fall back to single loading mode + return $ + Set.toList $ + if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -435,23 +554,20 @@ getHieDbLoc dir = do loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - cradle_files <- newIORef (Set.fromList []) - error_loading_files <- newIORef (Set.fromList []) - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- STM.newIO :: IO FlagsMap - -- Mapping from a Filepath to its 'hie.yaml' location. - -- Should hold the same Filepaths as 'fileToFlags', otherwise - -- they are inconsistent. So, everywhere you modify 'fileToFlags', - -- you have to modify 'filesMap' as well. - filesMap <- STM.newIO :: IO FilesMap - -- Pending files waiting to be loaded - pendingFileSet <- S.newIO :: IO (S.OrderedSet FilePath) - -- Version of the mappings above - version <- newVar 0 + + -- Initialize SessionState + sessionState <- SessionState + <$> newIORef (Set.fromList []) -- cradle_files + <*> newIORef (Set.fromList []) -- error_loading_files + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> S.newIO -- pendingFileSet + <*> newVar 0 -- version + biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) + -- This caches the mapping from Mod.hs -> hie.yaml cradleLoc <- liftIO $ memoIO $ \v -> do res <- findCradle v @@ -466,7 +582,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras let invalidateShakeCache = do - void $ modifyVar' version succ + void $ incrementVersion sessionState return $ toNoFileKey GhcSessionIO IdeOptions{ optTesting = IdeTesting optTesting @@ -523,7 +639,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do + modifyVar (hscEnvs sessionState) $ \m -> do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv let oldDeps = Map.lookup hieYaml m @@ -594,12 +710,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - let insertAll m xs = mapM_ (flip (uncurry STM.insert) m) xs - newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map atomically $ do - STM.insert this_flags_map hieYaml fileToFlags - insertAll filesMap $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete pendingFileSet + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -635,19 +750,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - pendingFiles <- Set.insert cfp . Set.fromList <$> (atomically $ S.toUnOrderedList pendingFileSet) - errorFiles <- readIORef error_loading_files - old_files <- readIORef cradle_files - -- if the file is in error loading files, we fall back to single loading mode - let extraToLoads = if cfp `Set.member` errorFiles - then Set.empty - -- remove error files from pending files since error loading need to load one by one - else Set.delete cfp $ pendingFiles `Set.difference` errorFiles - + extraToLoads <- getExtraFilesToLoad sessionState cfp eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp (Set.toList $ Set.delete cfp $ extraToLoads <> old_files) + res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp extraToLoads addTag "result" (show res) return res @@ -663,51 +770,42 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ((runTime, _):_) | compileTime == runTime -> do (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + pendingFiles <- getPendingFiles sessionState let newLoaded = pendingFiles `Set.intersection` allNewLoaded -- log new loaded files logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files - atomicModifyIORef' error_loading_files (\old -> (old `Set.difference` allNewLoaded, ())) - atomicModifyIORef' cradle_files (\xs -> (newLoaded <> xs,())) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) + addCradleFiles sessionState newLoaded restart | otherwise -> do - -- delete cfp from pending files - atomically $ do - STM.focus (Focus.insertOrMerge HM.union - (HM.singleton ncfp (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty))) - hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - S.delete cfp pendingFileSet + -- Use the common pattern here: updateFileState + completeFileProcessing sessionState hieYaml ncfp cfp + (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty) -- Failure case, either a cradle error or the none cradle Left err -> do - let attemptToLoadFiles = (Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err) - `Set.difference` old_files - if (not $ null attemptToLoadFiles) - + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- readIORef (cradle_files sessionState) + let errorToLoadNewFiles = attemptToLoadFiles `Set.difference` old_files + if not (null errorToLoadNewFiles) then do -- we are loading more files and failed, we need to retry - -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - let failedLoadingFiles = (Set.insert cfp attemptToLoadFiles) - atomicModifyIORef' error_loading_files (\xs -> (failedLoadingFiles <> xs,())) + addErrorLoadingFiles sessionState (Set.toList errorToLoadNewFiles) -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp else do -- we are only loading this file and it failed - dep_info <- getDependencyInfo ((maybeToList hieYaml) ++ concatMap cradleErrorDependencies err) + dep_info <- getDependencyInfo (maybeToList hieYaml ++ concatMap cradleErrorDependencies err) let ncfp = toNormalizedFilePath' cfp let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - -- remove cfp from pending files - atomicModifyIORef' error_loading_files (\xs -> (Set.insert cfp xs,())) - atomically $ do - STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp (res, dep_info))) hieYaml fileToFlags - STM.insert hieYaml ncfp filesMap - S.delete cfp pendingFileSet + completeFileProcessing sessionState hieYaml ncfp cfp (res, dep_info) let -- | We allow users to specify a loading strategy. @@ -736,40 +834,36 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ do - STM.reset filesMap - STM.reset fileToFlags + atomically $ resetFileMaps sessionState -- Don't even keep the name cache, we start from scratch here! - modifyVar_ hscEnvs (const (return Map.empty)) + modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) -- cleanup error loading files and cradle files - atomicModifyIORef' error_loading_files (\_ -> (Set.empty,())) - atomicModifyIORef' cradle_files (\_ -> (Set.empty,())) + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState - v <- atomically $ fromMaybe HM.empty <$> STM.lookup hieYaml fileToFlags - case HM.lookup (toNormalizedFilePath' file) v of + v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of Just (_opts, old_di) -> do deps_ok <- checkDependencyInfo old_di - if (not deps_ok) + if not deps_ok then do -- if deps are old, we can try to load the error files again - atomicModifyIORef' error_loading_files (\xs -> (Set.delete file xs,())) - atomicModifyIORef' cradle_files (\xs -> (Set.delete file xs,())) + removeErrorLoadingFile sessionState file + removeCradleFile sessionState file -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ do - STM.reset filesMap - STM.reset fileToFlags + atomically $ resetFileMaps sessionState -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml ) + modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) consultCradle hieYaml file -- if deps are ok, we can just remove the file from pending files - else atomically $ S.delete file pendingFileSet + else atomically $ removeFromPending sessionState file Nothing -> consultCradle hieYaml file let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) checkInCache ncfp = runMaybeT $ do - cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp filesMap - m <- MaybeT $ STM.lookup cachedHieYamlLocation fileToFlags + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) MaybeT $ pure $ HM.lookup ncfp m -- The main function which gets options for a file. We only want one of these running @@ -779,22 +873,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let getOptions :: FilePath -> IO () getOptions file = do let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- atomically $ STM.lookup ncfp filesMap + cachedHieYamlLocation <- atomically $ STM.lookup ncfp (filesMap sessionState) hieYaml <- cradleLoc file let hieLoc = join cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` \e -> do - dep <- getDependencyInfo $ maybe [] pure hieYaml - let errorResult = (([renderPackageSetupException file e], Nothing), dep) - atomically $ do - STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp errorResult)) hieLoc fileToFlags - STM.insert hieYaml ncfp filesMap - -- delete file from pending files - S.delete file pendingFileSet + sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - absFile <- atomically $ S.readQueue pendingFileSet + absFile <- atomically $ S.readQueue (pendingFileSet sessionState) logWith recorder Debug (LogGetOptionsLoop absFile) getOptions absFile getOptionsLoop @@ -808,7 +895,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile res <- atomically $ do -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile pendingFileSet) STM.retry + Extra.whenM (S.lookup absFile (pendingFileSet sessionState)) STM.retry -- check if in the cache checkInCache ncfp logWith recorder Debug $ LogLookupSessionCache absFile @@ -823,7 +910,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Just r -> return r Nothing -> do -- if not ok, we need to reload the session - atomically $ S.insert absFile pendingFileSet + atomically $ addToPending sessionState absFile lookupOrWaitCache absFile -- see Note [Serializing runs in separate thread] From 80d016094abba178ecff317b186bfe3c52517c43 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 27 Apr 2025 22:45:14 +0800 Subject: [PATCH 040/107] update hiebois --- cabal.project | 9 +----- ghcide/ghcide.cabal | 2 +- .../session-loader/Development/IDE/Session.hs | 32 +++++++++++-------- 3 files changed, 21 insertions(+), 22 deletions(-) diff --git a/cabal.project b/cabal.project index e54c7f4bfe..59f565677b 100644 --- a/cabal.project +++ b/cabal.project @@ -8,7 +8,7 @@ packages: ./hls-test-utils -index-state: 2025-04-19T07:34:07Z +index-state: 2025-04-26T07:34:07Z tests: True test-show-details: direct @@ -53,13 +53,6 @@ allow-newer: cabal-install-parsers:Cabal-syntax, -source-repository-package - type: git - location: https://github.com/haskell/hie-bios - tag: e372a62b780b1314a35238a698a9e3813096b122 --- see https://github.com/haskell/haskell-language-server/pull/4445#issuecomment-2705787655 -allow-older: hie-bios:optparse-applicative - if impl(ghc >= 9.11) benchmarks: False allow-newer: diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0ae7b15ce9..eed0ed5919 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -73,7 +73,7 @@ library , Glob , haddock-library >=1.8 && <1.12 , hashable - , hie-bios ^>=0.14.0 + , hie-bios ^>=0.15.0 , hie-compat ^>=0.3.0.0 , hiedb ^>= 0.6.0.2 , hls-graph == 2.10.0.0 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 76d10c9d66..a153e15119 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -500,6 +500,23 @@ completeFileProcessing state hieYaml ncfp file flags = do insertFileMapping state hieYaml ncfp removeFromPending state file +-- | Handle successful loading by updating session state with the new file maps +updateSessionOnSuccess :: Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> [TargetDetails] -> IO () +updateSessionOnSuccess recorder state hieYaml this_flags_map all_targets = do + let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags state) + insertAllFileMappings state $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet state) + pendingFiles <- getPendingFiles state + let newLoaded = pendingFiles `Set.intersection` newLoaded + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile state) (Set.toList newLoaded) + addCradleFiles state newLoaded + return () + -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -711,11 +728,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) - + updateSessionOnSuccess recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -769,14 +782,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) - pendingFiles <- getPendingFiles sessionState - let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) - addCradleFiles sessionState newLoaded + (_results, _allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) restart | otherwise -> do -- Use the common pattern here: updateFileState From 24269f6e085d1edda2c2d5c3131c3e4282ab760e Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 18:00:58 +0800 Subject: [PATCH 041/107] revert --- .../session-loader/Development/IDE/Session.hs | 32 ++++++++----------- 1 file changed, 13 insertions(+), 19 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a153e15119..76d10c9d66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -500,23 +500,6 @@ completeFileProcessing state hieYaml ncfp file flags = do insertFileMapping state hieYaml ncfp removeFromPending state file --- | Handle successful loading by updating session state with the new file maps -updateSessionOnSuccess :: Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> [TargetDetails] -> IO () -updateSessionOnSuccess recorder state hieYaml this_flags_map all_targets = do - let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags state) - insertAllFileMappings state $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet state) - pendingFiles <- getPendingFiles state - let newLoaded = pendingFiles `Set.intersection` newLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile state) (Set.toList newLoaded) - addCradleFiles state newLoaded - return () - -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -728,7 +711,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Nothing let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map - updateSessionOnSuccess recorder sessionState hieYaml this_flags_map all_targets + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + -- Typecheck all files in the project on startup checkProject <- getCheckProject -- The VFS doesn't change on cradle edits, re-use the old one. @@ -782,7 +769,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> do - (_results, _allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) + pendingFiles <- getPendingFiles sessionState + let newLoaded = pendingFiles `Set.intersection` allNewLoaded + -- log new loaded files + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) + addCradleFiles sessionState newLoaded restart | otherwise -> do -- Use the common pattern here: updateFileState From 98999f55b674cfcd5cd649f180f9f45366b8e5dc Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 19:20:10 +0800 Subject: [PATCH 042/107] restart the shake if cabal file changed --- .../session-loader/Development/IDE/Session.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 76d10c9d66..96c1016399 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -840,6 +840,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- cleanup error loading files and cradle files clearErrorLoadingFiles sessionState clearCradleFiles sessionState + cacheKey <- invalidateShakeCache + restartShakeSession VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) case v >>= HM.lookup (toNormalizedFilePath' file) of @@ -870,20 +872,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. - let getOptions :: FilePath -> IO () - getOptions file = do - let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- atomically $ STM.lookup ncfp (filesMap sessionState) - hieYaml <- cradleLoc file - let hieLoc = join cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - absFile <- atomically $ S.readQueue (pendingFileSet sessionState) - logWith recorder Debug (LogGetOptionsLoop absFile) - getOptions absFile + file <- atomically $ S.readQueue (pendingFileSet sessionState) + logWith recorder Debug (LogGetOptionsLoop file) + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) + hieYaml <- cradleLoc file + let hieLoc = cachedHieYamlLocation <|> hieYaml + sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From 21dd23314329a989dd5069817c51549a3f761888 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:30:05 +0800 Subject: [PATCH 043/107] better error handling in session loader --- .../session-loader/Development/IDE/Session.hs | 65 +++++++++---------- 1 file changed, 29 insertions(+), 36 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 96c1016399..738af0944a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -489,16 +489,6 @@ addToPending :: SessionState -> FilePath -> STM () addToPending state file = S.insert file (pendingFileSet state) --- | Common pattern: Insert file flags, insert file mapping, and remove from pending -completeFileProcessing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> FilePath -> (IdeResult HscEnvEq, DependencyInfo) -> IO () -completeFileProcessing state hieYaml ncfp file flags = do --- remove cfp from pending files - addErrorLoadingFile state file - removeCradleFile state file - atomically $ do - insertFileFlags state hieYaml ncfp flags - insertFileMapping state hieYaml ncfp - removeFromPending state file -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () @@ -516,10 +506,20 @@ getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pending -- | Handle errors during session loading by recording file as having error and removing from pending handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () handleSessionError state hieYaml file e = do - dep <- getDependencyInfo $ maybe [] pure hieYaml + handleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () +handleFileProcessingError state hieYaml file diags extraDepFiles = do + addErrorLoadingFile state file + removeCradleFile state file + dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file - let errorResult = (([renderPackageSetupException file e], Nothing), dep) - completeFileProcessing state hieYaml ncfp file errorResult + let flags = ((diags, Nothing), dep) + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + removeFromPending state file -- | Get the set of extra files to load based on the current file path -- If the current file is in error loading files, we fallback to single loading mode (empty set) @@ -679,8 +679,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ((IdeResult HscEnvEq,DependencyInfo), HashSet FilePath, IO ()) + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> IO () session args@(hieYaml, _cfp, _opts, _libDir) = do (new_deps, old_deps) <- packageSetup args @@ -695,7 +694,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, this_options) + let (all_targets, this_flags_map, _this_options) = case HM.lookup _cfp flags_map' of Just this -> (all_targets', flags_map', this) Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) @@ -710,17 +709,24 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - let newLoaded = Set.fromList $ fromNormalizedFilePath <$> HM.keys this_flags_map + pendingFiles <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendingFiles `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + -- remove all new loaded file from error loading files + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded -- Typecheck all files in the project on startup checkProject <- getCheckProject + -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - let restart = restartShakeSession VFSUnmodified "new component" [] $ do + restartShakeSession VFSUnmodified "new component" [] $ do keys2 <- invalidateShakeCache keys1 <- extendKnownTargets all_targets unless (null new_deps || not checkProject) $ do @@ -734,7 +740,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] - return (this_options, newLoaded, restart) let consultCradle :: Maybe FilePath -> FilePath -> IO () consultCradle hieYaml cfp = do @@ -759,29 +764,19 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return res logWith recorder Debug $ LogSessionLoadingResult eopts + let ncfp = toNormalizedFilePath' cfp case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. Right (opts, libDir, version) -> do - let ncfp = toNormalizedFilePath' cfp let compileTime = fullCompilerVersion case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) - | compileTime == runTime -> do - (_results, allNewLoaded, restart) <- session (hieYaml, ncfp, opts, libDir) - pendingFiles <- getPendingFiles sessionState - let newLoaded = pendingFiles `Set.intersection` allNewLoaded - -- log new loaded files - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList allNewLoaded) - addCradleFiles sessionState newLoaded - restart + | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) | otherwise -> do -- Use the common pattern here: updateFileState - completeFileProcessing sessionState hieYaml ncfp cfp - (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing), mempty) + handleFileProcessingError sessionState hieYaml cfp [renderPackageSetupException cfp GhcVersionMismatch{..}] mempty -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? @@ -802,10 +797,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do consultCradle hieYaml cfp else do -- we are only loading this file and it failed - dep_info <- getDependencyInfo (maybeToList hieYaml ++ concatMap cradleErrorDependencies err) - let ncfp = toNormalizedFilePath' cfp - let res = (map (\err' -> renderCradleError err' cradle ncfp) err, Nothing) - completeFileProcessing sessionState hieYaml ncfp cfp (res, dep_info) + let res = map (\err' -> renderCradleError err' cradle ncfp) err + handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err let -- | We allow users to specify a loading strategy. From f140a2afc3a19f1e56babc1dd6e9a4a5b627ea7a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:37:10 +0800 Subject: [PATCH 044/107] refactor error handling in loadSessionWithOptions to improve clarity and logic --- ghcide/session-loader/Development/IDE/Session.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 738af0944a..caa8bec577 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -782,8 +782,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err old_files <- readIORef (cradle_files sessionState) - let errorToLoadNewFiles = attemptToLoadFiles `Set.difference` old_files - if not (null errorToLoadNewFiles) + let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) + if length errorToLoadNewFiles > 1 then do -- we are loading more files and failed, we need to retry -- mark as less loaded files as failedLoadingFiles as possible @@ -791,7 +791,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to error_loading_files. -- And make other files failed to load in batch mode. - addErrorLoadingFiles sessionState (Set.toList errorToLoadNewFiles) + addErrorLoadingFiles sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp From e339c1d3e4869aebd104cc9b0dadb80aba03ae13 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 28 Apr 2025 23:54:37 +0800 Subject: [PATCH 045/107] refactor SessionState management for improved batch loading logic --- .../session-loader/Development/IDE/Session.hs | 93 ++++++++++++------- 1 file changed, 58 insertions(+), 35 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index caa8bec577..3f20e93fc1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -418,14 +418,33 @@ getHieDbLoc dir = do createDirectoryIfMissing True cDir pure (cDir db) +{- Note [SessionState and batch load] +SessionState manages the state for batch loading files in the session loader. + +- When a new file needs to be loaded, it is added to the pendingFiles set. +- The loader processes files from pendingFiles, attempting to load them in batches. +- If a file is already in failedFiles, it is loaded individually (single-file mode). +- Otherwise, the loader tries to load as many files as possible together (batch mode). + +On success: + - All successfully loaded files are removed from pendingFiles and failedFiles, + and added to loadedFiles. + +On failure: + - If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. + - If batch loading fails, all files attempted are added to failedFiles. + +This approach ensures efficient batch loading while isolating problematic files for individual handling. +-} + data SessionState = SessionState - { cradle_files :: !(IORef (HashSet FilePath)) - , error_loading_files :: !(IORef (HashSet FilePath)) - , hscEnvs :: !(Var HieMap) - , fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))) - , filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)) - , pendingFileSet :: !(S.OrderedSet FilePath) - , version :: !(Var Int) + { loadedFiles :: !(IORef (HashSet FilePath)), + failedFiles :: !(IORef (HashSet FilePath)), + pendingFiles :: !(S.OrderedSet FilePath), + hscEnvs :: !(Var HieMap), + fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))), + filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)), + version :: !(Var Int) } -- | Helper functions for SessionState management @@ -434,7 +453,7 @@ data SessionState = SessionState -- | Add a file to the set of files with errors during loading addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = - atomicModifyIORef' (error_loading_files state) (\xs -> (Set.insert file xs, ())) + atomicModifyIORef' (failedFiles state) (\xs -> (Set.insert file xs, ())) addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () addErrorLoadingFiles = mapM_ . addErrorLoadingFile @@ -442,26 +461,26 @@ addErrorLoadingFiles = mapM_ . addErrorLoadingFile -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = - atomicModifyIORef' (error_loading_files state) (\xs -> (Set.delete file xs, ())) + atomicModifyIORef' (failedFiles state) (\xs -> (Set.delete file xs, ())) addCradleFiles :: SessionState -> HashSet FilePath -> IO () addCradleFiles state files = - atomicModifyIORef' (cradle_files state) (\xs -> (files <> xs, ())) + atomicModifyIORef' (loadedFiles state) (\xs -> (files <> xs, ())) -- | Remove a file from the cradle files set removeCradleFile :: SessionState -> FilePath -> IO () removeCradleFile state file = - atomicModifyIORef' (cradle_files state) (\xs -> (Set.delete file xs, ())) + atomicModifyIORef' (loadedFiles state) (\xs -> (Set.delete file xs, ())) -- | Clear error loading files and reset to empty set clearErrorLoadingFiles :: SessionState -> IO () clearErrorLoadingFiles state = - atomicModifyIORef' (error_loading_files state) (\_ -> (Set.empty, ())) + atomicModifyIORef' (failedFiles state) (\_ -> (Set.empty, ())) -- | Clear cradle files and reset to empty set clearCradleFiles :: SessionState -> IO () clearCradleFiles state = - atomicModifyIORef' (cradle_files state) (\_ -> (Set.empty, ())) + atomicModifyIORef' (loadedFiles state) (\_ -> (Set.empty, ())) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -482,12 +501,12 @@ insertFileMapping state hieYaml ncfp = -- | Remove a file from the pending file set removeFromPending :: SessionState -> FilePath -> STM () removeFromPending state file = - S.delete file (pendingFileSet state) + S.delete file (pendingFiles state) -- | Add a file to the pending file set addToPending :: SessionState -> FilePath -> STM () addToPending state file = - S.insert file (pendingFileSet state) + S.insert file (pendingFiles state) -- | Insert multiple file mappings at once @@ -501,7 +520,7 @@ incrementVersion state = modifyVar' (version state) succ -- | Get files from the pending file set getPendingFiles :: SessionState -> IO (HashSet FilePath) -getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFileSet state) +getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () @@ -527,8 +546,8 @@ handleFileProcessingError state hieYaml file diags extraDepFiles = do getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] getExtraFilesToLoad state cfp = do pendingFiles <- getPendingFiles state - errorFiles <- readIORef (error_loading_files state) - old_files <- readIORef (cradle_files state) + errorFiles <- readIORef (failedFiles state) + old_files <- readIORef (loadedFiles state) -- if the file is in error loading files, we fall back to single loading mode return $ Set.toList $ @@ -537,6 +556,19 @@ getExtraFilesToLoad state cfp = do -- remove error files from pending files since error loading need to load one by one else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files +newSessionState :: IO SessionState +newSessionState = do + -- Initialize SessionState + sessionState <- SessionState + <$> newIORef (Set.fromList []) -- loadedFiles + <*> newIORef (Set.fromList []) -- failedFiles + <*> S.newIO -- pendingFiles + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> newVar 0 -- version + return sessionState + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -555,16 +587,7 @@ loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions - loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] - -- Initialize SessionState - sessionState <- SessionState - <$> newIORef (Set.fromList []) -- cradle_files - <*> newIORef (Set.fromList []) -- error_loading_files - <*> newVar Map.empty -- hscEnvs - <*> STM.newIO -- fileToFlags - <*> STM.newIO -- filesMap - <*> S.newIO -- pendingFileSet - <*> newVar 0 -- version - + sessionState <- newSessionState biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) @@ -709,13 +732,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - pendingFiles <- getPendingFiles sessionState + pendings <- getPendingFiles sessionState -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendingFiles `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFileSet sessionState) + forM_ newLoaded $ flip S.delete (pendingFiles sessionState) logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded -- remove all new loaded file from error loading files @@ -781,7 +804,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readIORef (cradle_files sessionState) + old_files <- readIORef (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do @@ -789,7 +812,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- mark as less loaded files as failedLoadingFiles as possible -- limitation is that when we are loading files, and the dependencies of old_files -- are changed, and old_files are not valid anymore. - -- but they will still be in the old_files, and will not move to error_loading_files. + -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. addErrorLoadingFiles sessionState errorToLoadNewFiles -- retry without other files @@ -869,7 +892,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let getOptionsLoop :: IO () getOptionsLoop = do -- Get the next file to load - file <- atomically $ S.readQueue (pendingFileSet sessionState) + file <- atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) @@ -887,7 +910,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let ncfp = toNormalizedFilePath' absFile res <- atomically $ do -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile (pendingFileSet sessionState)) STM.retry + Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry -- check if in the cache checkInCache ncfp logWith recorder Debug $ LogLookupSessionCache absFile From 1425289cc8fa2ece6b6382e2fb56f76a9eb692d7 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 29 Apr 2025 00:13:18 +0800 Subject: [PATCH 046/107] refactor session loading error handling for improved clarity and separation of concerns --- .../session-loader/Development/IDE/Session.hs | 39 ++++++++++++------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3f20e93fc1..7f10528e86 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -122,7 +122,6 @@ import Control.Concurrent.STM (STM) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus -import GHC.Data.Bag import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, @@ -423,20 +422,37 @@ SessionState manages the state for batch loading files in the session loader. - When a new file needs to be loaded, it is added to the pendingFiles set. - The loader processes files from pendingFiles, attempting to load them in batches. -- If a file is already in failedFiles, it is loaded individually (single-file mode). -- Otherwise, the loader tries to load as many files as possible together (batch mode). +- (SBL1) If a file is already in failedFiles, it is loaded individually (single-file mode). +- (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode). On success: - - All successfully loaded files are removed from pendingFiles and failedFiles, + - (SBL3) All successfully loaded files are removed from pendingFiles and failedFiles, and added to loadedFiles. On failure: - - If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. - - If batch loading fails, all files attempted are added to failedFiles. + - (SBL4) If loading a single file fails, it is added to failedFiles and removed from loadedFiles and pendingFiles. + - (SBL5) If batch loading fails, all files attempted are added to failedFiles. This approach ensures efficient batch loading while isolating problematic files for individual handling. -} +handleLoadingSucc :: SessionState -> HashSet FilePath -> IO () +handleLoadingSucc sessionState files = do + atomically $ forM_ (Set.toList files) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList files) + addCradleFiles sessionState files + +handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () +handleLoadingFailureBatch sessionState files = do + addErrorLoadingFiles sessionState files + +handleLoadingFailureSingle :: SessionState -> FilePath -> IO () +handleLoadingFailureSingle sessionState file = do + addErrorLoadingFile sessionState file + removeErrorLoadingFile sessionState file + atomically $ S.delete file (pendingFiles sessionState) + removeCradleFile sessionState file + data SessionState = SessionState { loadedFiles :: !(IORef (HashSet FilePath)), failedFiles :: !(IORef (HashSet FilePath)), @@ -530,15 +546,13 @@ handleSessionError state hieYaml file e = do -- | Common pattern: Insert file flags, insert file mapping, and remove from pending handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () handleFileProcessingError state hieYaml file diags extraDepFiles = do - addErrorLoadingFile state file - removeCradleFile state file dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) + handleLoadingFailureSingle state file atomically $ do insertFileFlags state hieYaml ncfp flags insertFileMapping state hieYaml ncfp - removeFromPending state file -- | Get the set of extra files to load based on the current file path -- If the current file is in error loading files, we fallback to single loading mode (empty set) @@ -738,12 +752,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - forM_ newLoaded $ flip S.delete (pendingFiles sessionState) logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - -- remove all new loaded file from error loading files - mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) - addCradleFiles sessionState newLoaded + handleLoadingSucc sessionState newLoaded -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -814,7 +825,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. - addErrorLoadingFiles sessionState errorToLoadNewFiles + handleLoadingFailureBatch sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) consultCradle hieYaml cfp From de6eb9cefebdf27a5487d6251c79b8132a449c79 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 16:39:37 +0800 Subject: [PATCH 047/107] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7f10528e86..483487c552 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -454,13 +454,13 @@ handleLoadingFailureSingle sessionState file = do removeCradleFile sessionState file data SessionState = SessionState - { loadedFiles :: !(IORef (HashSet FilePath)), - failedFiles :: !(IORef (HashSet FilePath)), + { loadedFiles :: !(IORef (HashSet FilePath)), + failedFiles :: !(IORef (HashSet FilePath)), pendingFiles :: !(S.OrderedSet FilePath), - hscEnvs :: !(Var HieMap), - fileToFlags :: !(STM.Map (Maybe FilePath) (HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))), - filesMap :: !(STM.Map NormalizedFilePath (Maybe FilePath)), - version :: !(Var Int) + hscEnvs :: !(Var HieMap), + fileToFlags :: !FlagsMap, + filesMap :: !FilesMap, + version :: !(Var Int) } -- | Helper functions for SessionState management From c9926d43536cf576521d19dd86d600427e2e2aba Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 16:56:00 +0800 Subject: [PATCH 048/107] fix --- .../session-loader/Development/IDE/Session.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7b574a492f..597d7cffaf 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -893,13 +893,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do checkInCache ncfp = runMaybeT $ do cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) - -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action - -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. - -- The GlobPattern of a FileSystemWatcher can be absolute or relative. - -- We use the absolute one because it is supported by more LSP clients. - -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern. - let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath deps) - MaybeT $ pure $ absolutePathsCradleDeps <$> HM.lookup ncfp m + MaybeT $ pure $ HM.lookup ncfp m -- The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try @@ -947,9 +941,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop + + -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action + -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. + -- The GlobPattern of a FileSystemWatcher can be absolute or relative. + -- We use the absolute one because it is supported by more LSP clients. + -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern. + let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) returnWithVersion $ \file -> do let absFile = toAbsolutePath file - second Map.keys <$> lookupOrWaitCache absFile + absolutePathsCradleDeps <$> lookupOrWaitCache absFile -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From 48a46d1d084eb295383ebc040a8d68c46556edd9 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 8 May 2025 17:27:50 +0800 Subject: [PATCH 049/107] add sessionLoadingPreferenceConfig var to SessionState --- .../session-loader/Development/IDE/Session.hs | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 597d7cffaf..87edfc0513 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -78,7 +78,8 @@ import Ide.Logger (Pretty (pretty), nest, toCologActionWithPrio, vcat, viaShow, (<+>)) -import Ide.Types (SessionLoadingPreferenceConfig (..), +import Ide.Types (Config, + SessionLoadingPreferenceConfig (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -460,7 +461,8 @@ data SessionState = SessionState hscEnvs :: !(Var HieMap), fileToFlags :: !FlagsMap, filesMap :: !FilesMap, - version :: !(Var Int) + version :: !(Var Int), + sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig)) } -- | Helper functions for SessionState management @@ -570,6 +572,24 @@ getExtraFilesToLoad state cfp = do -- remove error files from pending files since error loading need to load one by one else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files +-- | We allow users to specify a loading strategy. +-- Check whether this config was changed since the last time we have loaded +-- a session. +-- +-- If the loading configuration changed, we likely should restart the session +-- in its entirety. +didSessionLoadingPreferenceConfigChange :: SessionState -> Config -> IO Bool +didSessionLoadingPreferenceConfigChange s clientConfig = do + let biosSessionLoadingVar = sessionLoadingPreferenceConfig s + mLoadingConfig <- readVar biosSessionLoadingVar + case mLoadingConfig of + Nothing -> do + writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure False + Just loadingConfig -> do + writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure (loadingConfig /= sessionLoading clientConfig) + newSessionState :: IO SessionState newSessionState = do -- Initialize SessionState @@ -581,6 +601,7 @@ newSessionState = do <*> STM.newIO -- fileToFlags <*> STM.newIO -- filesMap <*> newVar 0 -- version + <*> newVar Nothing -- sessionLoadingPreferenceConfig return sessionState -- | Given a root directory, return a Shake 'Action' which setups an @@ -602,7 +623,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] sessionState <- newSessionState - biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig)) let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) -- This caches the mapping from Mod.hs -> hie.yaml @@ -833,31 +853,12 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err - - let - -- | We allow users to specify a loading strategy. - -- Check whether this config was changed since the last time we have loaded - -- a session. - -- - -- If the loading configuration changed, we likely should restart the session - -- in its entirety. - didSessionLoadingPreferenceConfigChange :: IO Bool - didSessionLoadingPreferenceConfigChange = do - mLoadingConfig <- readVar biosSessionLoadingVar - case mLoadingConfig of - Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure False - Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) - pure (loadingConfig /= sessionLoading clientConfig) - -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) -> IO () sessionOpts (hieYaml, file) = do - Extra.whenM didSessionLoadingPreferenceConfigChange $ do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do logWith recorder Info LogSessionLoadingChanged -- If the dependencies are out of date then clear both caches and start -- again. From 702e36752cd63c91c97d4cffbe3332c11cae9881 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 14 May 2025 18:56:12 +0800 Subject: [PATCH 050/107] refactor SessionState to use Var instead of IORef for loaded and failed files --- .../session-loader/Development/IDE/Session.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 87edfc0513..5d34423c6c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -455,8 +455,8 @@ handleLoadingFailureSingle sessionState file = do removeCradleFile sessionState file data SessionState = SessionState - { loadedFiles :: !(IORef (HashSet FilePath)), - failedFiles :: !(IORef (HashSet FilePath)), + { loadedFiles :: !(Var (HashSet FilePath)), + failedFiles :: !(Var (HashSet FilePath)), pendingFiles :: !(S.OrderedSet FilePath), hscEnvs :: !(Var HieMap), fileToFlags :: !FlagsMap, @@ -471,7 +471,7 @@ data SessionState = SessionState -- | Add a file to the set of files with errors during loading addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = - atomicModifyIORef' (failedFiles state) (\xs -> (Set.insert file xs, ())) + modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () addErrorLoadingFiles = mapM_ . addErrorLoadingFile @@ -479,26 +479,26 @@ addErrorLoadingFiles = mapM_ . addErrorLoadingFile -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = - atomicModifyIORef' (failedFiles state) (\xs -> (Set.delete file xs, ())) + modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) addCradleFiles :: SessionState -> HashSet FilePath -> IO () addCradleFiles state files = - atomicModifyIORef' (loadedFiles state) (\xs -> (files <> xs, ())) + modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) -- | Remove a file from the cradle files set removeCradleFile :: SessionState -> FilePath -> IO () removeCradleFile state file = - atomicModifyIORef' (loadedFiles state) (\xs -> (Set.delete file xs, ())) + modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) -- | Clear error loading files and reset to empty set clearErrorLoadingFiles :: SessionState -> IO () clearErrorLoadingFiles state = - atomicModifyIORef' (failedFiles state) (\_ -> (Set.empty, ())) + modifyVar_' (failedFiles state) (const $ return Set.empty) -- | Clear cradle files and reset to empty set clearCradleFiles :: SessionState -> IO () clearCradleFiles state = - atomicModifyIORef' (loadedFiles state) (\_ -> (Set.empty, ())) + modifyVar_' (loadedFiles state) (const $ return Set.empty) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -562,8 +562,8 @@ handleFileProcessingError state hieYaml file diags extraDepFiles = do getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] getExtraFilesToLoad state cfp = do pendingFiles <- getPendingFiles state - errorFiles <- readIORef (failedFiles state) - old_files <- readIORef (loadedFiles state) + errorFiles <- readVar (failedFiles state) + old_files <- readVar (loadedFiles state) -- if the file is in error loading files, we fall back to single loading mode return $ Set.toList $ @@ -594,8 +594,8 @@ newSessionState :: IO SessionState newSessionState = do -- Initialize SessionState sessionState <- SessionState - <$> newIORef (Set.fromList []) -- loadedFiles - <*> newIORef (Set.fromList []) -- failedFiles + <$> newVar (Set.fromList []) -- loadedFiles + <*> newVar (Set.fromList []) -- failedFiles <*> S.newIO -- pendingFiles <*> newVar Map.empty -- hscEnvs <*> STM.newIO -- fileToFlags @@ -835,7 +835,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readIORef (loadedFiles sessionState) + old_files <- readVar (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do From 09213d333342398b46aba48f12764c05cd490926 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 19 May 2025 22:24:59 +0800 Subject: [PATCH 051/107] simplified --- .../session-loader/Development/IDE/Session.hs | 54 +++++++++---------- 1 file changed, 25 insertions(+), 29 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5d34423c6c..42290e87e5 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -437,16 +437,26 @@ On failure: This approach ensures efficient batch loading while isolating problematic files for individual handling. -} -handleLoadingSucc :: SessionState -> HashSet FilePath -> IO () -handleLoadingSucc sessionState files = do - atomically $ forM_ (Set.toList files) $ flip S.delete (pendingFiles sessionState) - mapM_ (removeErrorLoadingFile sessionState) (Set.toList files) - addCradleFiles sessionState files +-- SBL3 +handleLoadingSuccBatch :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets = do + pendings <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded +-- SBL5 handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () handleLoadingFailureBatch sessionState files = do - addErrorLoadingFiles sessionState files + mapM_ (addErrorLoadingFile sessionState) files +-- SBL4 handleLoadingFailureSingle :: SessionState -> FilePath -> IO () handleLoadingFailureSingle sessionState file = do addErrorLoadingFile sessionState file @@ -473,9 +483,6 @@ addErrorLoadingFile :: SessionState -> FilePath -> IO () addErrorLoadingFile state file = modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) -addErrorLoadingFiles :: SessionState -> [FilePath] -> IO () -addErrorLoadingFiles = mapM_ . addErrorLoadingFile - -- | Remove a file from the set of files with errors during loading removeErrorLoadingFile :: SessionState -> FilePath -> IO () removeErrorLoadingFile state file = @@ -526,7 +533,6 @@ addToPending :: SessionState -> FilePath -> STM () addToPending state file = S.insert file (pendingFiles state) - -- | Insert multiple file mappings at once insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () insertAllFileMappings state mappings = @@ -541,13 +547,13 @@ getPendingFiles :: SessionState -> IO (HashSet FilePath) getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending -handleSessionError :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () -handleSessionError state hieYaml file e = do - handleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty +handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSingleFileProcessingError' state hieYaml file e = do + handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty -- | Common pattern: Insert file flags, insert file mapping, and remove from pending -handleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () -handleFileProcessingError state hieYaml file diags extraDepFiles = do +handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () +handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) @@ -766,15 +772,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do ]) Nothing - pendings <- getPendingFiles sessionState - -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - handleLoadingSucc sessionState newLoaded + handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup checkProject <- getCheckProject @@ -828,9 +826,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) - | otherwise -> do - -- Use the common pattern here: updateFileState - handleFileProcessingError sessionState hieYaml cfp [renderPackageSetupException cfp GhcVersionMismatch{..}] mempty + | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? @@ -852,7 +848,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do else do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err - handleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err + handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err -- This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies let sessionOpts :: (Maybe FilePath, FilePath) @@ -909,7 +905,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) hieYaml <- cradleLoc file let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSessionError sessionState hieLoc file + sessionOpts (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file getOptionsLoop -- | Given a file, this function will return the HscEnv and the dependencies From f768db08e2b737604bc72b854602a0ec244ce85d Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 21 Jun 2025 13:06:55 +0200 Subject: [PATCH 052/107] Extract top-level functions for session initialisation The session initialisation has too many implicit dependencies. To break these apart, we extract local functions and turn them into top-level definition with all parameters explicitly given. This commit only makes sure session initialisation functions are promoted to top-level definitions and tries to simplify them. The top-level definitions are lacking type signatures to make it easier to change them, but we plan to add them back. --- .../session-loader/Development/IDE/Session.hs | 641 +++++++++--------- 1 file changed, 333 insertions(+), 308 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6060f5ca05..045bdcbc54 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -27,7 +27,7 @@ import Control.Monad.Extra as Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Key) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -59,7 +59,7 @@ import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util -import Development.IDE.Graph (Action) +import Development.IDE.Graph (Action, Key) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -438,27 +438,27 @@ This approach ensures efficient batch loading while isolating problematic files -} -- SBL3 -handleLoadingSuccBatch :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () -handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets = do - pendings <- getPendingFiles sessionState - -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) - atomically $ do - STM.insert this_flags_map hieYaml (fileToFlags sessionState) - insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets - logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded - atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) - mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) - addCradleFiles sessionState newLoaded +handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets = do + pendings <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded -- SBL5 -handleLoadingFailureBatch :: SessionState -> [FilePath] -> IO () -handleLoadingFailureBatch sessionState files = do +handleBatchLoadFailure :: SessionState -> [FilePath] -> IO () +handleBatchLoadFailure sessionState files = do mapM_ (addErrorLoadingFile sessionState) files -- SBL4 -handleLoadingFailureSingle :: SessionState -> FilePath -> IO () -handleLoadingFailureSingle sessionState file = do +handleSingleLoadFailure :: SessionState -> FilePath -> IO () +handleSingleLoadFailure sessionState file = do addErrorLoadingFile sessionState file removeErrorLoadingFile sessionState file atomically $ S.delete file (pendingFiles sessionState) @@ -557,7 +557,7 @@ handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) - handleLoadingFailureSingle state file + handleSingleLoadFailure state file atomically $ do insertFileFlags state hieYaml ncfp flags insertFileMapping state hieYaml ncfp @@ -642,302 +642,29 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do return $ do clientConfig <- getClientConfigAction - extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv + extras@ShakeExtras{ideNc, knownTargetsVar } <- getShakeExtras let invalidateShakeCache = do void $ incrementVersion sessionState return $ toNoFileKey GhcSessionIO - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optExtensions - } <- getIdeOptions - - -- populate the knownTargetsVar with all the - -- files in the project so that `knownFiles` can learn about them and - -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- concatForM newTargets $ \TargetDetails{..} -> - case targetTarget of - TargetFile f -> do - -- If a target file has multiple possible locations, then we - -- assume they are all separate file targets. - -- This happens with '.hs-boot' files if they are in the root directory of the project. - -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. - -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the - -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. - -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either - -- - -- * TargetFile Foo.hs-boot - -- * TargetModule Foo - -- - -- If we don't generate a TargetFile for each potential location, we will only have - -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' - -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) - TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return [(targetTarget, Set.fromList found)] - hasUpdate <- atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - pure hasUpdate - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) - return $ toNoFileKey GetKnownTargets - - -- Create a new HscEnv from a hieYaml root and a set of options - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO ([ComponentInfo], [ComponentInfo]) - 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 - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar (hscEnvs sessionState) $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newTargetDfs - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - _inplace = map rawComponentUnitId $ NE.toList all_deps - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let cacheDirOpts = componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) - - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> IO () - session args@(hieYaml, _cfp, _opts, _libDir) = do - (new_deps, old_deps) <- packageSetup args - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - -- For GHC's supporting multi component sessions, we create a shared - -- HscEnv but set the active component accordingly - hscEnv <- emptyHscEnv ideNc _libDir - let new_cache = newComponentCache recorder optExtensions _cfp hscEnv - all_target_details <- new_cache old_deps new_deps - - let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - all_targets' = concat all_target_details - this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, _this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - (T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ]) - Nothing - - handleLoadingSuccBatch recorder sessionState hieYaml this_flags_map all_targets - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - - -- The VFS doesn't change on cradle edits, re-use the old one. - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - restartShakeSession VFSUnmodified "new component" [] $ do - keys2 <- invalidateShakeCache - keys1 <- extendKnownTargets all_targets - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return [keys1, keys2] - - let consultCradle :: Maybe FilePath -> FilePath -> IO () - consultCradle hieYaml cfp = do - let lfpLog = makeRelative rootDir cfp - logWith recorder Info $ LogCradlePath lfpLog - when (isNothing hieYaml) $ - logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir - when optTesting $ mRunLspT lspEnv $ - sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) - - -- Display a user friendly progress message here: They probably don't know what a cradle is - let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfpLog <> ")" - - extraToLoads <- getExtraFilesToLoad sessionState cfp - eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ - withTrace "Load cradle" $ \addTag -> do - addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp extraToLoads - addTag "result" (show res) - return res - - logWith recorder Debug $ LogSessionLoadingResult eopts - let ncfp = toNormalizedFilePath' cfp - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir, version) -> do - let compileTime = fullCompilerVersion - case reverse $ readP_to_S parseVersion version of - [] -> error $ "GHC version could not be parsed: " <> version - ((runTime, _):_) - | compileTime == runTime -> session (hieYaml, ncfp, opts, libDir) - | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) - -- Failure case, either a cradle error or the none cradle - Left err -> do - -- what if the error to load file is one of old_files ? - let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readVar (loadedFiles sessionState) - let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) - if length errorToLoadNewFiles > 1 - then do - -- we are loading more files and failed, we need to retry - -- mark as less loaded files as failedLoadingFiles as possible - -- limitation is that when we are loading files, and the dependencies of old_files - -- are changed, and old_files are not valid anymore. - -- but they will still be in the old_files, and will not move to failedFiles. - -- And make other files failed to load in batch mode. - handleLoadingFailureBatch sessionState errorToLoadNewFiles - -- retry without other files - logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) - consultCradle hieYaml cfp - else do - -- we are only loading this file and it failed - let res = map (\err' -> renderCradleError err' cradle ncfp) err - handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) - -> IO () - sessionOpts (hieYaml, file) = do - Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do - logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState - -- Don't even keep the name cache, we start from scratch here! - modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) - -- cleanup error loading files and cradle files - clearErrorLoadingFiles sessionState - clearCradleFiles sessionState - cacheKey <- invalidateShakeCache - restartShakeSession VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) - - v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) - case v >>= HM.lookup (toNormalizedFilePath' file) of - Just (_opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- if deps are old, we can try to load the error files again - removeErrorLoadingFile sessionState file - removeCradleFile sessionState file - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState - -- Keep the same name cache - modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) - consultCradle hieYaml file - -- if deps are ok, we can just remove the file from pending files - else atomically $ removeFromPending sessionState file - Nothing -> consultCradle hieYaml file - - let checkInCache ::NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) - checkInCache ncfp = runMaybeT $ do - cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) - m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) - MaybeT $ pure $ HM.lookup ncfp m - - -- The main function which gets options for a file. We only want one of these running - -- at a time. Therefore the IORef contains the currently running cradle, if we try - -- to get some more options then we wait for the currently running action to finish - -- before attempting to do so. - let getOptionsLoop :: IO () - getOptionsLoop = do - -- Get the next file to load - file <- atomically $ S.readQueue (pendingFiles sessionState) - logWith recorder Debug (LogGetOptionsLoop file) - let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) - hieYaml <- cradleLoc file - let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file - getOptionsLoop - - -- | Given a file, this function will return the HscEnv and the dependencies - -- it would look up the cache first, if the cache is not available, it would - -- submit a request to the getOptionsLoop to get the options for the file - -- and wait until the options are available - let lookupOrWaitCache :: FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) - lookupOrWaitCache absFile = do - let ncfp = toNormalizedFilePath' absFile - res <- atomically $ do - -- wait until target file is not in pendingFiles - Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry - -- check if in the cache - checkInCache ncfp - logWith recorder Debug $ LogLookupSessionCache absFile - updateDateRes <- case res of - Just r -> do - depOk <- checkDependencyInfo (snd r) - if depOk - then return $ Just r - else return Nothing - _ -> return Nothing - case updateDateRes of - Just r -> return r - Nothing -> do - -- if not ok, we need to reload the session - atomically $ addToPending sessionState absFile - lookupOrWaitCache absFile + ideOptions <- getIdeOptions -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty - liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ writeTQueue que getOptionsLoop + liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ do + let newSessionLoadingOptions = SessionLoadingOptions + { findCradle = cradleLoc + , .. + } + sessionShake = SessionShake + { restartSession = restartShakeSession extras + , invalidateCache = invalidateShakeCache + , enqueueActions = shakeEnqueue extras + , lspContext = lspEnv extras + } + + writeTQueue que (getOptionsLoop recorder sessionShake sessionState newSessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc) -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. @@ -947,7 +674,305 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) returnWithVersion $ \file -> do let absFile = toAbsolutePath file - absolutePathsCradleDeps <$> lookupOrWaitCache absFile + absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile + +-- | Given a file, this function will return the HscEnv and the dependencies +-- it would look up the cache first, if the cache is not available, it would +-- submit a request to the getOptionsLoop to get the options for the file +-- and wait until the options are available +lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) +lookupOrWaitCache recorder sessionState absFile = do + let ncfp = toNormalizedFilePath' absFile + res <- atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry + -- check if in the cache + checkInCache sessionState ncfp + logWith recorder Debug $ LogLookupSessionCache absFile + updateDateRes <- case res of + Just r -> do + depOk <- checkDependencyInfo (snd r) + if depOk + then return $ Just r + else return Nothing + _ -> return Nothing + case updateDateRes of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ addToPending sessionState absFile + lookupOrWaitCache recorder sessionState absFile + +checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) +checkInCache sessionState ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) + MaybeT $ pure $ HM.lookup ncfp m + +data SessionShake = SessionShake + { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () + , invalidateCache :: IO Key + , enqueueActions :: DelayedAction () -> IO (IO ()) + , lspContext :: Maybe (LanguageContextEnv Config) + } + +-- The main function which gets options for a file. We only want one of these running +-- at a time. Therefore the IORef contains the currently running cradle, if we try +-- to get some more options then we wait for the currently running action to finish +-- before attempting to do so. +getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc = do + -- Get the next file to load + file <- atomically $ S.readQueue (pendingFiles sessionState) + logWith recorder Debug (LogGetOptionsLoop file) + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) + hieYaml <- findCradle sessionLoadingOptions file + let hieLoc = cachedHieYamlLocation <|> hieYaml + sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieLoc, file) + `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file + getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc + +-- | This caches the mapping from hie.yaml + Mod.hs -> [String] +-- Returns the Ghc session and the cradle dependencies +sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieYaml, file) = do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do + logWith recorder Info LogSessionLoadingChanged + -- If the dependencies are out of date then clear both caches and start + -- again. + atomically $ resetFileMaps sessionState + -- Don't even keep the name cache, we start from scratch here! + modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + -- cleanup error loading files and cradle files + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState + cacheKey <- invalidateCache sessionShake + restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) + + v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of + Just (_opts, old_di) -> do + deps_ok <- checkDependencyInfo old_di + if not deps_ok + then do + -- if deps are old, we can try to load the error files again + removeErrorLoadingFile sessionState file + removeCradleFile sessionState file + -- If the dependencies are out of date then clear both caches and start + -- again. + atomically $ resetFileMaps sessionState + -- Keep the same name cache + modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + -- if deps are ok, we can just remove the file from pending files + else atomically $ removeFromPending sessionState file + Nothing -> consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + +consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp = do + (cradle, eopts) <- loadCradleWithNotifications recorder (optTesting ideOptions) + (lspContext sessionShake) sessionState (sessionLoading clientConfig) + (loadCradle sessionLoadingOptions) + rootDir hieYaml cfp + logWith recorder Debug $ LogSessionLoadingResult eopts + let ncfp = toNormalizedFilePath' cfp + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir, version) -> do + let compileTime = fullCompilerVersion + case reverse $ readP_to_S parseVersion version of + [] -> error $ "GHC version could not be parsed: " <> version + ((runTime, _):_) + | compileTime == runTime -> session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, ncfp, opts, libDir) + | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) + -- Failure case, either a cradle error or the none cradle + Left err -> do + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- readVar (loadedFiles sessionState) + let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) + if length errorToLoadNewFiles > 1 + then do + -- we are loading more files and failed, we need to retry + -- mark as less loaded files as failedLoadingFiles as possible + -- limitation is that when we are loading files, and the dependencies of old_files + -- are changed, and old_files are not valid anymore. + -- but they will still be in the old_files, and will not move to failedFiles. + -- And make other files failed to load in batch mode. + handleBatchLoadFailure sessionState errorToLoadNewFiles + -- retry without other files + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) + consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp + else do + -- we are only loading this file and it failed + let res = map (\err' -> renderCradleError err' cradle ncfp) err + handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err + +session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, cfp, opts, libDir) = do + let initEmptyHscEnv = emptyHscEnv ideNc libDir + (new_deps, old_deps) <- packageSetup recorder sessionState rootDir (getCacheDirs sessionLoadingOptions) initEmptyHscEnv (hieYaml, cfp, opts) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- For GHC's supporting multi component sessions, we create a shared + -- HscEnv but set the active component accordingly + hscEnv <- initEmptyHscEnv + let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv + all_target_details <- new_cache old_deps new_deps + (all_targets, this_flags_map) <- addErrorTargetIfUnknown all_target_details hieYaml cfp + + handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + -- Typecheck all files in the project on startup + loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets + +-- | Create a new HscEnv from a hieYaml root and a set of options +packageSetup recorder sessionState rootDir getCacheDirs newEmptyHscEnv (hieYaml, cfp, opts) = do + -- Parse DynFlags for the newly discovered component + hscEnv <- newEmptyHscEnv + newTargetDfs <- evalGhcEnv hscEnv $ setOptions 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 + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar (hscEnvs sessionState) $ + addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) + +addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let cacheDirOpts = componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + +addErrorTargetIfUnknown all_target_details hieYaml cfp = do + let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + all_targets' = concat all_target_details + this_dep_info <- getDependencyInfo $ maybeToList hieYaml + let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of + Just _ -> (all_targets', flags_map') + Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map') + where + this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing + pure (all_targets, this_flags_map) + +-- | Populate the knownTargetsVar with all the +-- files in the project so that `knownFiles` can learn about them and +-- we can generate a complete module graph +extendKnownTargets recorder knownTargetsVar newTargets = do + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> do + -- If a target file has multiple possible locations, then we + -- assume they are all separate file targets. + -- This happens with '.hs-boot' files if they are in the root directory of the project. + -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. + -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the + -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. + -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either + -- + -- * TargetFile Foo.hs-boot + -- * TargetModule Foo + -- + -- If we don't generate a TargetFile for each potential location, we will only have + -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' + -- and also not find 'TargetModule Foo'. + fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + TargetModule _ -> do + found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return [(targetTarget, Set.fromList found)] + hasUpdate <- atomically $ do + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + pure hasUpdate + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + return $ toNoFileKey GetKnownTargets + +loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps targets = do + checkProject <- getCheckProject + + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + restartSession sessionShake VFSUnmodified "new component" [] $ do + keys2 <- invalidateCache sessionShake + keys1 <- extendKnownTargets recorder knownTargetsVar targets + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations targets) + void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] + +loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState sessionPref loadCradle rootDir hieYaml cfp= do + let lfpLog = makeRelative rootDir cfp + logWith recorder Info $ LogCradlePath lfpLog + when (isNothing hieYaml) $ + logWith recorder Warning $ LogCradleNotFound lfpLog + cradle <- loadCradle recorder hieYaml rootDir + when (isTesting) $ mRunLspT lspEnv $ + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) + + -- Display a user friendly progress message here: They probably don't know what a cradle is + let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) + <> " (for " <> T.pack lfpLog <> ")" + + extraToLoads <- getExtraFilesToLoad sessionState cfp + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + withTrace "Load cradle" $ \addTag -> do + addTag "file" lfpLog + res <- cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads + addTag "result" (show res) + return res + pure (cradle, eopts) + -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the From d4fbc2c339e16b60df12788b2d272bd0884640ff Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 18:42:25 +0200 Subject: [PATCH 053/107] Remove unused _removeInplacePackages function --- .../session-loader/Development/IDE/Session.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 045bdcbc54..f6ebe43481 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1324,24 +1324,6 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -_removeInplacePackages --Only used in ghc < 9.4 - :: UnitId -- ^ fake uid to use for our internal component - -> [UnitId] - -> DynFlags - -> (DynFlags, [UnitId]) -_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ - df { packageFlags = ps }, uids) - where - (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) - -- | Memoize an IO function, with the characteristics: -- -- * If multiple people ask for a result simultaneously, make sure you only compute it once. From ff807c335960be11df8c8d08271a2c6e73c628c1 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 19:37:36 +0200 Subject: [PATCH 054/107] Introduce SessionM for bundling read-only variables --- .../session-loader/Development/IDE/Session.hs | 207 +++++++++++------- 1 file changed, 131 insertions(+), 76 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f6ebe43481..abeb9cb5d1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -28,7 +28,6 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import qualified Crypto.Hash.SHA1 as H import Data.Aeson hiding (Error, Key) -import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B import Data.Default @@ -36,7 +35,6 @@ import Data.Either.Extra import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM -import Data.IORef import Data.List import Data.List.Extra as L import Data.List.NonEmpty (NonEmpty (..)) @@ -119,7 +117,7 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) -import Control.Concurrent.STM (STM) +import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus @@ -129,6 +127,7 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State import qualified StmContainers.Map as STM +import Control.Monad.Trans.Reader #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) @@ -479,33 +478,33 @@ data SessionState = SessionState -- These functions encapsulate common operations on the SessionState -- | Add a file to the set of files with errors during loading -addErrorLoadingFile :: SessionState -> FilePath -> IO () +addErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () addErrorLoadingFile state file = - modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) -- | Remove a file from the set of files with errors during loading -removeErrorLoadingFile :: SessionState -> FilePath -> IO () +removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () removeErrorLoadingFile state file = - modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) -addCradleFiles :: SessionState -> HashSet FilePath -> IO () +addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m () addCradleFiles state files = - modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) -- | Remove a file from the cradle files set -removeCradleFile :: SessionState -> FilePath -> IO () +removeCradleFile :: MonadIO m => SessionState -> FilePath -> m () removeCradleFile state file = - modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) -- | Clear error loading files and reset to empty set -clearErrorLoadingFiles :: SessionState -> IO () +clearErrorLoadingFiles :: MonadIO m => SessionState -> m () clearErrorLoadingFiles state = - modifyVar_' (failedFiles state) (const $ return Set.empty) + liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty) -- | Clear cradle files and reset to empty set -clearCradleFiles :: SessionState -> IO () +clearCradleFiles :: MonadIO m => SessionState -> m () clearCradleFiles state = - modifyVar_' (loadedFiles state) (const $ return Set.empty) + liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty) -- | Reset the file maps in the session state resetFileMaps :: SessionState -> STM () @@ -547,13 +546,13 @@ getPendingFiles :: SessionState -> IO (HashSet FilePath) getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending -handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> IO () +handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM () handleSingleFileProcessingError' state hieYaml file e = do handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty -- | Common pattern: Insert file flags, insert file mapping, and remove from pending -handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> IO () -handleSingleFileProcessingError state hieYaml file diags extraDepFiles = do +handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM () +handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles let ncfp = toNormalizedFilePath' file let flags = ((diags, Nothing), dep) @@ -584,16 +583,17 @@ getExtraFilesToLoad state cfp = do -- -- If the loading configuration changed, we likely should restart the session -- in its entirety. -didSessionLoadingPreferenceConfigChange :: SessionState -> Config -> IO Bool -didSessionLoadingPreferenceConfigChange s clientConfig = do +didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool +didSessionLoadingPreferenceConfigChange s = do + clientConfig <- asks sessionClientConfig let biosSessionLoadingVar = sessionLoadingPreferenceConfig s - mLoadingConfig <- readVar biosSessionLoadingVar + mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar case mLoadingConfig of Nothing -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure False Just loadingConfig -> do - writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) pure (loadingConfig /= sessionLoading clientConfig) newSessionState :: IO SessionState @@ -661,10 +661,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do { restartSession = restartShakeSession extras , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras - , lspContext = lspEnv extras + } + sessionEnv = SessionEnv + { sessionLspContext = lspEnv extras + , sessionRootDir = rootDir + , sessionIdeOptions = ideOptions + , sessionClientConfig = clientConfig + , sessionSharedNameCache = ideNc + , sessionLoadingOptions = newSessionLoadingOptions } - writeTQueue que (getOptionsLoop recorder sessionShake sessionState newSessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc) + writeTQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. @@ -713,45 +720,55 @@ data SessionShake = SessionShake { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () , invalidateCache :: IO Key , enqueueActions :: DelayedAction () -> IO (IO ()) - , lspContext :: Maybe (LanguageContextEnv Config) } --- The main function which gets options for a file. We only want one of these running +data SessionEnv = SessionEnv + { sessionLspContext :: Maybe (LanguageContextEnv Config) + , sessionRootDir :: FilePath + , sessionIdeOptions :: IdeOptions + , sessionClientConfig :: Config + , sessionSharedNameCache :: NameCache + , sessionLoadingOptions :: SessionLoadingOptions + } + +type SessionM = ReaderT SessionEnv IO + +-- | The main function which gets options for a file. We only want one of these running -- at a time. Therefore the IORef contains the currently running cradle, if we try -- to get some more options then we wait for the currently running action to finish -- before attempting to do so. -getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc = do +getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM () +getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do + sessionLoadingOptions <- asks sessionLoadingOptions -- Get the next file to load - file <- atomically $ S.readQueue (pendingFiles sessionState) + file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file - cachedHieYamlLocation <- join <$> atomically (STM.lookup ncfp (filesMap sessionState)) - hieYaml <- findCradle sessionLoadingOptions file + cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp (filesMap sessionState))) + hieYaml <- liftIO $ findCradle sessionLoadingOptions file let hieLoc = cachedHieYamlLocation <|> hieYaml - sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieLoc, file) + sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file) `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file - getOptionsLoop recorder sessionShake sessionState sessionLoadingOptions ideOptions clientConfig knownTargetsVar rootDir ideNc -- | This caches the mapping from hie.yaml + Mod.hs -> [String] -- Returns the Ghc session and the cradle dependencies -sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc (hieYaml, file) = do - Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState clientConfig) $ do +sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM () +sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do logWith recorder Info LogSessionLoadingChanged - -- If the dependencies are out of date then clear both caches and start - -- again. - atomically $ resetFileMaps sessionState + liftIO $ atomically $ resetFileMaps sessionState -- Don't even keep the name cache, we start from scratch here! - modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) -- cleanup error loading files and cradle files clearErrorLoadingFiles sessionState clearCradleFiles sessionState - cacheKey <- invalidateCache sessionShake - restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) + cacheKey <- liftIO $ invalidateCache sessionShake + liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) - v <- atomically $ STM.lookup hieYaml (fileToFlags sessionState) + v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState) case v >>= HM.lookup (toNormalizedFilePath' file) of Just (_opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di + deps_ok <- liftIO $ checkDependencyInfo old_di if not deps_ok then do -- if deps are old, we can try to load the error files again @@ -759,19 +776,22 @@ sessionOpts recorder sessionShake ideOptions sessionState sessionLoadingOptions removeCradleFile sessionState file -- If the dependencies are out of date then clear both caches and start -- again. - atomically $ resetFileMaps sessionState + liftIO $ atomically $ resetFileMaps sessionState -- Keep the same name cache - modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) - consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file + liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file -- if deps are ok, we can just remove the file from pending files - else atomically $ removeFromPending sessionState file - Nothing -> consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml file - -consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp = do - (cradle, eopts) <- loadCradleWithNotifications recorder (optTesting ideOptions) - (lspContext sessionShake) sessionState (sessionLoading clientConfig) - (loadCradle sessionLoadingOptions) - rootDir hieYaml cfp + else liftIO $ atomically $ removeFromPending sessionState file + Nothing -> + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file + +consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM () +consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do + loadingOptions <- asks sessionLoadingOptions + (cradle, eopts) <- loadCradleWithNotifications recorder + sessionState + (loadCradle loadingOptions recorder) + hieYaml cfp logWith recorder Debug $ LogSessionLoadingResult eopts let ncfp = toNormalizedFilePath' cfp case eopts of @@ -782,13 +802,13 @@ consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOption case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) - | compileTime == runTime -> session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, ncfp, opts, libDir) + | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir) | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) -- Failure case, either a cradle error or the none cradle Left err -> do -- what if the error to load file is one of old_files ? let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err - old_files <- readVar (loadedFiles sessionState) + old_files <- liftIO $ readVar (loadedFiles sessionState) let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) if length errorToLoadNewFiles > 1 then do @@ -798,46 +818,66 @@ consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOption -- are changed, and old_files are not valid anymore. -- but they will still be in the old_files, and will not move to failedFiles. -- And make other files failed to load in batch mode. - handleBatchLoadFailure sessionState errorToLoadNewFiles + liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles -- retry without other files logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) - consultCradle recorder sessionShake ideOptions sessionState sessionLoadingOptions clientConfig knownTargetsVar rootDir ideNc hieYaml cfp + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp else do -- we are only loading this file and it failed let res = map (\err' -> renderCradleError err' cradle ncfp) err handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err -session recorder sessionShake sessionState ideOptions sessionLoadingOptions knownTargetsVar rootDir ideNc (hieYaml, cfp, opts, libDir) = do - let initEmptyHscEnv = emptyHscEnv ideNc libDir - (new_deps, old_deps) <- packageSetup recorder sessionState rootDir (getCacheDirs sessionLoadingOptions) initEmptyHscEnv (hieYaml, cfp, opts) +session :: + Recorder (WithPriority Log) -> + SessionShake -> + SessionState -> + TVar (Hashed KnownTargets) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> + SessionM () +session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do + let initEmptyHscEnv = emptyHscEnv libDir + (new_deps, old_deps) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) -- For each component, now make a new HscEnvEq which contains the -- HscEnv for the hie.yaml file but the DynFlags for that component -- For GHC's supporting multi component sessions, we create a shared -- HscEnv but set the active component accordingly hscEnv <- initEmptyHscEnv + ideOptions <- asks sessionIdeOptions let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv - all_target_details <- new_cache old_deps new_deps - (all_targets, this_flags_map) <- addErrorTargetIfUnknown all_target_details hieYaml cfp + all_target_details <- liftIO $ new_cache old_deps new_deps + (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp - handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + liftIO $ handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets -- Typecheck all files in the project on startup - loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets + liftIO $ loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets -- | Create a new HscEnv from a hieYaml root and a set of options -packageSetup recorder sessionState rootDir getCacheDirs newEmptyHscEnv (hieYaml, cfp, opts) = do +packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) +packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do + getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions) + rootDir <- asks sessionRootDir -- Parse DynFlags for the newly discovered component hscEnv <- newEmptyHscEnv - newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps + dep_info <- liftIO $ getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) - modifyVar (hscEnvs sessionState) $ + liftIO $ modifyVar (hscEnvs sessionState) $ addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) +addComponentInfo :: + MonadUnliftIO m => + Recorder (WithPriority Log) -> + (String -> [String] -> IO CacheDirs) -> + DependencyInfo -> + NonEmpty (DynFlags, [GHC.Target]) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + Map.Map (Maybe FilePath) [RawComponentInfo] -> + m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do -- Just deps if there's already an HscEnv -- Nothing is it's the first time we are making an HscEnv @@ -876,6 +916,7 @@ addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) let (new,old) = NE.splitAt (NE.length new_deps) all_deps' pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) +addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details @@ -898,6 +939,7 @@ addErrorTargetIfUnknown all_target_details hieYaml cfp = do -- | Populate the knownTargetsVar with all the -- files in the project so that `knownFiles` can learn about them and -- we can generate a complete module graph +extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key extendKnownTargets recorder knownTargetsVar newTargets = do knownTargets <- concatForM newTargets $ \TargetDetails{..} -> case targetTarget of @@ -931,6 +973,7 @@ extendKnownTargets recorder knownTargetsVar newTargets = do logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) return $ toNoFileKey GetKnownTargets +loadKnownTargets :: Recorder (WithPriority Log) -> SessionShake -> IO Bool -> TVar (Hashed KnownTargets) -> [ComponentInfo] -> [TargetDetails] -> IO () loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps targets = do checkProject <- getCheckProject @@ -951,12 +994,23 @@ loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] -loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState sessionPref loadCradle rootDir hieYaml cfp= do +loadCradleWithNotifications :: + Recorder (WithPriority Log) -> + SessionState -> + (Maybe FilePath -> FilePath -> IO (Cradle Void)) -> + Maybe FilePath -> + FilePath -> + SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String)) +loadCradleWithNotifications recorder sessionState loadCradle hieYaml cfp = do + IdeTesting isTesting <- asks (optTesting . sessionIdeOptions) + sessionPref <- asks (sessionLoading . sessionClientConfig) + lspEnv <- asks sessionLspContext + rootDir <- asks sessionRootDir let lfpLog = makeRelative rootDir cfp logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog - cradle <- loadCradle recorder hieYaml rootDir + cradle <- liftIO $ loadCradle hieYaml rootDir when (isTesting) $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) @@ -964,11 +1018,11 @@ loadCradleWithNotifications recorder (IdeTesting isTesting) lspEnv sessionState let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfpLog <> ")" - extraToLoads <- getExtraFilesToLoad sessionState cfp + extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfpLog - res <- cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads + res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads addTag "result" (show res) return res pure (cradle, eopts) @@ -1008,11 +1062,12 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do PreferSingleComponentLoading -> LoadFile PreferMultiComponentLoading -> LoadWithContext old_fps -emptyHscEnv :: NameCache -> FilePath -> IO HscEnv -emptyHscEnv nc libDir = do +emptyHscEnv :: FilePath -> SessionM HscEnv +emptyHscEnv libDir = do + nc <- asks sessionSharedNameCache -- We call setSessionDynFlags so that the loader is initialised -- We need to do this before we call initUnits. - env <- runGhc (Just libDir) $ + env <- liftIO $ runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) From 1aa1e2c55b621e8edad45baf4dfc0ebe1124005e Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 4 Jul 2025 20:10:33 +0200 Subject: [PATCH 055/107] Extract ghc specific functions into separate module --- ghcide/ghcide.cabal | 2 + .../session-loader/Development/IDE/Session.hs | 541 +----------------- .../Development/IDE/Session/Dependency.hs | 35 ++ .../Development/IDE/Session/Ghc.hs | 522 +++++++++++++++++ 4 files changed, 587 insertions(+), 513 deletions(-) create mode 100644 ghcide/session-loader/Development/IDE/Session/Dependency.hs create mode 100644 ghcide/session-loader/Development/IDE/Session/Ghc.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8218883077..dead03f36c 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -180,7 +180,9 @@ library Development.IDE.Plugin.Test Development.IDE.Plugin.TypeLenses Development.IDE.Session + Development.IDE.Session.Dependency Development.IDE.Session.Diagnostics + Development.IDE.Session.Ghc Development.IDE.Session.Implicit Development.IDE.Spans.AtPoint Development.IDE.Spans.Common diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index abeb9cb5d1..996f757303 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-| @@ -31,40 +30,31 @@ import Data.Aeson hiding (Error, Key) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B import Data.Default -import Data.Either.Extra -import Data.Function import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM import Data.List import Data.List.Extra as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy import qualified Data.Text as T -import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Compat.CmdLine import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, Var, Warning, getOptions) -import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) -import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util import Development.IDE.Graph (Action, Key) import qualified Development.IDE.Session.Implicit as GhcIde import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) +import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.ResponseFile import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) @@ -92,24 +82,20 @@ import Data.Void import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) import Control.Concurrent.STM.TQueue -import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (ContT (ContT, runContT)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Core.WorkerThread (withWorkerQueue) -import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) +import Development.IDE.Session.Dependency +import Development.IDE.Session.Ghc hiding (Log) import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..), toNoFileKey) -import GHC.Data.Graph.Directed import HieDb.Create import HieDb.Types import Ide.PluginUtils (toAbsolute) @@ -121,17 +107,9 @@ import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM import qualified Development.IDE.Session.OrderedSet as S import qualified Focus -import GHC.Driver.Env (hsc_all_home_unit_ids) -import GHC.Driver.Errors.Types -import GHC.Types.Error (errMsgDiagnostic, - singleMessage) -import GHC.Unit.State import qualified StmContainers.Map as STM import Control.Monad.Trans.Reader - -#if MIN_VERSION_ghc(9,13,0) -import GHC.Driver.Make (checkHomeUnitsClosed) -#endif +import qualified Development.IDE.Session.Ghc as Ghc data Log = LogSettingInitialDynFlags @@ -141,16 +119,12 @@ data Log | LogHieDbRetriesExhausted !Int !Int !Int !SomeException | LogHieDbWriterThreadSQLiteError !SQLError | LogHieDbWriterThreadException !SomeException - | LogInterfaceFilesCacheDir !FilePath | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) - | LogMakingNewHscEnv ![UnitId] - | LogDLLLoadError !String | LogCradlePath !FilePath | LogCradleNotFound !FilePath | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) | LogCradle !(Cradle Void) | LogNoneCradleFound FilePath - | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged | LogSessionNewLoadedFiles ![FilePath] @@ -158,6 +132,7 @@ data Log | LogGetOptionsLoop !FilePath | LogLookupSessionCache !FilePath | LogTime !String + | LogSessionGhc Ghc.Log deriving instance Show Log instance Pretty Log where @@ -209,18 +184,12 @@ instance Pretty Log where vcat [ "HieDb writer thread exception:" , pretty (displayException e) ] - LogInterfaceFilesCacheDir path -> - "Interface files cache directory:" <+> pretty path LogKnownFilesUpdated targetToPathsMap -> nest 2 $ vcat [ "Known files updated:" , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap ] - LogMakingNewHscEnv inPlaceUnitIds -> - "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) - LogDLLLoadError errorString -> - "Error dynamically loading libm.so.6:" <+> pretty errorString LogCradlePath path -> "Cradle path:" <+> pretty path LogCradleNotFound path -> @@ -232,9 +201,8 @@ instance Pretty Log where "Session loading result:" <+> viaShow e LogCradle cradle -> "Cradle:" <+> viaShow cradle - LogNewComponentCache componentCache -> - "New component cache HscEnvEq:" <+> viaShow componentCache LogHieBios msg -> pretty msg + LogSessionGhc msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." @@ -242,9 +210,6 @@ instance Pretty Log where hiedbDataVersion :: String hiedbDataVersion = "1" -data CacheDirs = CacheDirs - { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} - data SessionLoadingOptions = SessionLoadingOptions { findCradle :: FilePath -> IO (Maybe FilePath) -- | Load the cradle with an optional 'hie.yaml' location. @@ -733,18 +698,22 @@ data SessionEnv = SessionEnv type SessionM = ReaderT SessionEnv IO --- | The main function which gets options for a file. We only want one of these running --- at a time. Therefore the IORef contains the currently running cradle, if we try --- to get some more options then we wait for the currently running action to finish --- before attempting to do so. +-- | The main function which gets options for a file. +-- +-- The general approach is as follows: +-- 1. Find the 'hie.yaml' for the next file target, if there is any. +-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before +-- 3.1. If it wasn't, initialise a new session and continue with step 4. +-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified +-- 3.2.1. If we need to reload, remove the getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM () getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do - sessionLoadingOptions <- asks sessionLoadingOptions -- Get the next file to load file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState) logWith recorder Debug (LogGetOptionsLoop file) let ncfp = toNormalizedFilePath' file cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp (filesMap sessionState))) + sessionLoadingOptions <- asks sessionLoadingOptions hieYaml <- liftIO $ findCradle sessionLoadingOptions file let hieLoc = cachedHieYamlLocation <|> hieYaml sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file) @@ -780,8 +749,9 @@ sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = -- Keep the same name cache liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file - -- if deps are ok, we can just remove the file from pending files - else liftIO $ atomically $ removeFromPending sessionState file + else do + -- if deps are ok, we can just remove the file from pending files + liftIO $ atomically $ removeFromPending sessionState file Nothing -> consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file @@ -835,7 +805,7 @@ session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> SessionM () session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do - let initEmptyHscEnv = emptyHscEnv libDir + let initEmptyHscEnv = emptyHscEnvM libDir (new_deps, old_deps) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) -- For each component, now make a new HscEnvEq which contains the @@ -844,7 +814,7 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l -- HscEnv but set the active component accordingly hscEnv <- initEmptyHscEnv ideOptions <- asks sessionIdeOptions - let new_cache = newComponentCache recorder (optExtensions ideOptions) cfp hscEnv + let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv all_target_details <- liftIO $ new_cache old_deps new_deps (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp @@ -867,54 +837,7 @@ packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do -- information about other components loaded into the HscEnv -- (unitId, DynFlag, Targets) liftIO $ modifyVar (hscEnvs sessionState) $ - addComponentInfo recorder getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) - -addComponentInfo :: - MonadUnliftIO m => - Recorder (WithPriority Log) -> - (String -> [String] -> IO CacheDirs) -> - DependencyInfo -> - NonEmpty (DynFlags, [GHC.Target]) -> - (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> - Map.Map (Maybe FilePath) [RawComponentInfo] -> - m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) -addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags - all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps - -- Get all the unit-ids for things in this component - - all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let cacheDirOpts = componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo - { componentUnitId = rawComponentUnitId - , componentDynFlags = processed_df - , componentTargets = rawComponentTargets - , componentFP = rawComponentFP - , componentCOptions = rawComponentCOptions - , componentDependencyInfo = rawComponentDependencyInfo - } - -- Modify the map so the hieYaml now maps to the newly updated - -- ComponentInfos - -- Returns - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - let (new,old) = NE.splitAt (NE.length new_deps) all_deps' - pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do @@ -1062,255 +985,20 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do PreferSingleComponentLoading -> LoadFile PreferMultiComponentLoading -> LoadWithContext old_fps -emptyHscEnv :: FilePath -> SessionM HscEnv -emptyHscEnv libDir = do - nc <- asks sessionSharedNameCache - -- We call setSessionDynFlags so that the loader is initialised - -- We need to do this before we call initUnits. - env <- liftIO $ runGhc (Just libDir) $ - getSessionDynFlags >>= setSessionDynFlags >> getSession - pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) - -data TargetDetails = TargetDetails - { - targetTarget :: !Target, - targetEnv :: !(IdeResult HscEnvEq), - targetDepends :: !DependencyInfo, - targetLocations :: ![NormalizedFilePath] - } +-- ---------------------------------------------------------------------------- +-- Utilities +-- ---------------------------------------------------------------------------- -fromTargetId :: [FilePath] -- ^ import paths - -> [String] -- ^ extensions to consider - -> TargetId - -> IdeResult HscEnvEq - -> DependencyInfo - -> IO [TargetDetails] --- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule modName) env dep = do - let fps = [i moduleNameSlashes modName -<.> ext <> boot - | ext <- exts - , i <- is - , boot <- ["", "-boot"] - ] - let locs = fmap toNormalizedFilePath' fps - return [TargetDetails (TargetModule modName) env dep locs] --- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - let nf = toNormalizedFilePath' f - let other - | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) - | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") - return [TargetDetails (TargetFile nf) env deps [nf, other]] +emptyHscEnvM :: FilePath -> SessionM HscEnv +emptyHscEnvM libDir = do + nc <- asks sessionSharedNameCache + liftIO $ Ghc.emptyHscEnv nc libDir toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} = [ (l, (targetEnv, targetDepends)) | l <- targetLocations] - -setNameCache :: NameCache -> HscEnv -> HscEnv -setNameCache nc hsc = hsc { hsc_NC = nc } - -#if MIN_VERSION_ghc(9,13,0) --- Moved back to implementation in GHC. -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] -checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue -#else --- This function checks the important property that if both p and q are home units --- then any dependency of p, which transitively depends on q is also a home unit. --- GHC had an implementation of this function, but it was horribly inefficient --- We should move back to the GHC implementation on compilers where --- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) -checkHomeUnitsClosed' ue home_id_set - | OS.null bad_unit_ids = Nothing - | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) - where - bad_unit_ids = upwards_closure OS.\\ home_id_set - rootLoc = mkGeneralSrcSpan (Compat.fsLit "") - - graph :: Graph (Node UnitId UnitId) - graph = graphFromEdgedVerticesUniq graphNodes - - -- downwards closure of graph - downwards_closure - = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps) - | (uid, deps) <- Map.toList (allReachable graph node_key)] - - inverse_closure = transposeG downwards_closure - - upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set] - - all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId) - all_unit_direct_deps - = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C OS.union - (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) - rest - where - external_depends = mapUniqMap (OS.fromList . unitDepends) -#if !MIN_VERSION_ghc(9,7,0) - $ listToUniqMap $ Map.toList -#endif - - $ unitInfoMap this_units - this_units = homeUnitEnv_units this_uis - this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go OS.empty home_id_set - where - go done todo - = case OS.minView todo of - Nothing -> [] - Just (uid, todo') - | OS.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends OS.\\ done) `OS.union` todo' - in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo'' -#endif - --- | Create a mapping from FilePaths to HscEnvEqs --- This combines all the components we know about into --- an appropriate session, which is a multi component --- session on GHC 9.4+ -newComponentCache - :: Recorder (WithPriority Log) - -> [String] -- ^ File extensions to consider - -> NormalizedFilePath -- ^ Path to file that caused the creation of this component - -> HscEnv -- ^ An empty HscEnv - -> [ComponentInfo] -- ^ New components to be loaded - -> [ComponentInfo] -- ^ old, already existing components - -> IO [ [TargetDetails] ] -newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do - let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) - -- When we have multiple components with the same uid, - -- prefer the new one over the old. - -- However, we might have added some targets to the old unit - -- (see special target), so preserve those - unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } - mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) - let dfs = map componentDynFlags $ Map.elems cis - uids = Map.keys cis - logWith recorder Info $ LogMakingNewHscEnv uids - hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 - Compat.initUnits dfs hsc_env - - let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - closure_err_to_multi_err err = - ideErrorWithSource - (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp - (T.pack (Compat.printWithoutUniques (singleMessage err))) - (Just (fmap GhcDriverMessage err)) - multi_errs = map closure_err_to_multi_err closure_errs - bad_units = OS.fromList $ concat $ do - x <- map errMsgDiagnostic closure_errs - DriverHomePackagesNotClosed us <- pure x - pure us - isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units - -- Whenever we spin up a session on Linux, dynamically load libm.so.6 - -- in. We need this in case the binary is statically linked, in which - -- case the interactive session will fail when trying to load - -- ghc-prim, which happens whenever Template Haskell is being - -- evaluated or haskell-language-server's eval plugin tries to run - -- some code. If the binary is dynamically linked, then this will have - -- no effect. - -- See https://github.com/haskell/haskell-language-server/issues/221 - -- We need to do this after the call to setSessionDynFlags initialises - -- the loader - when (os == "linux") $ do - initObjLinker hscEnv' - res <- loadDLL hscEnv' "libm.so.6" - case res of - Nothing -> pure () - Just err -> logWith recorder Error $ LogDLLLoadError err - - forM (Map.elems cis) $ \ci -> do - let df = componentDynFlags ci - thisEnv <- do - -- In GHC 9.4 we have multi component support, and we have initialised all the units - -- above. - -- We just need to set the current unit here - pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' - henv <- newHscEnvEq thisEnv - let targetEnv = (if isBad ci then multi_errs else [], Just henv) - targetDepends = componentDependencyInfo ci - logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) - evaluate $ liftRnf rwhnf $ componentTargets ci - - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends - ctargets <- concatMapM mk (componentTargets ci) - - return (L.nubOrdOn targetTarget ctargets) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) - pure $ dflags - & maybe id setHiDir hiCacheDir - & maybe id setHieDir hieCacheDir - & maybe id setODir oCacheDir - -- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a "hie.yaml" location to all its Target Filepaths and options. type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) @@ -1318,67 +1006,6 @@ type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResu -- It aims to be the reverse of 'FlagsMap'. type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: UnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: UnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | All targets of this components. - , componentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - safeTryIO :: IO a -> IO (Either IOException a) - safeTryIO = Safe.try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) - -- | Memoize an IO function, with the characteristics: -- -- * If multiple people ask for a result simultaneously, make sure you only compute it once. @@ -1396,118 +1023,6 @@ memoIO op = do return (Map.insert k res mp, res) Just res -> return (mp, res) -unit_flags :: [Flag (CmdLineP [String])] -unit_flags = [defFlag "unit" (SepArg addUnit)] - -addUnit :: String -> EwM (CmdLineP [String]) () -addUnit unit_str = liftEwM $ do - units <- getCmdLineState - putCmdLineState (unit_str : units) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m - => NormalizedFilePath - -> ComponentOptions - -> DynFlags - -> FilePath -- ^ root dir, see Note [Root Directory] - -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions 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 - Nothing -> do - (df, targets) <- initOne (map unLoc theOpts') - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- - -- When we have a singleComponent that is caused to be loaded due to a - -- file, we assume the file is part of that component. This is useful - -- for bare GHC sessions, such as many of the ones used in the testsuite - -- - -- We don't do this when we have multiple components, because each - -- component better list all targets or there will be anarchy. - -- It is difficult to know which component to add our file to in - -- that case. - -- Multi unit arguments are likely to come from cabal, which - -- does list all targets. - -- - -- If we don't end up with a target for the current file in the end, then - -- we will report it as an error for that file - let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) - let special_target = Compat.mkSimpleTarget df abs_fp - pure $ (df, special_target : targets) :| [] - where - initMulti unitArgFiles = - forM unitArgFiles $ \f -> do - args <- liftIO $ expandResponse [f] - initOne args - initOne this_opts = do - (dflags', targets') <- addCmdOpts this_opts dflags - let dflags'' = - case unitIdString (homeUnitId_ dflags') of - -- cabal uses main for the unit id of all executable packages - -- This makes multi-component sessions confused about what - -- options to use for that component. - -- Solution: hash the options and use that as part of the unit id - -- This works because there won't be any dependencies on the - -- executable unit. - "main" -> - let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) - hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) - in setHomeUnitId_ hashed_uid dflags' - _ -> dflags' - - let targets = makeTargetsAbsolute root targets' - root = case workingDirectory dflags'' of - Nothing -> compRoot - Just wdir -> compRoot wdir - let dflags''' = - setWorkingDirectory root $ - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ - disableOptimisation $ - Compat.setUpTypedHoles $ - makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory - dflags'' - return (dflags''', targets) - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -setODir :: FilePath -> DynFlags -> DynFlags -setODir f d = - -- override user settings to avoid conflicts leading to recompilation - d { objectDir = Just f} - -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/ghcide/session-loader/Development/IDE/Session/Dependency.hs b/ghcide/session-loader/Development/IDE/Session/Dependency.hs new file mode 100644 index 0000000000..926e0e47b3 --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/Dependency.hs @@ -0,0 +1,35 @@ +module Development.IDE.Session.Dependency where + +import Control.Exception.Safe as Safe +import Data.Either.Extra +import qualified Data.Map.Strict as Map +import Data.Time.Clock +import System.Directory + +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + safeTryIO :: IO a -> IO (Either IOException a) + safeTryIO = Safe.try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs new file mode 100644 index 0000000000..25f377200c --- /dev/null +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Session.Ghc where + +import Control.Monad +import Control.Monad.Extra as Extra +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.Function +import Data.List +import Data.List.Extra as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.Shake hiding (Log, knownTargets, + withHieDb) +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.CmdLine +import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, + TargetModule, Var, + Warning, getOptions) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) +import Development.IDE.GHC.Util +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) +import Development.IDE.Types.Location +import GHC.ResponseFile +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types hiding (Log) +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info), + Recorder, WithPriority, logWith, viaShow, (<+>)) +import System.Directory +import System.FilePath +import System.Info + + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Data.Set as OS +import qualified Development.IDE.GHC.Compat.Util as Compat +import Development.IDE.Session.Dependency +import GHC.Data.Graph.Directed +import Ide.PluginUtils (toAbsolute) + +import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Driver.Errors.Types +import GHC.Types.Error (errMsgDiagnostic, + singleMessage) +import GHC.Unit.State + +data Log + = LogInterfaceFilesCacheDir !FilePath + | LogMakingNewHscEnv ![UnitId] + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) + | LogDLLLoadError !String +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogMakingNewHscEnv inPlaceUnitIds -> + "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) + LogNewComponentCache componentCache -> + "New component cache HscEnvEq:" <+> viaShow componentCache + LogDLLLoadError errorString -> + "Error dynamically loading libm.so.6:" <+> pretty errorString + +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: UnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: UnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | All targets of this components. + , componentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + + +unit_flags :: [Flag (CmdLineP [String])] +unit_flags = [defFlag "unit" (SepArg addUnit)] + +addUnit :: String -> EwM (CmdLineP [String]) () +addUnit unit_str = liftEwM $ do + units <- getCmdLineState + putCmdLineState (unit_str : units) + + +-- | Create a mapping from FilePaths to HscEnvEqs +-- This combines all the components we know about into +-- an appropriate session, which is a multi component +-- session on GHC 9.4+ +newComponentCache + :: Recorder (WithPriority Log) + -> [String] -- ^ File extensions to consider + -> NormalizedFilePath -- ^ Path to file that caused the creation of this component + -> HscEnv -- ^ An empty HscEnv + -> [ComponentInfo] -- ^ New components to be loaded + -> [ComponentInfo] -- ^ old, already existing components + -> IO [ [TargetDetails] ] +newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do + let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) + -- When we have multiple components with the same uid, + -- prefer the new one over the old. + -- However, we might have added some targets to the old unit + -- (see special target), so preserve those + unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } + mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) + let dfs = map componentDynFlags $ Map.elems cis + uids = Map.keys cis + logWith recorder Info $ LogMakingNewHscEnv uids + hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits dfs hsc_env + + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + closure_err_to_multi_err err = + ideErrorWithSource + (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (T.pack (Compat.printWithoutUniques (singleMessage err))) + (Just (fmap GhcDriverMessage err)) + multi_errs = map closure_err_to_multi_err closure_errs + bad_units = OS.fromList $ concat $ do + x <- map errMsgDiagnostic closure_errs + DriverHomePackagesNotClosed us <- pure x + pure us + isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units + -- Whenever we spin up a session on Linux, dynamically load libm.so.6 + -- in. We need this in case the binary is statically linked, in which + -- case the interactive session will fail when trying to load + -- ghc-prim, which happens whenever Template Haskell is being + -- evaluated or haskell-language-server's eval plugin tries to run + -- some code. If the binary is dynamically linked, then this will have + -- no effect. + -- See https://github.com/haskell/haskell-language-server/issues/221 + -- We need to do this after the call to setSessionDynFlags initialises + -- the loader + when (os == "linux") $ do + initObjLinker hscEnv' + res <- loadDLL hscEnv' "libm.so.6" + case res of + Nothing -> pure () + Just err -> logWith recorder Error $ LogDLLLoadError err + + forM (Map.elems cis) $ \ci -> do + let df = componentDynFlags ci + thisEnv <- do + -- In GHC 9.4 we have multi component support, and we have initialised all the units + -- above. + -- We just need to set the current unit here + pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' + henv <- newHscEnvEq thisEnv + let targetEnv = (if isBad ci then multi_errs else [], Just henv) + targetDepends = componentDependencyInfo ci + logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) + evaluate $ liftRnf rwhnf $ componentTargets ci + + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (componentTargets ci) + + return (L.nubOrdOn targetTarget ctargets) + +-- | Throws if package flags are unsatisfiable +setOptions :: GhcMonad m + => NormalizedFilePath + -> ComponentOptions + -> DynFlags + -> FilePath -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions 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 + Nothing -> do + (df, targets) <- initOne (map unLoc theOpts') + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- + -- When we have a singleComponent that is caused to be loaded due to a + -- file, we assume the file is part of that component. This is useful + -- for bare GHC sessions, such as many of the ones used in the testsuite + -- + -- We don't do this when we have multiple components, because each + -- component better list all targets or there will be anarchy. + -- It is difficult to know which component to add our file to in + -- that case. + -- Multi unit arguments are likely to come from cabal, which + -- does list all targets. + -- + -- If we don't end up with a target for the current file in the end, then + -- we will report it as an error for that file + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) + let special_target = Compat.mkSimpleTarget df abs_fp + pure $ (df, special_target : targets) :| [] + where + initMulti unitArgFiles = + forM unitArgFiles $ \f -> do + args <- liftIO $ expandResponse [f] + initOne args + initOne this_opts = do + (dflags', targets') <- addCmdOpts this_opts dflags + let dflags'' = + case unitIdString (homeUnitId_ dflags') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid dflags' + _ -> dflags' + + let targets = makeTargetsAbsolute root targets' + root = case workingDirectory dflags'' of + Nothing -> compRoot + Just wdir -> compRoot wdir + let dflags''' = + setWorkingDirectory root $ + disableWarningsAsErrors $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setBytecodeLinkerOptions $ + disableOptimisation $ + Compat.setUpTypedHoles $ + makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory + dflags'' + return (dflags''', targets) + +addComponentInfo :: + MonadUnliftIO m => + Recorder (WithPriority Log) -> + (String -> [String] -> IO CacheDirs) -> + DependencyInfo -> + NonEmpty (DynFlags, [GHC.Target]) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + Map.Map (Maybe FilePath) [RawComponentInfo] -> + m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) +addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let cacheDirOpts = componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +setODir :: FilePath -> DynFlags -> DynFlags +setODir f d = + -- override user settings to avoid conflicts leading to recompilation + d { objectDir = Just f} + +data CacheDirs = CacheDirs + { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) + pure $ dflags + & maybe id setHiDir hiCacheDir + & maybe id setHieDir hieCacheDir + & maybe id setODir oCacheDir + +getCacheDirsDefault :: String -> [String] -> IO CacheDirs +getCacheDirsDefault prefix opts = do + dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + return $ CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + +setNameCache :: NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +emptyHscEnv :: NameCache -> FilePath -> IO HscEnv +emptyHscEnv nc libDir = do + -- We call setSessionDynFlags so that the loader is initialised + -- We need to do this before we call initUnits. + env <- liftIO $ runGhc (Just libDir) $ + getSessionDynFlags >>= setSessionDynFlags >> getSession + pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) + +-- ---------------------------------------------------------------------------- +-- Target Details +-- ---------------------------------------------------------------------------- + +data TargetDetails = TargetDetails + { + targetTarget :: !Target, + targetEnv :: !(IdeResult HscEnvEq), + targetDepends :: !DependencyInfo, + targetLocations :: ![NormalizedFilePath] + } + +fromTargetId :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider + -> TargetId + -> IdeResult HscEnvEq + -> DependencyInfo + -> IO [TargetDetails] +-- For a target module we consider all the import paths +fromTargetId is exts (GHC.TargetModule modName) env dep = do + let fps = [i moduleNameSlashes modName -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] + let locs = fmap toNormalizedFilePath' fps + return [TargetDetails (TargetModule modName) env dep locs] +-- For a 'TargetFile' we consider all the possible module names +fromTargetId _ _ (GHC.TargetFile f _) env deps = do + let nf = toNormalizedFilePath' f + let other + | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) + | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") + return [TargetDetails (TargetFile nf) env deps [nf, other]] + +-- ---------------------------------------------------------------------------- +-- Backwards compatibility +-- ---------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,13,0) +-- Moved back to implementation in GHC. +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue +#else +-- This function checks the important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +-- GHC had an implementation of this function, but it was horribly inefficient +-- We should move back to the GHC implementation on compilers where +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) +checkHomeUnitsClosed' ue home_id_set + | OS.null bad_unit_ids = Nothing + | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) + where + bad_unit_ids = upwards_closure OS.\\ home_id_set + rootLoc = mkGeneralSrcSpan (Compat.fsLit "") + + graph :: Graph (Node UnitId UnitId) + graph = graphFromEdgedVerticesUniq graphNodes + + -- downwards closure of graph + downwards_closure + = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps) + | (uid, deps) <- Map.toList (allReachable graph node_key)] + + inverse_closure = transposeG downwards_closure + + upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId) + all_unit_direct_deps + = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C OS.union + (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) + rest + where + external_depends = mapUniqMap (OS.fromList . unitDepends) +#if !MIN_VERSION_ghc(9,7,0) + $ listToUniqMap $ Map.toList +#endif + + $ unitInfoMap this_units + this_units = homeUnitEnv_units this_uis + this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go OS.empty home_id_set + where + go done todo + = case OS.minView todo of + Nothing -> [] + Just (uid, todo') + | OS.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends OS.\\ done) `OS.union` todo' + in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo'' +#endif From 7d106cff15a80b38897710ce0ef04a8ba735169b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 19 Jul 2025 02:22:49 +0800 Subject: [PATCH 056/107] fix duplication --- .../session-loader/Development/IDE/Session.hs | 133 ++---------------- 1 file changed, 9 insertions(+), 124 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5e9a710893..ca4cafcd4d 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -91,9 +91,9 @@ import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Core.WorkerThread (withWorkerQueue) -import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Session.Dependency -import Development.IDE.Session.Ghc hiding (Log) +import Development.IDE.Session.Diagnostics (renderCradleError) +import Development.IDE.Session.Ghc hiding (Log) import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..), toNoFileKey) @@ -106,11 +106,11 @@ import Text.ParserCombinators.ReadP (readP_to_S) import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM +import Control.Monad.Trans.Reader +import qualified Development.IDE.Session.Ghc as Ghc import qualified Development.IDE.Session.OrderedSet as S import qualified Focus import qualified StmContainers.Map as STM -import Control.Monad.Trans.Reader -import qualified Development.IDE.Session.Ghc as Ghc data Log = LogSettingInitialDynFlags @@ -689,12 +689,12 @@ data SessionShake = SessionShake } data SessionEnv = SessionEnv - { sessionLspContext :: Maybe (LanguageContextEnv Config) - , sessionRootDir :: FilePath - , sessionIdeOptions :: IdeOptions - , sessionClientConfig :: Config + { sessionLspContext :: Maybe (LanguageContextEnv Config) + , sessionRootDir :: FilePath + , sessionIdeOptions :: IdeOptions + , sessionClientConfig :: Config , sessionSharedNameCache :: NameCache - , sessionLoadingOptions :: SessionLoadingOptions + , sessionLoadingOptions :: SessionLoadingOptions } type SessionM = ReaderT SessionEnv IO @@ -1024,121 +1024,6 @@ memoIO op = do return (Map.insert k res mp, res) Just res -> return (mp, res) -unit_flags :: [Flag (CmdLineP [String])] -unit_flags = [defFlag "unit" (SepArg addUnit)] - -addUnit :: String -> EwM (CmdLineP [String]) () -addUnit unit_str = liftEwM $ do - units <- getCmdLineState - putCmdLineState (unit_str : units) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m - => NormalizedFilePath - -> ComponentOptions - -> DynFlags - -> FilePath -- ^ root dir, see Note [Root Directory] - -> m (NonEmpty (DynFlags, [GHC.Target])) -setOptions 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 - Nothing -> do - (df, targets) <- initOne (map unLoc theOpts') - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- - -- When we have a singleComponent that is caused to be loaded due to a - -- file, we assume the file is part of that component. This is useful - -- for bare GHC sessions, such as many of the ones used in the testsuite - -- - -- We don't do this when we have multiple components, because each - -- component better list all targets or there will be anarchy. - -- It is difficult to know which component to add our file to in - -- that case. - -- Multi unit arguments are likely to come from cabal, which - -- does list all targets. - -- - -- If we don't end up with a target for the current file in the end, then - -- we will report it as an error for that file - let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) - let special_target = Compat.mkSimpleTarget df abs_fp - pure $ (df, special_target : targets) :| [] - where - initMulti unitArgFiles = - forM unitArgFiles $ \f -> do - args <- liftIO $ expandResponse [f] - -- The reponse files may contain arguments like "+RTS", - -- and hie-bios doesn't expand the response files of @-unit@ arguments. - -- Thus, we need to do the stripping here. - initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args - initOne this_opts = do - (dflags', targets') <- addCmdOpts this_opts dflags - let dflags'' = - case unitIdString (homeUnitId_ dflags') of - -- cabal uses main for the unit id of all executable packages - -- This makes multi-component sessions confused about what - -- options to use for that component. - -- Solution: hash the options and use that as part of the unit id - -- This works because there won't be any dependencies on the - -- executable unit. - "main" -> - let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) - hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) - in setHomeUnitId_ hashed_uid dflags' - _ -> dflags' - - let targets = makeTargetsAbsolute root targets' - root = case workingDirectory dflags'' of - Nothing -> compRoot - Just wdir -> compRoot wdir - let dflags''' = - setWorkingDirectory root $ - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ - disableOptimisation $ - Compat.setUpTypedHoles $ - makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory - dflags'' - return (dflags''', targets) - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -setODir :: FilePath -> DynFlags -> DynFlags -setODir f d = - -- override user settings to avoid conflicts leading to recompilation - d { objectDir = Just f} - -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - ---------------------------------------------------------------------------------------------------- data PackageSetupException From ddef7d4f2a1d6c6d82aab9144139759a67ea8e1f Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 15:11:59 +0800 Subject: [PATCH 057/107] Remove RTS options from multi-unit configuration files --- ghcide-test/data/multi-unit/a-1.0.0-inplace | 3 --- ghcide-test/data/multi-unit/c-1.0.0-inplace | 2 -- 2 files changed, 5 deletions(-) diff --git a/ghcide-test/data/multi-unit/a-1.0.0-inplace b/ghcide-test/data/multi-unit/a-1.0.0-inplace index cab2b716ff..a54ea9bc4b 100644 --- a/ghcide-test/data/multi-unit/a-1.0.0-inplace +++ b/ghcide-test/data/multi-unit/a-1.0.0-inplace @@ -16,6 +16,3 @@ base text -XHaskell98 A -+RTS --A32M --RTS diff --git a/ghcide-test/data/multi-unit/c-1.0.0-inplace b/ghcide-test/data/multi-unit/c-1.0.0-inplace index 7421d59279..7201a40de4 100644 --- a/ghcide-test/data/multi-unit/c-1.0.0-inplace +++ b/ghcide-test/data/multi-unit/c-1.0.0-inplace @@ -17,5 +17,3 @@ a-1.0.0-inplace base -XHaskell98 C -+RTS --A32M From d5632d695f05637bb9c4a88907995240922cb4f3 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 15:53:17 +0800 Subject: [PATCH 058/107] format --- cabal.project | 2 -- ghcide/session-loader/Development/IDE/Session/Dependency.hs | 4 ++-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index e4b31e93f5..fed144eb90 100644 --- a/cabal.project +++ b/cabal.project @@ -51,10 +51,8 @@ constraints: allow-newer: cabal-install-parsers:Cabal-syntax, - if impl(ghc >= 9.11) benchmarks: False allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, - diff --git a/ghcide/session-loader/Development/IDE/Session/Dependency.hs b/ghcide/session-loader/Development/IDE/Session/Dependency.hs index 926e0e47b3..deedf809b8 100644 --- a/ghcide/session-loader/Development/IDE/Session/Dependency.hs +++ b/ghcide/session-loader/Development/IDE/Session/Dependency.hs @@ -1,8 +1,8 @@ module Development.IDE.Session.Dependency where -import Control.Exception.Safe as Safe +import Control.Exception.Safe as Safe import Data.Either.Extra -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import Data.Time.Clock import System.Directory From 4c5bc35eb53f3b4436e5670a302fab1a372c9e8b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 17:51:15 +0800 Subject: [PATCH 059/107] apply the patch from https://github.com/haskell/haskell-language-server/commit/c3b61feccbc87857390b9fdb542ce0b3a701d074 --- ghcide-test/data/multi-unit/a-1.0.0-inplace | 3 +++ ghcide-test/data/multi-unit/c-1.0.0-inplace | 2 ++ ghcide/session-loader/Development/IDE/Session/Ghc.hs | 5 ++++- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ghcide-test/data/multi-unit/a-1.0.0-inplace b/ghcide-test/data/multi-unit/a-1.0.0-inplace index a54ea9bc4b..cab2b716ff 100644 --- a/ghcide-test/data/multi-unit/a-1.0.0-inplace +++ b/ghcide-test/data/multi-unit/a-1.0.0-inplace @@ -16,3 +16,6 @@ base text -XHaskell98 A ++RTS +-A32M +-RTS diff --git a/ghcide-test/data/multi-unit/c-1.0.0-inplace b/ghcide-test/data/multi-unit/c-1.0.0-inplace index 7201a40de4..7421d59279 100644 --- a/ghcide-test/data/multi-unit/c-1.0.0-inplace +++ b/ghcide-test/data/multi-unit/c-1.0.0-inplace @@ -17,3 +17,5 @@ a-1.0.0-inplace base -XHaskell98 C ++RTS +-A32M diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index 88157bd990..ab1e5b7977 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -230,7 +230,10 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = initMulti unitArgFiles = forM unitArgFiles $ \f -> do args <- liftIO $ expandResponse [f] - initOne args + -- The reponse files may contain arguments like "+RTS", + -- and hie-bios doesn't expand the response files of @-unit@ arguments. + -- Thus, we need to do the stripping here. + initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args initOne this_opts = do (dflags', targets') <- addCmdOpts this_opts dflags let dflags'' = From d943452c92ece39076d6af94f1d256b650138417 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 18:16:39 +0800 Subject: [PATCH 060/107] add comments for orderedSet --- .../session-loader/Development/IDE/Session.hs | 2 +- .../Development/IDE/Session/OrderedSet.hs | 20 ++++++++++++++++--- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 02a0a13763..6feb6325f2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -509,7 +509,7 @@ incrementVersion state = modifyVar' (version state) succ -- | Get files from the pending file set getPendingFiles :: SessionState -> IO (HashSet FilePath) -getPendingFiles state = atomically $ Set.fromList <$> S.toUnOrderedList (pendingFiles state) +getPendingFiles state = atomically $ S.toHashSet (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM () diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index a2b0a76565..250d6fa086 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -5,6 +5,7 @@ import Control.Concurrent.STM (STM, TQueue, flushTQueue, import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) import Control.Monad (when) import Data.Hashable (Hashable) +import qualified Data.HashSet import qualified Focus import qualified ListT as LT import qualified StmContainers.Set as S @@ -13,6 +14,14 @@ import StmContainers.Set (Set) type OrderedSet a = (TQueue a, Set a) +-- | Insert an element into the ordered set. +-- If the element is not already present, it is added to both the queue and set. +-- If the element already exists, it is moved to the end of the queue to maintain +-- most-recently-inserted ordering semantics. +-- It take O(n), not very good. + +-- Alternative: could preserve original position. +-- I am not sure which one is better. insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s @@ -23,7 +32,6 @@ insert a (que, s) = do mapM_ (writeTQueue que) items return () writeTQueue que a - -- when que $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do @@ -31,6 +39,9 @@ newIO = do s <- S.newIO return (que, s) +-- | Read the first element from the queue. +-- If an element is not in the set, it means it has been deleted, +-- so we retry until we find a valid element that exists in the set. readQueue :: Hashable a => OrderedSet a -> STM a readQueue rs@(que, s) = do f <- readTQueue que @@ -41,8 +52,11 @@ readQueue rs@(que, s) = do lookup :: Hashable a => a -> OrderedSet a -> STM Bool lookup a (_, s) = S.lookup a s +-- | Delete an element from the set. +-- The queue is not modified directly; stale entries are filtered out lazily +-- during reading operations (see 'readQueue'). delete :: Hashable a => a -> OrderedSet a -> STM () delete a (_, s) = S.delete a s -toUnOrderedList :: Hashable a => OrderedSet a -> STM [a] -toUnOrderedList (_, s) = LT.toList $ S.listT s +toHashSet :: Hashable a => OrderedSet a -> Data.HashSet a +toHashSet (_, s) = TreeSet.fromList $ LT.toList $ S.listT s From bd79156a01920b2ba30b5b40b11a96f86762f993 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 18:18:15 +0800 Subject: [PATCH 061/107] update comments for orderedSet --- ghcide/session-loader/Development/IDE/Session/OrderedSet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index 250d6fa086..33d64b53d8 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -20,7 +20,7 @@ type OrderedSet a = (TQueue a, Set a) -- most-recently-inserted ordering semantics. -- It take O(n), not very good. --- Alternative: could preserve original position. +-- Alternative: preserve original position and ignore new one. -- I am not sure which one is better. insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do From dc34df6d38751038fc1c35ccb5dcaabfad4b90b4 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 4 Aug 2025 18:38:57 +0800 Subject: [PATCH 062/107] fix import --- .../Development/IDE/Session/Ghc.hs | 1 + .../Development/IDE/Session/OrderedSet.hs | 18 ++++-------------- 2 files changed, 5 insertions(+), 14 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index ab1e5b7977..7a84263ec9 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -30,6 +30,7 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) import Development.IDE.Types.Location import GHC.ResponseFile +import qualified HIE.Bios.Cradle.Utils as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import Ide.Logger (Pretty (pretty), diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index 33d64b53d8..a66e89f84d 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -16,22 +16,12 @@ type OrderedSet a = (TQueue a, Set a) -- | Insert an element into the ordered set. -- If the element is not already present, it is added to both the queue and set. --- If the element already exists, it is moved to the end of the queue to maintain --- most-recently-inserted ordering semantics. --- It take O(n), not very good. - --- Alternative: preserve original position and ignore new one. --- I am not sure which one is better. +-- If the element already exists, ignore it insert :: Hashable a => a -> OrderedSet a -> STM () insert a (que, s) = do (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s -- if already in the set - -- update the position of the element in the queue - when (not inserted) $ do - items <- filter (==a) <$> flushTQueue que - mapM_ (writeTQueue que) items - return () - writeTQueue que a + when inserted $ writeTQueue que a newIO :: Hashable a => IO (OrderedSet a) newIO = do @@ -58,5 +48,5 @@ lookup a (_, s) = S.lookup a s delete :: Hashable a => a -> OrderedSet a -> STM () delete a (_, s) = S.delete a s -toHashSet :: Hashable a => OrderedSet a -> Data.HashSet a -toHashSet (_, s) = TreeSet.fromList $ LT.toList $ S.listT s +toHashSet :: Hashable a => OrderedSet a -> STM (Data.HashSet.HashSet a) +toHashSet (_, s) = Data.HashSet.fromList <$> LT.toList (S.listT s) From 71d65754ed8ff942c55b9d833985990949553eb1 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 5 Aug 2025 17:17:15 +0800 Subject: [PATCH 063/107] refactor OrderedSet to use a record for better clarity and structure --- .../session-loader/Development/IDE/Session.hs | 1 - .../Development/IDE/Session/OrderedSet.hs | 20 ++++++++++--------- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6feb6325f2..5804ead632 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -56,7 +56,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified HIE.Bios as HieBios -import qualified HIE.Bios.Cradle.Utils as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios diff --git a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs index a66e89f84d..630f1dc4fc 100644 --- a/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs +++ b/ghcide/session-loader/Development/IDE/Session/OrderedSet.hs @@ -1,7 +1,6 @@ module Development.IDE.Session.OrderedSet where -import Control.Concurrent.STM (STM, TQueue, flushTQueue, - newTQueueIO) +import Control.Concurrent.STM (STM, TQueue, newTQueueIO) import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) import Control.Monad (when) import Data.Hashable (Hashable) @@ -12,13 +11,16 @@ import qualified StmContainers.Set as S import StmContainers.Set (Set) -type OrderedSet a = (TQueue a, Set a) +data OrderedSet a = OrderedSet + { insertionOrder :: TQueue a + , elements :: Set a + } -- | Insert an element into the ordered set. -- If the element is not already present, it is added to both the queue and set. -- If the element already exists, ignore it insert :: Hashable a => a -> OrderedSet a -> STM () -insert a (que, s) = do +insert a (OrderedSet que s) = do (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s -- if already in the set when inserted $ writeTQueue que a @@ -27,26 +29,26 @@ newIO :: Hashable a => IO (OrderedSet a) newIO = do que <- newTQueueIO s <- S.newIO - return (que, s) + return (OrderedSet que s) -- | Read the first element from the queue. -- If an element is not in the set, it means it has been deleted, -- so we retry until we find a valid element that exists in the set. readQueue :: Hashable a => OrderedSet a -> STM a -readQueue rs@(que, s) = do +readQueue rs@(OrderedSet que s) = do f <- readTQueue que b <- S.lookup f s -- retry if no files are left in the queue if b then return f else readQueue rs lookup :: Hashable a => a -> OrderedSet a -> STM Bool -lookup a (_, s) = S.lookup a s +lookup a (OrderedSet _ s) = S.lookup a s -- | Delete an element from the set. -- The queue is not modified directly; stale entries are filtered out lazily -- during reading operations (see 'readQueue'). delete :: Hashable a => a -> OrderedSet a -> STM () -delete a (_, s) = S.delete a s +delete a (OrderedSet _ s) = S.delete a s toHashSet :: Hashable a => OrderedSet a -> STM (Data.HashSet.HashSet a) -toHashSet (_, s) = Data.HashSet.fromList <$> LT.toList (S.listT s) +toHashSet (OrderedSet _ s) = Data.HashSet.fromList <$> LT.toList (S.listT s) From dd6b562976f7998200dd143939b844143417035c Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 11 Aug 2025 21:22:24 +0800 Subject: [PATCH 064/107] merge master in --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5804ead632..b1f0b63d21 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -832,7 +832,7 @@ packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do hscEnv <- newEmptyHscEnv newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- liftIO $ getDependencyInfo deps + dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps) -- Now lookup to see whether we are combining with an existing HscEnv -- or making a new one. The lookup returns the HscEnv and a list of -- information about other components loaded into the HscEnv From 24738d61deddc0853f89b9fab23eb1e03a7b5460 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 20 Aug 2025 00:43:14 +0800 Subject: [PATCH 065/107] session: move handleBatchLoadSuccess inside restartSession to avoid stale GhcSession results and lost diagnostics --- .../session-loader/Development/IDE/Session.hs | 48 +++++++++---------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index b1f0b63d21..678acb13f4 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -817,10 +817,30 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv all_target_details <- liftIO $ new_cache old_deps new_deps (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp - - liftIO $ handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets - -- Typecheck all files in the project on startup - liftIO $ loadKnownTargets recorder sessionShake (optCheckProject ideOptions) knownTargetsVar new_deps all_targets + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + liftIO $ do + checkProject <- optCheckProject ideOptions + restartSession sessionShake VFSUnmodified "new component" [] $ do + -- It is necessary to call handleBatchLoadSuccess in restartSession + -- to ensure the GhcSession rule does not return before a new session is started. + -- Otherwise, invalid compilation results may propagate to downstream rules, + -- potentially resulting in lost diagnostics and other issues. + handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + keys2 <- invalidateCache sessionShake + keys1 <- extendKnownTargets recorder knownTargetsVar all_targets + -- Typecheck all files in the project on startup + unless (null new_deps || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] -- | Create a new HscEnv from a hieYaml root and a set of options packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) @@ -897,26 +917,6 @@ extendKnownTargets recorder knownTargetsVar newTargets = do logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) return $ toNoFileKey GetKnownTargets -loadKnownTargets :: Recorder (WithPriority Log) -> SessionShake -> IO Bool -> TVar (Hashed KnownTargets) -> [ComponentInfo] -> [TargetDetails] -> IO () -loadKnownTargets recorder sessionShake getCheckProject knownTargetsVar new_deps targets = do - checkProject <- getCheckProject - - -- The VFS doesn't change on cradle edits, re-use the old one. - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - restartSession sessionShake VFSUnmodified "new component" [] $ do - keys2 <- invalidateCache sessionShake - keys1 <- extendKnownTargets recorder knownTargetsVar targets - unless (null new_deps || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations targets) - void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - shakeExtras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return [keys1, keys2] loadCradleWithNotifications :: Recorder (WithPriority Log) -> From b1237d0a244efafc083106f6229b05e711be7fb7 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 21 Aug 2025 17:14:03 +0800 Subject: [PATCH 066/107] debug --- .github/workflows/test.yml | 2 +- ghcide/src/Development/IDE/Core/Compile.hs | 3 +- ghcide/src/Development/IDE/Core/FileStore.hs | 10 +- ghcide/src/Development/IDE/Core/Shake.hs | 155 +++++++++--------- ghcide/src/Development/IDE/Plugin/Test.hs | 2 +- .../IDE/Graph/Internal/Database.hs | 20 ++- .../Development/IDE/Graph/Internal/Types.hs | 12 +- log copy.txt | 139 ++++++++++++++++ log.txt | 111 +++++++++++++ run_progress_test.sh | 22 +++ 10 files changed, 383 insertions(+), 93 deletions(-) create mode 100644 log copy.txt create mode 100644 log.txt create mode 100644 run_progress_test.sh diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 984758a310..1a9dde30fd 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -114,7 +114,7 @@ jobs: - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory - run: cabal test ghcide-tests || cabal test ghcide-tests + run: cabal test ghcide-tests - if: matrix.test name: Test hls-plugin-api diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 48439e2ff3..1e77a4c2f3 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -793,7 +793,8 @@ atomicFileWrite se targetPath write = do let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir - (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> + atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index e545ec7b14..eb7b459d93 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -82,6 +82,7 @@ data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) | LogShake Shake.Log + | LogGetModificationTime !NormalizedFilePath deriving Show instance Pretty Log where @@ -94,6 +95,8 @@ instance Pretty Log where <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) LogShake msg -> pretty msg + LogGetModificationTime path -> + "Getting modification time for" <+> viaShow path addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do @@ -109,7 +112,8 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogSha getModificationTimeRule :: Recorder (WithPriority Log) -> Rules () -getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> +getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> do + logWith recorder Info $ LogGetModificationTime file getModificationTimeImpl missingFileDiags file getModificationTimeImpl @@ -279,11 +283,9 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) - when checkParents $ - typecheckParents recorder state nfp typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..60bfd6f165 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -130,6 +130,7 @@ import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP +import Control.Concurrent (threadDelay) import Development.IDE.Core.Tracing import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, @@ -183,7 +184,7 @@ import UnliftIO (MonadUnliftIO (withRunI data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] ![Key] !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) @@ -208,7 +209,7 @@ instance Pretty Log where vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) - , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) + , "Keys:" <+> pretty (map show keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" @@ -279,7 +280,7 @@ data ShakeExtras = ShakeExtras ,globals :: TVar (HMap.HashMap TypeRep Dynamic) -- ^ Registry of global state used by rules. -- Small and immutable after startup, so not worth using an STM.Map. - ,state :: Values + ,stateValues :: Values ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic] @@ -328,8 +329,6 @@ data ShakeExtras = ShakeExtras -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , dirtyKeys :: TVar KeySet - -- ^ Set of dirty rule keys since the last Shake run , restartQueue :: TQueue (IO ()) -- ^ Queue of restart actions to be run. , loaderQueue :: TQueue (IO ()) @@ -452,7 +451,7 @@ getIdeOptionsIO ide = do -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) -lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,stateValues} k file = do let readPersistent | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests @@ -466,7 +465,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> atomicallyNamed "lastValueIO 1" $ do - STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state + STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) stateValues return Nothing Just (v,del,mbVer) -> do actual_version <- case mbVer of @@ -474,7 +473,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) `catch` (\(_ :: IOException) -> pure Nothing) atomicallyNamed "lastValueIO 2" $ do - STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state + STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) stateValues Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics @@ -485,7 +484,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case + atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) stateValues) >>= \case Nothing -> readPersistent Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> @@ -599,8 +598,8 @@ deleteValue -> k -> NormalizedFilePath -> STM [Key] -deleteValue ShakeExtras{state} key file = do - STM.delete (toKey key file) state +deleteValue ShakeExtras{stateValues} key file = do + STM.delete (toKey key file) stateValues return [toKey key file] @@ -668,7 +667,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer ideNc <- initNameCache 'r' knownKeyNames shakeExtras <- do globals <- newTVarIO HMap.empty - state <- STM.newIO + stateValues <- STM.newIO diagnostics <- STM.newIO hiddenDiagnostics <- STM.newIO publishedDiagnostics <- STM.newIO @@ -701,7 +700,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv pure ShakeExtras{shakeRecorder = recorder, ..} @@ -721,7 +719,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) + readDirtyKeys = return 0 readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb @@ -741,7 +739,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer getStateKeys :: ShakeExtras -> IO [Key] -getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state +getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . stateValues -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () @@ -749,7 +747,7 @@ shakeSessionInit recorder IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) - initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" + initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" Nothing putMVar shakeSession initSession logWith recorder Debug LogSessionInitialised @@ -798,22 +796,22 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- ioActionBetweenShakeSession + newDirtyKeys <- ioActionBetweenShakeSession -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + -- atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + logWith recorder Debug $ LogBuildSessionRestart reason queue newDirtyKeys stopTime res + return newDirtyKeys ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + (\newDirtyKeys -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason (Just newDirtyKeys)) where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do @@ -846,15 +844,15 @@ data VFSModified = VFSUnmodified | VFSModified !VFS -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. -newSession - :: Recorder (WithPriority Log) - -> ShakeExtras - -> VFSModified - -> ShakeDatabase - -> [DelayedActionInternal] - -> String - -> IO ShakeSession -newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do +-- newSession +-- :: Recorder (WithPriority Log) +-- -> ShakeExtras +-- -> VFSModified +-- -> ShakeDatabase +-- -> [DelayedActionInternal] +-- -> String +-- -> IO ShakeSession +newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKeys = do -- Take a new VFS snapshot case vfsMod of @@ -863,16 +861,27 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue - allPendingKeys <- - if optRunSubset - then Just <$> readTVarIO dirtyKeys - else return Nothing let -- A daemon-like action used to inject additional work -- Runs actions from the work queue sequentially pumpActionThread otSpan = do d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan + -- + -- garbageCollect = do + -- previousNumber <- countQueue actionQueue + -- liftIO $ threadDelay 2_000_000 + -- currentNumber <- countQueue actionQueue + -- if previousNumber + currentNumber == 0 + -- then do + -- logWith recorder Debug LogGarbageCollectingActionQueue + -- -- If the queue is empty, we can garbage collect it + -- -- This will remove all actions that are not running + -- atomicallyNamed "actionQueue - garbage collect" $ garbageCollectQueue actionQueue + -- else do + -- logWith recorder Debug LogGarbageCollectingActionQueueSkipped + + -- TODO figure out how to thread the otSpan into defineEarlyCutoff run _otSpan d = do @@ -887,10 +896,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do workRun restore = withSpan "Shake session" $ \otSpan -> do setTag otSpan "reason" (fromString reason) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) - whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) + -- whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ - restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs + restore $ shakeRunDatabaseForKeys (if optRunSubset then newDirtyKeys else Nothing) shakeDb keysActs return $ do let exception = case res of @@ -953,35 +962,36 @@ garbageCollectDirtyKeys = do garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do - dirtySet <- getDirtySet - garbageCollectKeys "dirty GC" maxAge checkParents dirtySet - -garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] -garbageCollectKeys label maxAge checkParents agedKeys = do - start <- liftIO offsetTime - ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras - (n::Int, garbage) <- liftIO $ - foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys - t <- liftIO start - when (n>0) $ liftIO $ do - logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t - when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) - (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) - return garbage - - where - showKey = show . Q - removeDirtyKey dk values st@(!counter, keys) (k, age) - | age > maxAge - , Just (kt,_) <- fromKeyType k - , not(kt `HSet.member` preservedKeys checkParents) - = atomicallyNamed "GC" $ do - gotIt <- STM.focus (Focus.member <* Focus.delete) k values - when gotIt $ - modifyTVar' dk (insertKeySet k) - return $ if gotIt then (counter+1, k:keys) else st - | otherwise = pure st + return [] + -- dirtySet <- getDirtySet + -- garbageCollectKeys "dirty GC" maxAge checkParents dirtySet + +-- garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +-- garbageCollectKeys label maxAge checkParents agedKeys = do +-- start <- liftIO offsetTime +-- ShakeExtras{state, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras +-- (n::Int, garbage) <- liftIO $ +-- foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys +-- t <- liftIO start +-- when (n>0) $ liftIO $ do +-- logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t +-- when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ +-- LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) +-- (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) +-- return garbage + +-- where +-- showKey = show . Q +-- removeDirtyKey dk values st@(!counter, keys) (k, age) +-- | age > maxAge +-- , Just (kt,_) <- fromKeyType k +-- , not(kt `HSet.member` preservedKeys checkParents) +-- = atomicallyNamed "GC" $ do +-- gotIt <- STM.focus (Focus.member <* Focus.delete) k values +-- when gotIt $ +-- modifyTVar' dk (insertKeySet k) +-- return $ if gotIt then (counter+1, k:keys) else st +-- | otherwise = pure st countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = @@ -1090,8 +1100,8 @@ useWithStaleFast' key file = do -- keep updating the value in the key. waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file - s@ShakeExtras{state} <- askShake - r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file + s@ShakeExtras{stateValues} <- askShake + r <- liftIO $ atomicallyNamed "useStateFast" $ getValues stateValues key file liftIO $ case r of -- block for the result if we haven't computed before Nothing -> do @@ -1235,13 +1245,13 @@ defineEarlyCutoff' -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do - ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras + ShakeExtras{stateValues, progress} <- getShakeExtras options <- getIdeOptions let trans g x = withRunInIO $ \run -> g (run x) (if optSkipProgress options key then id else trans (inProgress progress file)) $ do val <- case mbOld of Just old | mode == RunDependenciesSame -> do - mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file + mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues stateValues key file case mbValue of -- No changes in the dependencies and we have -- an existing successful result. @@ -1257,7 +1267,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do res <- case val of Just res -> return res Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues stateValues key file <&> \case Nothing -> Failed False Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v @@ -1285,8 +1295,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do (A res) $ do -- this hook needs to be run in the same transaction as the key is marked clean -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - setValues state key file res (Vector.fromList diags) - modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + setValues stateValues key file res (Vector.fromList diags) return res where -- Highly unsafe helper to compute the version of a file diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index e24bcfeee9..d99f61ddfd 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -130,7 +130,7 @@ testRequestHandler s (GarbageCollectDirtyKeys parents age) = do res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do - keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ state $ shakeExtras s) + keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ stateValues $ shakeExtras s) return $ Right $ toJSON $ map show keys testRequestHandler s GetFilesOfInterest = do ff <- liftIO $ getFilesOfInterest s diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 359e5ceb6a..afe985bd88 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -39,6 +39,7 @@ import Development.IDE.Graph.Internal.Types import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap +import qualified StmContainers.Set as SSet import System.IO.Unsafe import System.Time.Extra (duration, sleep) @@ -53,6 +54,7 @@ newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 databaseValues <- atomically SMap.new + databaseDirtyKeys <- atomically SSet.new pure Database{..} -- | Increment the step and mark dirty. @@ -60,13 +62,12 @@ newDatabase databaseExtra databaseRules = do incDatabase :: Database -> Maybe [Key] -> IO () -- only some keys are dirty incDatabase db (Just kk) = do - atomicallyNamed "incDatabase" $ modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 - transitiveDirtyKeys <- transitiveDirtySet db kk - for_ (toListKeySet transitiveDirtyKeys) $ \k -> - -- Updating all the keys atomically is not necessary - -- since we assume that no build is mutating the db. - -- Therefore run one transaction per key to minimise contention. - atomicallyNamed "incDatabase" $ SMap.focus updateDirty k (databaseValues db) + atomicallyNamed "incDatabase" $ do + modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 + for_ kk $ \k -> SSet.insert k (databaseDirtyKeys db) + keys <- ListT.toList $ SSet.listT (databaseDirtyKeys db) + transitiveDirtyKeys <- transitiveDirtySet db keys + for_ (toListKeySet transitiveDirtyKeys) $ \k -> SMap.focus updateDirty k (databaseValues db) -- all keys are dirty incDatabase db Nothing = do @@ -220,6 +221,7 @@ compute db@Database{..} stack key mode result = do atomicallyNamed "compute and run hook" $ do runHook SMap.focus (updateStatus $ Clean res) key databaseValues + SSet.delete key databaseDirtyKeys pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () @@ -286,14 +288,14 @@ updateReverseDeps myId db prev new = do getReverseDependencies :: Database -> Key -> STM (Maybe KeySet) getReverseDependencies db = (fmap.fmap) keyReverseDeps . flip SMap.lookup (databaseValues db) -transitiveDirtySet :: Foldable t => Database -> t Key -> IO KeySet +transitiveDirtySet :: Foldable t => Database -> t Key -> STM KeySet transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop where loop x = do seen <- State.get if x `memberKeySet` seen then pure () else do State.put (insertKeySet x seen) - next <- lift $ atomically $ getReverseDependencies database x + next <- lift $ getReverseDependencies database x traverse_ loop (maybe mempty toListKeySet next) -------------------------------------------------------------------------------- diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 34bed42391..cdf384f7f6 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -27,6 +27,7 @@ import GHC.Generics (Generic) import qualified ListT import qualified StmContainers.Map as SMap import StmContainers.Map (Map) +import StmContainers.Set (Set) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO) @@ -109,10 +110,13 @@ onKeyReverseDeps f it@KeyDetails{..} = it{keyReverseDeps = f keyReverseDeps} data Database = Database { - databaseExtra :: Dynamic, - databaseRules :: TheRules, - databaseStep :: !(TVar Step), - databaseValues :: !(Map Key KeyDetails) + databaseExtra :: Dynamic, + databaseRules :: TheRules, + databaseStep :: !(TVar Step), + databaseValues :: !(Map Key KeyDetails), + databaseDirtyKeys :: !(Set Key) + -- ^ The set of dirty keys, which are the keys that have been marked as dirty + -- by the client, it would be removed once the target key is marked as clean. } waitForDatabaseRunningKeys :: Database -> IO () diff --git a/log copy.txt b/log copy.txt new file mode 100644 index 0000000000..5da3744ff0 --- /dev/null +++ b/log copy.txt @@ -0,0 +1,139 @@ +Run #3 +ThreadId 6 ghcide + diagnostics +| 2025-08-1 Cancellation + edit header + GetHieAst: 9T14:55:44.590216Z | Info | Test Project located in directory: /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736 +ThreadId 7 | 2025-08-19T14:55:44.591607Z | Info | Heap statistics are not enabled (RTS option -T is needed) +ThreadId 7 | 2025-08-19T14:55:44.594438Z | Info | Starting LSP server... + If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option! + PluginIds: [ test + , block-command + , ghcide-completions + , core + , ghcide-type-lenses + , LSPRecorderCallback + , ghcide-hover-and-symbols + , ghcide-core ] +ThreadId 16 | 2025-08-19T14:55:44.594799Z | Info | Starting server +ThreadId 16 | 2025-08-19T14:55:44.595197Z | Debug | LSP: set new config: { + "cabalFormattingProvider": "cabal-gild", + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { }, + "sessionLoading": "singleComponent" +} +ThreadId 16 | 2025-08-19T14:55:44.595437Z | Info | Registering IDE configuration: IdeConfiguration {workspaceFolders = fromList [NormalizedUri (-2250868254854792059) "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736"], clientSettings = hashed (Just (Object (fromList [("haskell",Object (fromList [("cabalFormattingProvider",String "cabal-gild"),("checkParents",String "CheckOnSave"),("checkProject",Bool True),("formattingProvider",String "ormolu"),("maxCompletions",Number 40.0),("plugin",Object (fromList [])),("sessionLoading",String "singleComponent")]))])))} +ThreadId 16 | 2025-08-19T14:55:44.603799Z | Info | Started LSP server in 0.01s +ThreadId 16 | 2025-08-19T14:55:44.603902Z | Debug | shouldRunSubset: True +ThreadId 24 | 2025-08-19T14:55:44.603975Z | Debug | Initializing exports map from hiedb +ThreadId 24 | 2025-08-19T14:55:44.604080Z | Debug | Done initializing exports map from hiedb. Size: 0 +ThreadId 20 | 2025-08-19T14:55:44.604735Z | Debug | Shake session initialized +ThreadId 16 | 2025-08-19T14:55:44.605403Z | Debug | VFS: opening file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 16 | 2025-08-19T14:55:44.605775Z | Debug | LSP: set new config: { + "cabalFormattingProvider": "cabal-gild", + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { }, + "sessionLoading": "singleComponent" +} +ThreadId 26 | 2025-08-19T14:55:44.605883Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:44.605934Z | Debug | Configuration changed: Config {checkParents = CheckOnSave, checkProject = True, formattingProvider = "ormolu", cabalFormattingProvider = "cabal-gild", maxCompletions = 40, sessionLoading = PreferSingleComponentLoading, plugins = fromList []} +ThreadId 21 | 2025-08-19T14:55:44.606008Z | Debug | Restarting build session due to config change +Action Queue: [] +Keys: [GetClientSettings; ] +Aborting previous build session took 0.00s +ThreadId 30 | 2025-08-19T14:55:44.606131Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:44.606163Z | Debug | Set files of interst to + [ ( /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs + , Modified {firstOpen = True} ) ] +ThreadId 21 | 2025-08-19T14:55:44.606229Z | Debug | Restarting build session due to /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs (modified) +Action Queue: [] +Keys: [ GetClientSettings; + , GetModificationTime; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs + , IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs ] +Aborting previous build session took 0.00s +ThreadId 20 | 2025-08-19T14:55:44.606351Z | Debug | Opened text document: file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 39 | 2025-08-19T14:55:44.606579Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 42 | 2025-08-19T14:55:44.606750Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 22 | 2025-08-19T14:55:44.606794Z | Debug | Loop: getOptions for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 22 | 2025-08-19T14:55:44.606904Z | Info | Cradle path: Foo.hs +ThreadId 22 | 2025-08-19T14:55:44.606952Z | Warning | No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for Foo.hs. +Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie). +You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error. +ThreadId 46 | 2025-08-19T14:55:44.620269Z | Debug | Cradle: Cradle{ cradleRootDir = "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736", cradleOptsProg = CradleAction: Default} +ThreadId 46 | 2025-08-19T14:55:44.620334Z | Info | invoking build tool to determine build flags (this may take some time depending on the cache) +ThreadId 46 | 2025-08-19T14:55:44.683118Z | Debug | ghc --print-libdir +ThreadId 46 | 2025-08-19T14:55:44.746399Z | Debug | ghc --numeric-version +ThreadId 22 | 2025-08-19T14:55:44.746594Z | Debug | Session loading result: Right (ComponentOptions {componentOptions = [], componentRoot = "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736", componentDependencies = []},"/Users/ares/.ghcup/ghc/9.12.2/lib/ghc-9.12.2/lib","9.12.2") +ThreadId 22 | 2025-08-19T14:55:44.751250Z | Info | Interface files cache directory: /var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/.cache/ghcide/main-da39a3ee5e6b4b0d3255bfef95601890afd80709-da39a3ee5e6b4b0d3255bfef95601890afd80709 +ThreadId 22 | 2025-08-19T14:55:44.761208Z | Info | Making new HscEnv. In-place unit ids: [ main-da39a3ee5e6b4b0d3255bfef95601890afd80709 ] +ThreadId 22 | 2025-08-19T14:55:44.766821Z | Debug | New component cache HscEnvEq: (([],Just HscEnvEq 5),fromList []) +ThreadId 22 | 2025-08-19T14:55:44.767014Z | Info | New loaded files: [ /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs ] +ThreadId 42 | 2025-08-19T14:55:44.767161Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 42 | 2025-08-19T14:55:44.767193Z | Info | Add dependency /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +[] +ThreadId 71 | 2025-08-19T14:55:44.767277Z | Info | Modification time for "v1" +ThreadId 71 | 2025-08-19T14:55:44.767314Z | Info | Modification time for "v1.1" +ThreadId 33 | 2025-08-19T14:55:44.767455Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:44.767514Z | Debug | Known files updated: + fromList [(TargetFile NormalizedFilePath "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs",fromList ["/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs"])] +ThreadId 21 | 2025-08-19T14:55:44.769748Z | Debug | Restarting build session due to new component +Action Queue: [ WaitForIdeRule TypeCheck Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs"} ] +Keys: [ IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs + , GhcSessionIO; + , GetKnownTargets; ] +Aborting previous build session took 0.00s +ThreadId 83 | 2025-08-19T14:55:44.769932Z | Debug | Finished: InitialLoad Took: 0.00s +ThreadId 84 | 2025-08-19T14:55:44.769935Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 87 | 2025-08-19T14:55:44.770101Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 87 | 2025-08-19T14:55:44.770141Z | Info | Add dependency /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +[] +ThreadId 84 | 2025-08-19T14:55:44.779362Z | Warning | Typechecking file mid /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 84 | 2025-08-19T14:55:44.787260Z | Warning | Typechecking file end /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 81 | 2025-08-19T14:55:44.788775Z | Debug | Finished: WaitForIdeRule TypeCheck Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs"} Took: 0.02s +ThreadId 16 | 2025-08-19T14:55:44.990428Z | Error | LSP: no handler for: "non-existent-method" +ThreadId 78 | 2025-08-19T14:55:44.992303Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:44.992398Z | Debug | Set files of interst to + [ ( /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs + , Modified {firstOpen = False} ) ] +ThreadId 21 | 2025-08-19T14:55:44.992559Z | Debug | Restarting build session due to /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs (modified) +Action Queue: [] +Keys: [ GetModificationTime; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs + , IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs ] +Aborting previous build session took 0.00s +ThreadId 20 | 2025-08-19T14:55:44.992780Z | Debug | Modified text document: file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 132 | 2025-08-19T14:55:44.993293Z | Info | Modification time for "v1" +ThreadId 132 | 2025-08-19T14:55:44.993379Z | Info | Modification time for "v1.1" +ThreadId 128 | 2025-08-19T14:55:44.994761Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 126 | 2025-08-19T14:55:44.995047Z | Debug | Finished: WaitForIdeRule GetHieAst Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs"} Took: 0.00s +ThreadId 121 | 2025-08-19T14:55:44.996016Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:44.996055Z | Debug | Restarting build session due to /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs (modified) +Action Queue: [] +Keys: [ GetModificationTime; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs ] +Aborting previous build session took 0.00s +ThreadId 20 | 2025-08-19T14:55:44.996292Z | Debug | Modified text document: file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 153 | 2025-08-19T14:55:45.005864Z | Info | Modification time for "v1" +ThreadId 153 | 2025-08-19T14:55:45.005981Z | Info | Modification time for "v1.1" +ThreadId 149 | 2025-08-19T14:55:45.007173Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 149 | 2025-08-19T14:55:45.007522Z | Warning | Typechecking file mid /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 149 | 2025-08-19T14:55:45.008236Z | Warning | Typechecking file end /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs +ThreadId 148 | 2025-08-19T14:55:45.008442Z | Debug | Finished: WaitForIdeRule TypeCheck Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-26398544736/Foo.hs"} Took: 0.01s +ThreadId 16 | 2025-08-19T14:55:45.211497Z | Error | LSP: no handler for: "non-existent-method" +ThreadId 16 | 2025-08-19T14:55:45.717804Z | Info | LSP: received shutdown +ThreadId 16 | 2025-08-19T14:55:45.717897Z | Debug | Received shutdown message +ThreadId 143 | 2025-08-19T14:55:45.717964Z | Debug | Finished build session +AsyncCancelled +ThreadId 6 | 2025-08-19T14:55:45.718622Z | Debug | Cleaned up temporary directory + GetHieAst: OK (1.13s) + +All 1 tests passed (1.13s) diff --git a/log.txt b/log.txt new file mode 100644 index 0000000000..86afac3e96 --- /dev/null +++ b/log.txt @@ -0,0 +1,111 @@ +Run #4 +Thghcide + diagnostics + Cancellation + edit header +readId 6 | GetHieAst: 2025-08-19T14:55:45.773048Z | Info | Test Project located in directory: /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736 +ThreadId 7 | 2025-08-19T14:55:45.774261Z | Info | Heap statistics are not enabled (RTS option -T is needed) +ThreadId 7 | 2025-08-19T14:55:45.776775Z | Info | Starting LSP server... + If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option! + PluginIds: [ test + , block-command + , ghcide-completions + , core + , ghcide-type-lenses + , LSPRecorderCallback + , ghcide-hover-and-symbols + , ghcide-core ] +ThreadId 16 | 2025-08-19T14:55:45.777036Z | Info | Starting server +ThreadId 16 | 2025-08-19T14:55:45.777814Z | Debug | LSP: set new config: { + "cabalFormattingProvider": "cabal-gild", + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { }, + "sessionLoading": "singleComponent" +} +ThreadId 16 | 2025-08-19T14:55:45.778159Z | Info | Registering IDE configuration: IdeConfiguration {workspaceFolders = fromList [NormalizedUri (-4077115142264691803) "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736"], clientSettings = hashed (Just (Object (fromList [("haskell",Object (fromList [("cabalFormattingProvider",String "cabal-gild"),("checkParents",String "CheckOnSave"),("checkProject",Bool True),("formattingProvider",String "ormolu"),("maxCompletions",Number 40.0),("plugin",Object (fromList [])),("sessionLoading",String "singleComponent")]))])))} +ThreadId 16 | 2025-08-19T14:55:45.785776Z | Info | Started LSP server in 0.01s +ThreadId 16 | 2025-08-19T14:55:45.785884Z | Debug | shouldRunSubset: True +ThreadId 24 | 2025-08-19T14:55:45.785963Z | Debug | Initializing exports map from hiedb +ThreadId 24 | 2025-08-19T14:55:45.786047Z | Debug | Done initializing exports map from hiedb. Size: 0 +ThreadId 20 | 2025-08-19T14:55:45.786560Z | Debug | Shake session initialized +ThreadId 16 | 2025-08-19T14:55:45.786658Z | Debug | VFS: opening file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 16 | 2025-08-19T14:55:45.786871Z | Debug | LSP: set new config: { + "cabalFormattingProvider": "cabal-gild", + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { }, + "sessionLoading": "singleComponent" +} +ThreadId 26 | 2025-08-19T14:55:45.786890Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:45.787076Z | Debug | Set files of interst to + [ ( /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs + , Modified {firstOpen = True} ) ] +ThreadId 21 | 2025-08-19T14:55:45.787154Z | Debug | Restarting build session due to /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs (modified) +Action Queue: [] +Keys: [ GetModificationTime; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs + , IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs ] +Aborting previous build session took 0.00s +ThreadId 20 | 2025-08-19T14:55:45.787225Z | Debug | Opened text document: file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 30 | 2025-08-19T14:55:45.787249Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:45.787316Z | Debug | Configuration changed: Config {checkParents = CheckOnSave, checkProject = True, formattingProvider = "ormolu", cabalFormattingProvider = "cabal-gild", maxCompletions = 40, sessionLoading = PreferSingleComponentLoading, plugins = fromList []} +ThreadId 21 | 2025-08-19T14:55:45.787402Z | Debug | Restarting build session due to config change +Action Queue: [] +Keys: [ GetModificationTime; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs + , IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs + , GetClientSettings; ] +Aborting previous build session took 0.00s +ThreadId 39 | 2025-08-19T14:55:45.787576Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 42 | 2025-08-19T14:55:45.787771Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 22 | 2025-08-19T14:55:45.787834Z | Debug | Loop: getOptions for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 22 | 2025-08-19T14:55:45.787956Z | Info | Cradle path: Foo.hs +ThreadId 22 | 2025-08-19T14:55:45.788018Z | Warning | No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for Foo.hs. +Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie). +You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error. +ThreadId 46 | 2025-08-19T14:55:45.802993Z | Debug | Cradle: Cradle{ cradleRootDir = "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736", cradleOptsProg = CradleAction: Default} +ThreadId 46 | 2025-08-19T14:55:45.803066Z | Info | invoking build tool to determine build flags (this may take some time depending on the cache) +ThreadId 46 | 2025-08-19T14:55:45.868167Z | Debug | ghc --print-libdir +ThreadId 46 | 2025-08-19T14:55:45.932486Z | Debug | ghc --numeric-version +ThreadId 22 | 2025-08-19T14:55:45.932641Z | Debug | Session loading result: Right (ComponentOptions {componentOptions = [], componentRoot = "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736", componentDependencies = []},"/Users/ares/.ghcup/ghc/9.12.2/lib/ghc-9.12.2/lib","9.12.2") +ThreadId 22 | 2025-08-19T14:55:45.936702Z | Info | Interface files cache directory: /var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/.cache/ghcide/main-da39a3ee5e6b4b0d3255bfef95601890afd80709-da39a3ee5e6b4b0d3255bfef95601890afd80709 +ThreadId 22 | 2025-08-19T14:55:45.946351Z | Info | Making new HscEnv. In-place unit ids: [ main-da39a3ee5e6b4b0d3255bfef95601890afd80709 ] +ThreadId 22 | 2025-08-19T14:55:45.956408Z | Debug | New component cache HscEnvEq: (([],Just HscEnvEq 5),fromList []) +ThreadId 22 | 2025-08-19T14:55:45.956697Z | Info | New loaded files: [ /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs ] +ThreadId 42 | 2025-08-19T14:55:45.957872Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 42 | 2025-08-19T14:55:45.957948Z | Info | Add dependency /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +[] +ThreadId 70 | 2025-08-19T14:55:45.959426Z | Info | Modification time for "v1" +ThreadId 70 | 2025-08-19T14:55:45.959473Z | Info | Modification time for "v1.1" +ThreadId 37 | 2025-08-19T14:55:45.959782Z | Debug | Finished build session +AsyncCancelled +ThreadId 21 | 2025-08-19T14:55:45.959915Z | Debug | Known files updated: + fromList [(TargetFile NormalizedFilePath "/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs",fromList ["/private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs"])] +ThreadId 21 | 2025-08-19T14:55:45.959969Z | Debug | Restarting build session due to new component +Action Queue: [ WaitForIdeRule TypeCheck Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs"} ] +Keys: [ IsFileOfInterest; /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs + , GhcSessionIO; + , GetKnownTargets; ] +Aborting previous build session took 0.00s +ThreadId 83 | 2025-08-19T14:55:45.960398Z | Debug | Finished: InitialLoad Took: 0.00s +ThreadId 84 | 2025-08-19T14:55:45.984810Z | Warning | Typechecking file start /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 88 | 2025-08-19T14:55:45.985135Z | Debug | Looking up session cache for /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 88 | 2025-08-19T14:55:45.985189Z | Info | Add dependency /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +[] +ThreadId 84 | 2025-08-19T14:55:45.992785Z | Warning | Typechecking file mid /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 84 | 2025-08-19T14:55:46.004387Z | Warning | Typechecking file end /private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs +ThreadId 81 | 2025-08-19T14:55:46.004765Z | Debug | Finished: WaitForIdeRule TypeCheck Uri {getUri = "file:///private/var/folders/36/_743psv11gv2wrj9dclrpd500000gn/T/hls-test-root/extra-dir-35327754736/Foo.hs"} Took: 0.04s +ThreadId 16 | 2025-08-19T14:55:46.207056Z | Error | LSP: no handler for: "non-existent-method" +ThreadId 16 | 2025-08-19T14:55:46.207691Z | Error | LSP: no handler for: "non-existent-method" +ThreadId 16 | 2025-08-19T14:55:46.208630Z | Info | LSP: received shutdown +ThreadId 16 | 2025-08-19T14:55:46.208805Z | Debug | Received shutdown message +ThreadId 78 | 2025-08-19T14:55:46.209199Z | Debug | Finished build session +AsyncCancelled + GetHieAst: FAIL (0.44s) + ghcide-test/exe/DiagnosticTests.hs:560: + Could not find (DiagnosticSeverity_Warning,(3,0),"Top-level binding",Just "GHC-38417",Nothing) in [] diff --git a/run_progress_test.sh b/run_progress_test.sh new file mode 100644 index 0000000000..24101db454 --- /dev/null +++ b/run_progress_test.sh @@ -0,0 +1,22 @@ +#!/bin/bash + +set -e +# pattern="edit header" + +# test_target="func-test" +# pattern="sends indefinite progress notifications" +test_target="ghcide-tests" +pattern="lower-case drive" +# HLS_TEST_LOG_STDERR=1 +NumberOfRuns=1 + # TASTY_PATTERN="sends indefinite progress notifications" cabal test func-test + # TASTY_PATTERN="notification handlers run in priority order" cabal test ghcide-tests + + +cabal build $test_target +targetBin=$(find dist-newstyle -type f -name $test_target) +for i in {1..$NumberOfRuns}; do + echo "Run #$i" + # TASTY_PATTERN=$pattern HLS_TEST_LOG_STDERR=$HLS_TEST_LOG_STDERR HLS_TEST_HARNESS_STDERR=1 $targetBin + TASTY_PATTERN=$pattern HLS_TEST_HARNESS_STDERR=1 $targetBin +done From 1263b9f843c33728a6a64435f06815186bbed82a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 1 Sep 2025 23:31:22 +0800 Subject: [PATCH 067/107] Refactor garbage collection logic and improve logging in Shake module --- ghcide/src/Development/IDE/Core/FileStore.hs | 2 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 13 +- .../Development/IDE/Core/ProgressReporting.hs | 45 ++- ghcide/src/Development/IDE/Core/Shake.hs | 286 +++++++++++------- ghcide/src/Development/IDE/Plugin/Test.hs | 5 - ghcide/src/Development/IDE/Types/Action.hs | 10 +- .../src/Development/IDE/Graph/Database.hs | 6 +- .../IDE/Graph/Internal/Database.hs | 87 +++++- .../Development/IDE/Graph/Internal/Types.hs | 6 + hls-graph/test/ActionSpec.hs | 9 +- hls-test-utils/src/Development/IDE/Test.hs | 5 +- 11 files changed, 329 insertions(+), 145 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index eb7b459d93..2cde86713f 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -297,7 +297,7 @@ typecheckParentsAction recorder nfp = do case revs of Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs + logWith recorder L.Debug $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 19e0f40e24..abdc224898 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -57,10 +57,6 @@ instance Pretty Log where pretty = \case LogShake msg -> pretty msg -newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) - -instance IsIdeGlobal OfInterestVar - -- | The rule that initialises the files of interest state. ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do @@ -79,9 +75,6 @@ ofInterestRules recorder = do summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 ------------------------------------------------------------- -newtype GarbageCollectVar = GarbageCollectVar (Var Bool) -instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API @@ -154,10 +147,6 @@ kick = do liftIO $ progressUpdate progress ProgressCompleted - GarbageCollectVar var <- getIdeGlobalAction - garbageCollectionScheduled <- liftIO $ readVar var - when garbageCollectionScheduled $ do - void garbageCollectDirtyKeys - liftIO $ writeVar var False signal (Proxy @"kick/done") + diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 3d8a2bf989..20dfbe9e69 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -39,7 +39,11 @@ import Language.LSP.Server (ProgressAmount (..), ProgressCancellable (..), withProgress) import qualified Language.LSP.Server as LSP +import qualified ListT as L import qualified StmContainers.Map as STM +import qualified StmContainers.Set as S +import qualified StmContainers.Set as Set +import StmContainers.Set import UnliftIO (Async, async, bracket, cancel) data ProgressEvent @@ -124,24 +128,25 @@ updateState _ StopProgress st = pure st data InProgressState = InProgressState { -- | Number of files to do - todoVar :: TVar Int, + todoVar :: TVar Int, -- | Number of files done - doneVar :: TVar Int, - currentVar :: STM.Map NormalizedFilePath Int + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int, + workingFileVar :: S.Set NormalizedFilePath } newInProgress :: IO InProgressState -newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO +newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO <*> newIO recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () recordProgress InProgressState {..} file shift = do (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar atomicallyNamed "recordProgress2" $ case (prev, new) of (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1) - (Nothing, _) -> modifyTVar' todoVar (+ 1) + (Nothing, _) -> modifyTVar' todoVar (+ 1) >> S.insert file workingFileVar (Just 0, 0) -> pure () (Just 0, _) -> modifyTVar' doneVar pred - (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, 0) -> modifyTVar' doneVar (+ 1) >> S.delete file workingFileVar (Just _, _) -> pure () where alterPrevAndNew = do @@ -158,16 +163,18 @@ recordProgress InProgressState {..} file shift = do progressReportingNoTrace :: STM Int -> STM Int -> + STM (Maybe T.Text)-> Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> IO ProgressReporting -progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting -progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do +progressReportingNoTrace _ _ _ Nothing _title _optProgressStyle = return noProgressReporting +progressReportingNoTrace todo done mf (Just lspEnv) title optProgressStyle = do progressState <- newVar NotStarted - let _progressUpdate event = liftIO $ updateStateVar $ Event event + let _progressUpdate event = do + liftIO $ updateStateVar $ Event event _progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done mf) return ProgressReporting {..} -- | `progressReporting` initiates a new progress reporting session. @@ -182,12 +189,18 @@ progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) - (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle + (readTVar $ doneVar inProgressState) (getFile $ workingFileVar inProgressState) (Just lspEnv) title optProgressStyle let inProgress :: NormalizedFilePath -> IO a -> IO a inProgress = updateStateForFile inProgressState return PerFileProgressReporting {..} where + getFile :: Set.Set NormalizedFilePath -> STM (Maybe T.Text) + getFile set = do + let lst = S.listT set + x <- L.head lst + return (T.pack . fromNormalizedFilePath <$> x) + updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const where -- This functions are deliberately eta-expanded to avoid space leaks. @@ -203,23 +216,25 @@ progressCounter :: ProgressReportingStyle -> STM Int -> STM Int -> + STM (Maybe T.Text)-> IO () -progressCounter lspEnv title optProgressStyle getTodo getDone = +progressCounter lspEnv title optProgressStyle getTodo getDone mf = LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 where loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do - (todo, done, nextPct) <- liftIO $ atomically $ do + (todo, done, nextPct,file) <- liftIO $ atomically $ do todo <- getTodo done <- getDone + file <- mf let nextFrac :: Double nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo nextPct :: UInt nextPct = floor $ 100 * nextFrac when (nextPct == prevPct) retry - pure (todo, done, nextPct) + pure (todo, done, nextPct, file) - _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + _ <- update (ProgressAmount (Just nextPct) (Just $ (T.pack $ show done) <> "/" <> (T.pack $ show todo) <> maybe mempty (":" <>) file)) loop update nextPct mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 60bfd6f165..53c9939ab2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -24,7 +24,9 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, + KnownTargets(..), Target(..), GarbageCollectVar(..), + OfInterestVar(..), + toKnownFiles, unionKnownTargets, mkKnownTargets, IdeRule, IdeResult, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, @@ -71,8 +73,6 @@ module Development.IDE.Core.Shake( HieDb, HieDbWriter(..), addPersistentRule, - garbageCollectDirtyKeys, - garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), @@ -81,104 +81,119 @@ module Development.IDE.Core.Shake( import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Concurrent.STM.Stats (atomicallyNamed) +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq -import Control.Exception.Extra hiding (bracket_) -import Control.Lens ((%~), (&), (?~)) +import Control.Exception.Extra hiding (bracket_) +import Control.Lens ((%~), (&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe -import Data.Aeson (Result (Success), - toJSON) -import qualified Data.Aeson.Types as A -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.Coerce (coerce) +import Data.Aeson (Result (Success), + toJSON) +import qualified Data.Aeson.Types as A +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce (coerce) import Data.Default import Data.Dynamic -import Data.EnumMap.Strict (EnumMap) -import qualified Data.EnumMap.Strict as EM -import Data.Foldable (find, for_) -import Data.Functor ((<&>)) +import Data.EnumMap.Strict (EnumMap) +import qualified Data.EnumMap.Strict as EM +import Data.Foldable (find, for_) +import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Hashable -import qualified Data.HashMap.Strict as HMap -import Data.HashSet (HashSet) -import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) -import qualified Data.Map.Strict as Map +import qualified Data.HashMap.Strict as HMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet +import Data.List.Extra (foldl', partition, + takeEnd) +import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.SortedList as SL -import Data.String (fromString) -import qualified Data.Text as T +import qualified Data.SortedList as SL +import Data.String (fromString) +import qualified Data.Text as T import Data.Time import Data.Traversable import Data.Tuple.Extra import Data.Typeable import Data.Unique -import Data.Vector (Vector) -import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileUtils (getModTime) +import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Types.Options as Options -import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Server as LSP - -import Control.Concurrent (threadDelay) +import Development.IDE.Types.Options as Options +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Extra (readVar) +import Control.Monad (forever) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int64) +import Data.IORef.Extra (atomicModifyIORef'_, + readIORef) +import Data.Text.Encoding (encodeUtf8) import Development.IDE.Core.Tracing import Development.IDE.Core.WorkerThread -import Development.IDE.GHC.Compat (NameCache, - NameCacheUpdater, - initNameCache, - knownKeyNames) -import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue, - action) -import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database (ShakeDatabase, - shakeGetBuildStep, - shakeGetDatabaseKeys, - shakeNewDatabase, - shakeProfileDatabase, - shakeRunDatabaseForKeys) +import Development.IDE.GHC.Compat (NameCache, + NameCacheUpdater, + initNameCache, + knownKeyNames) +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue, + action) +import qualified Development.IDE.Graph as Shake +import Development.IDE.Graph.Database (ShakeDatabase, + shakeGetBuildStep, + shakeGetDatabaseKeys, + shakeNewDatabase, + shakeProfileDatabase, + shakeRunDatabaseForKeys) +import Development.IDE.Graph.Internal.Database (garbageCollectKeys, + garbageCollectKeys1) +import Development.IDE.Graph.Internal.Types (Database) import Development.IDE.Graph.Rule import Development.IDE.Types.Action +import Development.IDE.Types.Action (isActionQueueEmpty) import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports hiding (exportsMapSize) -import qualified Development.IDE.Types.Exports as ExportsMap +import Development.IDE.Types.Exports hiding (exportsMapSize) +import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Monitoring (Monitoring (..)) +import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Shake import qualified Focus +import GHC.Base (undefined) import GHC.Fingerprint -import GHC.Stack (HasCallStack) -import GHC.TypeLits (KnownSymbol) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol) import HieDb.Types -import Ide.Logger hiding (Priority) -import qualified Ide.Logger as Logger +import Ide.Logger hiding (Priority) +import qualified Ide.Logger as Logger import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS +import qualified Ide.PluginUtils as HLS import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import Ide.Types (CheckParents (CheckOnSave)) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import qualified Language.LSP.Protocol.Types as LSP -import Language.LSP.VFS hiding (start) +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.VFS hiding (start) import qualified "list-t" ListT -import OpenTelemetry.Eventlog hiding (addEvent) -import qualified Prettyprinter as Pretty -import qualified StmContainers.Map as STM -import System.FilePath hiding (makeRelative) -import System.IO.Unsafe (unsafePerformIO) +import OpenTelemetry.Eventlog hiding (addEvent) +import qualified Prettyprinter as Pretty +import qualified StmContainers.Map as STM +import System.FilePath hiding (makeRelative) +import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import UnliftIO (MonadUnliftIO (withRunInIO)) +import UnliftIO (MonadUnliftIO (withRunInIO), + newIORef) data Log @@ -194,13 +209,16 @@ data Log | LogCancelledAction !T.Text | LogSessionInitialised | LogLookupPersistentKey !T.Text - | LogShakeGarbageCollection !T.Text !Int !Seconds + | LogShakeGarbageCollection !T.Text ![Key] !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogMonitering !T.Text !Int64 deriving Show instance Pretty Log where pretty = \case + LogMonitering name value -> + "Monitoring:" <+> pretty name <+> "value:" <+> pretty value LogCreateHieDbExportsMapStart -> "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> @@ -235,8 +253,10 @@ instance Pretty Log where LogSessionInitialised -> "Shake session initialized" LogLookupPersistentKey key -> "LOOKUP PERSISTENT FOR:" <+> pretty key - LogShakeGarbageCollection label number duration -> - pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")" + LogShakeGarbageCollection label victims duration -> + "ShakeGarbageCollect" <+> pretty (showDuration duration) <+> ", reson" <+> pretty label + <+> "removed" <+> pretty (length victims) <+> "keys" + <> hang 2 (pretty (map show victims)) LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) @@ -388,6 +408,8 @@ addPersistentRule k getVal = do void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where +newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +instance IsIdeGlobal OfInterestVar -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) @@ -658,7 +680,7 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting - withHieDb threadQueue opts monitoring rules rootDir = mdo + withHieDb threadQueue opts argMonitoring rules rootDir = mdo -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue restartQueue = tRestartQueue threadQueue @@ -680,8 +702,8 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer indexCompleted <- newTVarIO 0 semanticTokensId <- newTVarIO 0 indexProgressReporting <- progressReportingNoTrace - (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted)) - (readTVar indexCompleted) + (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted) ) + (readTVar indexCompleted) (pure $ Nothing) lspEnv "Indexing" optProgressStyle let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty @@ -717,6 +739,8 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer checkParents <- optCheckParents + logMonitoring <- newLogMonitoring recorder + let monitoring = logMonitoring <> argMonitoring -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras readDirtyKeys = return 0 @@ -724,6 +748,9 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb + readNumActionsRunning = fromIntegral . length <$> atomically (peekInProgress $ actionQueue shakeExtras) + readIsActionQueueEmpty = let boolToInt b = if b then 1 else 0 + in boolToInt <$> atomically (isActionQueueEmpty $ actionQueue shakeExtras) registerGauge monitoring "ghcide.values_count" readValuesCounter registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys @@ -731,12 +758,30 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer registerGauge monitoring "ghcide.exports_map_count" readExportsMap registerGauge monitoring "ghcide.database_count" readDatabaseCount registerCounter monitoring "ghcide.num_builds" readDatabaseStep + registerCounter monitoring "ghcide.num_actions_runnning" readNumActionsRunning + registerCounter monitoring "ghcide.isActionQueueEmpty" readIsActionQueueEmpty stopMonitoring <- start monitoring let ideState = IdeState{..} return ideState +newLogMonitoring :: MonadIO m => Recorder (WithPriority Log) -> m Monitoring +newLogMonitoring logger = do + actions <- newIORef [] + let registerCounter name readA = do + let update = do + val <- readA + logWith logger Info $ LogMonitering name (fromIntegral val) + atomicModifyIORef'_ actions (update :) + registerGauge = registerCounter + let start = do + a <- regularly 10 $ sequence_ =<< readIORef actions + return (cancel a) + return Monitoring{..} + where + regularly :: Seconds -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> sleep delay) getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . stateValues @@ -829,7 +874,7 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue let wait' barrier = waitBarrier barrier `catches` - [ Handler(\BlockedIndefinitelyOnMVar -> + [ Handler (\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) , Handler (\e@AsyncCancelled -> do @@ -842,6 +887,17 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do data VFSModified = VFSUnmodified | VFSModified !VFS +------------------------------------------------------------ +newtype GarbageCollectVar = GarbageCollectVar (Var Bool) +instance IsIdeGlobal GarbageCollectVar + + +getFilesOfInterest :: ShakeExtras -> IO [NormalizedFilePath] +getFilesOfInterest state = do + OfInterestVar var <- getIdeGlobalExtras state + mm <- readVar var + return $ map fst $ HashMap.toList mm + -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. -- newSession @@ -860,6 +916,8 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe VFSModified vfs -> atomically $ writeTVar vfsVar vfs IdeOptions{optRunSubset} <- getIdeOptionsIO extras + isActionQueueEmpty <- fmap ((&&) (null acts)) $ atomicallyNamed "actionQueue - is empty" $ isActionQueueEmpty actionQueue + reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue let -- A daemon-like action used to inject additional work @@ -867,21 +925,6 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe pumpActionThread otSpan = do d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan - -- - -- garbageCollect = do - -- previousNumber <- countQueue actionQueue - -- liftIO $ threadDelay 2_000_000 - -- currentNumber <- countQueue actionQueue - -- if previousNumber + currentNumber == 0 - -- then do - -- logWith recorder Debug LogGarbageCollectingActionQueue - -- -- If the queue is empty, we can garbage collect it - -- -- This will remove all actions that are not running - -- atomicallyNamed "actionQueue - garbage collect" $ garbageCollectQueue actionQueue - -- else do - -- logWith recorder Debug LogGarbageCollectingActionQueueSkipped - - -- TODO figure out how to thread the otSpan into defineEarlyCutoff run _otSpan d = do @@ -900,6 +943,35 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ restore $ shakeRunDatabaseForKeys (if optRunSubset then newDirtyKeys else Nothing) shakeDb keysActs + -- We only do garbage collection if the action queue is empty + -- and if it has been scheduled + $ \db -> do + GarbageCollectVar var <- getIdeGlobalExtras extras + -- checkParentsOpt <- optCheckParents =<< getIdeOptionsIO extras + isGarbageCollectionScheduled <- readVar var + when (isActionQueueEmpty && isGarbageCollectionScheduled) $ do + -- reset garbage collection flag + liftIO $ writeVar var False + start <- offsetTime + -- todo do not remove keys that have FOI as its reverse deps. + -- top level + foiFiles <- getFilesOfInterest extras + -- We find a list of keys that are FOI and their dependencies, + -- and mark them as "needed". Then we delete all dirty keys not marked as needed. + let isFoiRules :: Key -> Bool + isFoiRules k = case fromKeyType k of + Just (_, path) | path `elem` foiFiles || path == "" -> True + _ -> False + + -- victims <- garbageCollectKeys db (isRelevantKey checkParentsOpt) + victims <- garbageCollectKeys1 db isFoiRules + -- also remove the keys from the stateValues map + (mapM_ $ \k -> STM.focus Focus.delete k stateValues) + when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) + (toJSON $ mapMaybe (fmap (show . Q) . fromKeyType) victims) + runTime <- liftIO start + logWith recorder Info $ LogShakeGarbageCollection (T.pack reason) victims runTime return $ do let exception = case res of @@ -954,24 +1026,26 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do -- * position mapping store -- * indexing queue -- * exports map -garbageCollectDirtyKeys :: Action [Key] -garbageCollectDirtyKeys = do - IdeOptions{optCheckParents} <- getIdeOptions - checkParents <- liftIO optCheckParents - garbageCollectDirtyKeysOlderThan 0 checkParents - -garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] -garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do - return [] - -- dirtySet <- getDirtySet - -- garbageCollectKeys "dirty GC" maxAge checkParents dirtySet - --- garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] --- garbageCollectKeys label maxAge checkParents agedKeys = do +-- garbageCollectDirtyKeys :: Action [Key] +-- garbageCollectDirtyKeys = do +-- IdeOptions{optCheckParents} <- getIdeOptions +-- checkParents <- liftIO optCheckParents +-- garbageCollectDirtyKeysOlderThan TVar KeySet 0 checkParents + +-- garbageCollectDirtyKeysOlderThan :: TVar KeySet -> Int -> CheckParents -> Action [Key] +-- garbageCollectDirtyKeysOlderThan dirtyKeys maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do +-- dirtySet <- getDirtySet +-- garbageCollectKeys dirtyKeys "dirty GC" maxAge checkParents dirtySet + +-- garbageCollectKeys :: Database -> String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +-- garbageCollectKeys = undefined +-- garbageCollectKeys dirtyKeys label maxAge checkParents agedKeys = do -- start <- liftIO offsetTime --- ShakeExtras{state, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras +-- ShakeExtras{stateValues, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras -- (n::Int, garbage) <- liftIO $ --- foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys +-- foldM (removeDirtyKey dirtyKeys stateValues) (0,[]) agedKeys +-- -- let n = 0 +-- -- let garbage = [] -- t <- liftIO start -- when (n>0) $ liftIO $ do -- logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t @@ -997,8 +1071,15 @@ countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType) +-- A key is relevant if it is not in the preserved set +-- i.e. it is a key that can be garbage collected +isRelevantKey :: CheckParents -> Key -> Bool +isRelevantKey p k = maybe False (not . (`HSet.member` preservedKeys p) . fst) (fromKeyType k) + preservedKeys :: CheckParents -> HashSet TypeRep preservedKeys checkParents = HSet.fromList $ + -- always preserved + -- always preserved -- always preserved [ typeOf GetFileExists , typeOf GetModificationTime @@ -1161,6 +1242,7 @@ usesWithStale key files = do traverse (lastValue key) files -- we use separate fingerprint rules to trigger the rebuild of the rule +-- fingerKey should depend on the key, so we can use it to trigger a rebuild useWithSeparateFingerprintRule :: (IdeRule k v, IdeRule k1 Fingerprint) => k1 -> k -> NormalizedFilePath -> Action (Maybe v) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index d99f61ddfd..a16f1a9781 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -53,7 +53,6 @@ import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.Time.Extra -type Age = Int data TestRequest = BlockSeconds Seconds -- ^ :: Null | GetInterfaceFilesDir Uri -- ^ :: String @@ -64,7 +63,6 @@ data TestRequest | GetBuildKeysBuilt -- ^ :: [(String] | GetBuildKeysChanged -- ^ :: [(String] | GetBuildEdgesCount -- ^ :: Int - | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) | GetStoredKeys -- ^ :: [String] (list of keys in store) | GetFilesOfInterest -- ^ :: [FilePath] | GetRebuildsCount -- ^ :: Int (number of times we recompiled with GHC) @@ -126,9 +124,6 @@ testRequestHandler s GetBuildKeysVisited = liftIO $ do testRequestHandler s GetBuildEdgesCount = liftIO $ do count <- shakeGetBuildEdges $ shakeDb s return $ Right $ toJSON count -testRequestHandler s (GarbageCollectDirtyKeys parents age) = do - res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents - return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ stateValues $ shakeExtras s) return $ Right $ toJSON $ map show keys diff --git a/ghcide/src/Development/IDE/Types/Action.hs b/ghcide/src/Development/IDE/Types/Action.hs index 0aedd1d0da..225f5b603d 100644 --- a/ghcide/src/Development/IDE/Types/Action.hs +++ b/ghcide/src/Development/IDE/Types/Action.hs @@ -7,7 +7,9 @@ module Development.IDE.Types.Action popQueue, doneQueue, peekInProgress, - abortQueue,countQueue) + abortQueue, + countQueue, + isActionQueueEmpty) where import Control.Concurrent.STM @@ -86,3 +88,9 @@ countQueue ActionQueue{..} = do peekInProgress :: ActionQueue -> STM [DelayedActionInternal] peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress + +isActionQueueEmpty :: ActionQueue -> STM Bool +isActionQueueEmpty ActionQueue {..} = do + emptyQueue <- isEmptyTQueue newActions + inProg <- Set.null <$> readTVar inProgress + return (emptyQueue && inProg) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index bd8601cd16..902fe031d5 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -34,7 +34,7 @@ shakeNewDatabase opts rules = do pure $ ShakeDatabase (length actions) actions db shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a] -shakeRunDatabase = shakeRunDatabaseForKeys Nothing +shakeRunDatabase a b = shakeRunDatabaseForKeys Nothing a b (const $ pure ()) -- | Returns the set of dirty keys annotated with their age (in # of builds) shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] @@ -57,9 +57,11 @@ shakeRunDatabaseForKeys -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] + -> (Database -> IO ()) -> IO [a] -shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do +shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 garbageCollect = do incDatabase db keysChanged + garbageCollect db fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index afe985bd88..78bf196572 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,7 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, incDatabaseRaw, garbageCollectKeys, garbageCollectKeys1) where import Prelude hiding (unzip) @@ -57,6 +57,72 @@ newDatabase databaseExtra databaseRules = do databaseDirtyKeys <- atomically SSet.new pure Database{..} +incDatabaseRaw :: Database -> IO () +incDatabaseRaw db = + atomicallyNamed "incDatabaseRaw" $ do + modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 + +garbageCollectKeys1 :: Database -> (Key -> Bool) -> ([Key] -> STM ()) -> IO [Key] +garbageCollectKeys1 db pred garbageCollectHook = do + -- GC policy: + -- We find a list of keys that are FOI and their dependencies, + -- and mark them as "needed". Then we delete all dirty keys not marked as needed. + let maxAge = 0 -- builds; tune as needed or make configurable upstream + -- on idle but still dirty keys + ks <- getKeysAndVisitAge db + let foiks = [ k | (k, _) <- ks, pred k ] + toKeep <- atomically $ transitiveSet db foiks + dirtyWithAge <- Development.IDE.Graph.Internal.Database.getDirtySet db + let victims = [k | (k, age) <- dirtyWithAge + , age >= maxAge + , not (k `memberKeySet` toKeep)] + unless (null victims) $ do + -- Delete victim keys and remove them from the dirty set + atomically $ do + forM_ victims $ \k -> do + SMap.focus cleanupDirty k (databaseValues db) + -- Remove the victim keys from reverse-dependency sets of remaining keys + let list = SMap.listT (databaseValues db) + ListT.traverse_ (\(k', _) -> + SMap.focus (Focus.adjust (onKeyReverseDeps (\ks -> foldr deleteKeySet ks victims))) k' (databaseValues db) + ) list + garbageCollectHook victims + pure () + return victims + +garbageCollectKeys :: Database -> (Key -> Bool) -> ([Key] -> STM ()) -> IO [Key] +garbageCollectKeys db pred garbageCollectHook = do + -- GC policy: + -- - Select dirty keys whose age >= maxAge and that satisfy the given predicate 'pred'. + -- - For each selected key (a victim), drop its previous result by setting its status to Dirty Nothing + -- and remove that key from every other key's reverse-dependency set. + -- - Finally, run the provided 'garbageCollectHook victims' within the same STM transaction. + let maxAge = 0 -- builds; tune as needed or make configurable upstream + -- on idle but still dirty keys + dirtyWithAge <- Development.IDE.Graph.Internal.Database.getDirtySet db + let victims = [k | (k, age) <- dirtyWithAge, age >= maxAge, pred k] + unless (null victims) $ do + -- Delete victim keys and remove them from the dirty set + atomically $ do + forM_ victims $ \k -> do + SMap.focus cleanupDirty k (databaseValues db) + -- Remove the victim keys from reverse-dependency sets of remaining keys + let list = SMap.listT (databaseValues db) + ListT.traverse_ (\(k', _) -> + SMap.focus (Focus.adjust (onKeyReverseDeps (\ks -> foldr deleteKeySet ks victims))) k' (databaseValues db) + ) list + garbageCollectHook victims + pure () + return victims + + +cleanupDirty :: Monad m => Focus.Focus KeyDetails m () +cleanupDirty = Focus.adjust $ \(KeyDetails status rdeps) -> + let status' + | Dirty _ <- status = Dirty Nothing + | otherwise = status + in KeyDetails status' rdeps + -- | Increment the step and mark dirty. -- Assumes that the database is not running a build incDatabase :: Database -> Maybe [Key] -> IO () @@ -298,6 +364,25 @@ transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop next <- lift $ getReverseDependencies database x traverse_ loop (maybe mempty toListKeySet next) +getDependencies :: Database -> Key -> STM (Maybe KeySet) +getDependencies db k = do + m <- SMap.lookup k (databaseValues db) + pure $ do + KeyDetails st _ <- m + case getDeps st of + UnknownDeps -> Nothing + rd -> Just (getResultDepsDefault mempty rd) + +transitiveSet :: Foldable t => Database -> t Key -> STM KeySet +transitiveSet database = flip State.execStateT mempty . traverse_ loop + where + loop x = do + seen <- State.get + if x `memberKeySet` seen then pure () else do + State.put (insertKeySet x seen) + next <- lift $ getDependencies database x + traverse_ loop (maybe mempty toListKeySet next) + -------------------------------------------------------------------------------- -- Asynchronous computations with cancellation diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index cdf384f7f6..a99e817621 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -148,6 +148,12 @@ getResult (Clean re) = Just re getResult (Dirty m_re) = m_re getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result +getDeps :: Status -> ResultDeps +getDeps (Clean re) = resultDeps re +getDeps (Dirty (Just re)) = resultDeps re +getDeps (Dirty Nothing) = UnknownDeps +getDeps (Running _ _ re _) = resultDeps re + waitRunning :: Status -> IO () waitRunning Running{..} = runningWait waitRunning _ = return () diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 97ab5555ac..3a0b8d6829 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -48,14 +48,17 @@ spec = do let parent = newKey CountRule -- instruct to RunDependenciesChanged then CountRule should be recomputed -- result should be changed 0, build 1 - _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2 + _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] $ \_ -> return () + -- count = 2 -- since child changed = parent build -- instruct to RunDependenciesSame then CountRule should not be recomputed -- result should be changed 0, build 1 - _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] $ \_ -> return () + -- count = 2 -- invariant child changed = parent build should remains after RunDependenciesSame -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238 - _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] $ \_ -> return () + -- count = 2 c1 <- readMVar count1 c1 `shouldBe` 2 describe "apply1" $ do diff --git a/hls-test-utils/src/Development/IDE/Test.hs b/hls-test-utils/src/Development/IDE/Test.hs index a1bd2dec0e..70390ad118 100644 --- a/hls-test-utils/src/Development/IDE/Test.hs +++ b/hls-test-utils/src/Development/IDE/Test.hs @@ -25,7 +25,6 @@ module Development.IDE.Test , flushMessages , waitForAction , getInterfaceFilesDir - , garbageCollectDirtyKeys , getFilesOfInterest , waitForTypecheck , waitForBuildQueue @@ -218,8 +217,8 @@ waitForAction key TextDocumentIdentifier{_uri} = getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) -garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] -garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) +-- garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] +-- garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) getStoredKeys :: Session [Text] getStoredKeys = callTestPlugin GetStoredKeys From 26aa9be0cf5602cf4e1fc90bde5505733e33c652 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 1 Sep 2025 23:14:04 +0800 Subject: [PATCH 068/107] hls-graph: simplify AIO; scoped cancellation; fewer threads; safe cleanup - Replace ad-hoc AIO with structured concurrency (TVar + async registry); builder returns results directly; remove lazy splitIO/unsafePerformIO - Reduce redundant thread creation; use per-key builderOne and STM retry instead of spawning; fewer races - Add AsyncParentKill (ThreadId, Step) and treat it as async; use cancelWith from Shake to scope cancellation to the current session - Mask critical sections and do uninterruptible cleanup on exception (mark Dirty) to avoid stuck Running and hangs - Adjust types/wiring (Running payload, runAIO takes Step, compute/refresh signatures); minor tweaks in ghcide Shake/Plugin.Test Fixes #4718 --- ghcide/src/Development/IDE/Core/Shake.hs | 26 +-- ghcide/src/Development/IDE/Plugin/Test.hs | 4 +- .../src/Development/IDE/Graph/Database.hs | 9 +- .../Development/IDE/Graph/Internal/Action.hs | 2 + .../IDE/Graph/Internal/Database.hs | 220 +++++++----------- .../Development/IDE/Graph/Internal/Types.hs | 43 ++-- 6 files changed, 129 insertions(+), 175 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 53c9939ab2..99db32ae94 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -94,7 +94,6 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) import Data.Default import Data.Dynamic @@ -107,8 +106,7 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) +import Data.List.Extra (partition, takeEnd) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL @@ -130,15 +128,11 @@ import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import Control.Concurrent (threadDelay) -import Control.Concurrent.Extra (readVar) -import Control.Monad (forever) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int64) import Data.IORef.Extra (atomicModifyIORef'_, readIORef) -import Data.Text.Encoding (encodeUtf8) import Development.IDE.Core.Tracing import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, @@ -149,18 +143,16 @@ import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue, action) import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database (ShakeDatabase, +import Development.IDE.Graph.Database (AsyncParentKill (..), + ShakeDatabase, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) -import Development.IDE.Graph.Internal.Database (garbageCollectKeys, - garbageCollectKeys1) -import Development.IDE.Graph.Internal.Types (Database) +import Development.IDE.Graph.Internal.Database (garbageCollectKeys1) import Development.IDE.Graph.Rule import Development.IDE.Types.Action -import Development.IDE.Types.Action (isActionQueueEmpty) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports hiding (exportsMapSize) import qualified Development.IDE.Types.Exports as ExportsMap @@ -169,7 +161,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Shake import qualified Focus -import GHC.Base (undefined) import GHC.Fingerprint import GHC.Stack (HasCallStack) import GHC.TypeLits (KnownSymbol) @@ -179,7 +170,6 @@ import qualified Ide.Logger as Logger import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types -import Ide.Types (CheckParents (CheckOnSave)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -948,7 +938,8 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe $ \db -> do GarbageCollectVar var <- getIdeGlobalExtras extras -- checkParentsOpt <- optCheckParents =<< getIdeOptionsIO extras - isGarbageCollectionScheduled <- readVar var + -- isGarbageCollectionScheduled <- readVar var + let isGarbageCollectionScheduled = False when (isActionQueueEmpty && isGarbageCollectionScheduled) $ do -- reset garbage collection flag liftIO $ writeVar var False @@ -989,8 +980,11 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe -- Cancelling is required to flush the Shake database when either -- the filesystem or the Ghc configuration have changed + step <- shakeGetBuildStep shakeDb let cancelShakeSession :: IO () - cancelShakeSession = cancel workThread + cancelShakeSession = do + tid <- myThreadId + cancelWith workThread $ AsyncParentKill tid step pure (ShakeSession{..}) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index a16f1a9781..be03cd5a8a 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -39,7 +39,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, shakeGetCleanKeys) import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited), - Step (Step)) + Step) import qualified Development.IDE.Graph.Internal.Types as Graph import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) @@ -140,7 +140,7 @@ getDatabaseKeys :: (Graph.Result -> Step) getDatabaseKeys field db = do keys <- shakeGetCleanKeys db step <- shakeGetBuildStep db - return [ k | (k, res) <- keys, field res == Step step] + return [ k | (k, res) <- keys, field res == step] parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 902fe031d5..65d946b547 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -1,4 +1,5 @@ module Development.IDE.Graph.Database( + AsyncParentKill(..), ShakeDatabase, ShakeValue, shakeNewDatabase, @@ -8,8 +9,8 @@ module Development.IDE.Graph.Database( shakeGetBuildStep, shakeGetDatabaseKeys, shakeGetDirtySet, - shakeGetCleanKeys - ,shakeGetBuildEdges) where + shakeGetCleanKeys, + shakeGetBuildEdges) where import Control.Concurrent.STM.Stats (readTVarIO) import Data.Dynamic import Data.Maybe @@ -42,9 +43,9 @@ shakeGetDirtySet (ShakeDatabase _ _ db) = Development.IDE.Graph.Internal.Database.getDirtySet db -- | Returns the build number -shakeGetBuildStep :: ShakeDatabase -> IO Int +shakeGetBuildStep :: ShakeDatabase -> IO Step shakeGetBuildStep (ShakeDatabase _ _ db) = do - Step s <- readTVarIO $ databaseStep db + s <- readTVarIO $ databaseStep db return s -- Only valid if we never pull on the results, which we don't diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 6d47d9b511..30ef078ffe 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -81,8 +81,10 @@ actionFork act k = do isAsyncException :: SomeException -> Bool isAsyncException e + | Just (_ :: SomeAsyncException) <- fromException e = True | Just (_ :: AsyncCancelled) <- fromException e = True | Just (_ :: AsyncException) <- fromException e = True + | Just (_ :: AsyncParentKill) <- fromException e = True | Just (_ :: ExitCode) <- fromException e = True | otherwise = False diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 78bf196572..0d27b73a11 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,16 +8,17 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, incDatabaseRaw, garbageCollectKeys, garbageCollectKeys1) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, AsyncParentKill(..), garbageCollectKeys, garbageCollectKeys1) where import Prelude hiding (unzip) import Control.Concurrent.Async import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats (STM, atomically, +import Control.Concurrent.STM.Stats (STM, TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, - readTVarIO) + readTVar, readTVarIO, + retry) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -25,7 +26,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic -import Data.Either import Data.Foldable (for_, traverse_) import Data.IORef.Extra import Data.Maybe @@ -40,8 +40,9 @@ import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap import qualified StmContainers.Set as SSet -import System.IO.Unsafe import System.Time.Extra (duration, sleep) +import UnliftIO (MonadUnliftIO (withRunInIO)) +import qualified UnliftIO.Exception as UE #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) @@ -57,11 +58,6 @@ newDatabase databaseExtra databaseRules = do databaseDirtyKeys <- atomically SSet.new pure Database{..} -incDatabaseRaw :: Database -> IO () -incDatabaseRaw db = - atomicallyNamed "incDatabaseRaw" $ do - modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 - garbageCollectKeys1 :: Database -> (Key -> Bool) -> ([Key] -> STM ()) -> IO [Key] garbageCollectKeys1 db pred garbageCollectHook = do -- GC policy: @@ -145,7 +141,7 @@ incDatabase db Nothing = do updateDirty :: Monad m => Focus.Focus KeyDetails m () updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> let status' - | Running _ _ _ x <- status = Dirty x + | Running _ x <- status = Dirty x | Clean x <- status = Dirty (Just x) | otherwise = status in KeyDetails status' rdeps @@ -155,11 +151,8 @@ build => Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do - built <- runAIO $ do - built <- builder db stack (fmap newKey keys) - case built of - Left clean -> return clean - Right dirty -> liftIO dirty + step <- readTVarIO $ databaseStep db + !built <- runAIO step $ builder db stack (fmap newKey keys) let (ids, vs) = unzip built pure (ids, fmap (asV . resultValue) vs) where @@ -169,44 +162,41 @@ build db stack keys = do -- | Build a list of keys and return their results. -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. -builder - :: Traversable f => Database -> Stack -> f Key -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))) +builder :: (Traversable f) => Database -> Stack -> f Key -> AIO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined -builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do - -- Things that I need to force before my results are ready - toForce <- liftIO $ newTVarIO [] - current <- liftIO $ readTVarIO databaseStep - results <- liftIO $ for keys $ \id -> - -- Updating the status of all the dependencies atomically is not necessary. - -- Therefore, run one transaction per dep. to avoid contention - atomicallyNamed "builder" $ do - -- Spawn the id if needed - status <- SMap.lookup id databaseValues - val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of - Clean r -> pure r - Running _ force val _ - | memberStack id stack -> throw $ StackException stack - | otherwise -> do - modifyTVar' toForce (Wait force :) - pure val - Dirty s -> do - let act = run (refresh db stack id s) - (force, val) = splitIO (join act) - SMap.focus (updateStatus $ Running current force val s) id databaseValues - modifyTVar' toForce (Spawn force:) - pure val - - pure (id, val) - - toForceList <- liftIO $ readTVarIO toForce - let waitAll = run $ waitConcurrently_ toForceList - case toForceList of - [] -> return $ Left results - _ -> return $ Right $ do - waitAll - pure results - - +builder db stack keys = do + keyWaits <- for keys $ \k -> builderOne db stack k + !res <- for keyWaits $ \(k, waitR) -> do + !v<- liftIO waitR + return (k, v) + return res + +builderOne :: Database -> Stack -> Key -> AIO (Key, IO Result) +builderOne db@Database {..} stack id = UE.mask $ \restore -> do + current <- liftIO $ readTVarIO databaseStep + (k, registerWaitResult) <- liftIO $ atomicallyNamed "builder" $ do + -- Spawn the id if needed + status <- SMap.lookup id databaseValues + val <- + let refreshRsult s = do + let act = + restore $ asyncWithCleanUp $ + refresh db stack id s + `UE.onException` (UE.uninterruptibleMask_ $ liftIO (atomicallyNamed "builder - onException" (SMap.focus updateDirty id databaseValues))) + + SMap.focus (updateStatus $ Running current s) id databaseValues + return act + in case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Dirty mbr -> refreshRsult mbr + Running step _mbr + | step /= current -> error $ "Inconsistent database state: key " ++ show id ++ " is marked Running at step " ++ show step ++ " but current step is " ++ show current + | memberStack id stack -> throw $ StackException stack + | otherwise -> retry + Clean r -> pure . pure . pure $ r + -- force here might contains async exceptions from previous runs + pure (id, val) + waitR <- registerWaitResult + return (k, waitR) -- | isDirty -- only dirty when it's build time is older than the changed time of one of its dependencies isDirty :: Foldable t => Result -> t (a, Result) -> Bool @@ -222,41 +212,37 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result refreshDeps visited db stack key result = \case -- no more deps to refresh - [] -> liftIO $ compute db stack key RunDependenciesSame (Just result) + [] -> compute' db stack key RunDependenciesSame (Just result) (dep:deps) -> do let newVisited = dep <> visited res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) - case res of - Left res -> if isDirty result res + if isDirty result res -- restart the computation if any of the deps are dirty - then liftIO $ compute db stack key RunDependenciesChanged (Just result) + then compute' db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps else refreshDeps newVisited db stack key result deps - Right iores -> do - res <- liftIO iores - if isDirty result res - then liftIO $ compute db stack key RunDependenciesChanged (Just result) - else refreshDeps newVisited db stack key result deps - --- | Refresh a key: -refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) + + +-- refresh :: Database -> Stack -> Key -> Maybe Result -> IO Result -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined +refresh :: Database -> Stack -> Key -> Maybe Result -> AIO Result refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps) - (Right stack, _) -> - asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) + (Right stack, _) -> compute' db stack key RunDependenciesChanged result +compute' :: Database -> Stack -> Key -> RunMode -> Maybe Result -> AIO Result +compute' db stack key mode result = liftIO $ compute db stack key mode result -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode - deps <- newIORef UnknownDeps + deps <- liftIO $ newIORef UnknownDeps (execution, RunResult{..}) <- - duration $ runReaderT (fromAction act) $ SAction db deps stack - curStep <- readTVarIO databaseStep - deps <- readIORef deps + liftIO $ duration $ runReaderT (fromAction act) $ SAction db deps stack + curStep <- liftIO $ readTVarIO databaseStep + deps <- liftIO $ readIORef deps let lastChanged = maybe curStep resultChanged result let lastBuild = maybe curStep resultBuilt result -- changed time is always older than or equal to build time @@ -279,12 +265,12 @@ compute db@Database{..} stack key mode result = do -- If an async exception strikes before the deps have been recorded, -- we won't be able to accurately propagate dirtiness for this key -- on the next build. - void $ + liftIO $ void $ updateReverseDeps key db (getResultDepsDefault mempty previousDeps) deps _ -> pure () - atomicallyNamed "compute and run hook" $ do + liftIO $ atomicallyNamed "compute and run hook" $ do runHook SMap.focus (updateStatus $ Clean res) key databaseValues SSet.delete key databaseDirtyKeys @@ -315,18 +301,6 @@ getKeysAndVisitAge db = do getAge Result{resultVisited = Step s} = curr - s return keysWithVisitAge -------------------------------------------------------------------------------- --- Lazy IO trick - -data Box a = Box {fromBox :: a} - --- | Split an IO computation into an unsafe lazy value and a forcing computation -splitIO :: IO a -> (IO (), a) -splitIO act = do - let act2 = Box <$> act - let res = unsafePerformIO act2 - (void $ evaluate res, fromBox res) - --------------------------------------------------------------------------------- -- Reverse dependencies -- | Update the reverse dependencies of an Id @@ -388,14 +362,29 @@ transitiveSet database = flip State.execStateT mempty . traverse_ loop -- | A simple monad to implement cancellation on top of 'Async', -- generalizing 'withAsync' to monadic scopes. -newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a } +newtype AIO a = AIO { unAIO :: ReaderT (TVar [Async ()]) IO a } deriving newtype (Applicative, Functor, Monad, MonadIO) +data AsyncParentKill = AsyncParentKill ThreadId Step + deriving (Show, Eq) + +instance Exception AsyncParentKill where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + -- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises -runAIO :: AIO a -> IO a -runAIO (AIO act) = do - asyncs <- newIORef [] - runReaderT act asyncs `onException` cleanupAsync asyncs +runAIO :: Step -> AIO a -> IO a +runAIO s (AIO act) = do + asyncsRef <- newTVarIO [] + -- Log the exact exception (including async exceptions) before cleanup, + -- then rethrow to preserve previous semantics. + runReaderT act asyncsRef `onException` do + asyncs <- atomically $ do + r <- readTVar asyncsRef + modifyTVar' asyncsRef $ const [] + return r + tid <- myThreadId + cleanupAsync asyncs tid s -- | Like 'async' but with built-in cancellation. -- Returns an IO action to wait on the result. @@ -406,7 +395,7 @@ asyncWithCleanUp act = do -- mask to make sure we keep track of the spawned async liftIO $ uninterruptibleMask $ \restore -> do a <- async $ restore io - atomicModifyIORef'_ st (void a :) + atomically $ modifyTVar' st (void a :) return $ wait a unliftAIO :: AIO a -> AIO (IO a) @@ -414,19 +403,17 @@ unliftAIO act = do st <- AIO ask return $ runReaderT (unAIO act) st -newtype RunInIO = RunInIO (forall a. AIO a -> IO a) +instance MonadUnliftIO AIO where + withRunInIO k = do + st <- AIO ask + liftIO $ k (\aio -> runReaderT (unAIO aio) st) -withRunInIO :: (RunInIO -> AIO b) -> AIO b -withRunInIO k = do - st <- AIO ask - k $ RunInIO (\aio -> runReaderT (unAIO aio) st) - -cleanupAsync :: IORef [Async a] -> IO () +cleanupAsync :: [Async a] -> ThreadId -> Step -> IO () -- mask to make sure we interrupt all the asyncs -cleanupAsync ref = uninterruptibleMask $ \unmask -> do - asyncs <- atomicModifyIORef' ref ([],) +cleanupAsync asyncs tid step = uninterruptibleMask $ \unmask -> do -- interrupt all the asyncs without waiting - mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs + -- mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs + mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) asyncs -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr unless (null asyncs) $ do @@ -435,32 +422,3 @@ cleanupAsync ref = uninterruptibleMask $ \unmask -> do traceM "cleanupAsync: waiting for asyncs to finish" withAsync warnIfTakingTooLong $ \_ -> mapM_ waitCatch asyncs - -data Wait - = Wait {justWait :: !(IO ())} - | Spawn {justWait :: !(IO ())} - -fmapWait :: (IO () -> IO ()) -> Wait -> Wait -fmapWait f (Wait io) = Wait (f io) -fmapWait f (Spawn io) = Spawn (f io) - -waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ())) -waitOrSpawn (Wait io) = pure $ Left io -waitOrSpawn (Spawn io) = Right <$> async io - -waitConcurrently_ :: [Wait] -> AIO () -waitConcurrently_ [] = pure () -waitConcurrently_ [one] = liftIO $ justWait one -waitConcurrently_ many = do - ref <- AIO ask - -- spawn the async computations. - -- mask to make sure we keep track of all the asyncs. - (asyncs, syncs) <- liftIO $ uninterruptibleMask $ \unmask -> do - waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many - let (syncs, asyncs) = partitionEithers waits - liftIO $ atomicModifyIORef'_ ref (asyncs ++) - return (asyncs, syncs) - -- work on the sync computations - liftIO $ sequence_ syncs - -- wait for the async computations before returning - liftIO $ traverse_ wait asyncs diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index a99e817621..03e1f0b657 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -6,7 +6,6 @@ module Development.IDE.Graph.Internal.Types where import Control.Concurrent.STM (STM) -import Control.Monad ((>=>)) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -81,8 +80,8 @@ getDatabase :: Action Database getDatabase = Action $ asks actionDatabase -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. -waitForDatabaseRunningKeysAction :: Action () -waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys +-- waitForDatabaseRunningKeysAction :: Action () +-- waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys --------------------------------------------------------------------- -- DATABASE @@ -90,7 +89,7 @@ waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunni data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int - deriving newtype (Eq,Ord,Hashable,Show) + deriving newtype (Eq,Ord,Hashable,Show,Num,Enum,Real,Integral) --------------------------------------------------------------------- -- Keys @@ -119,8 +118,8 @@ data Database = Database { -- by the client, it would be removed once the target key is marked as clean. } -waitForDatabaseRunningKeys :: Database -> IO () -waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) +-- waitForDatabaseRunningKeys :: Database -> IO () +-- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) getDatabaseValues :: Database -> IO [(Key, Status)] getDatabaseValues = atomically @@ -133,30 +132,30 @@ data Status = Clean !Result | Dirty (Maybe Result) | Running { - runningStep :: !Step, - runningWait :: !(IO ()), - runningResult :: Result, -- LAZY - runningPrev :: !(Maybe Result) + runningStep :: !Step, + -- runningWait :: !(IO ()), + -- runningResult :: Result, -- LAZY + runningPrev :: !(Maybe Result) } viewDirty :: Step -> Status -> Status -viewDirty currentStep (Running s _ _ re) | currentStep /= s = Dirty re +viewDirty currentStep (Running s re) | currentStep /= s = Dirty re viewDirty _ other = other getResult :: Status -> Maybe Result -getResult (Clean re) = Just re -getResult (Dirty m_re) = m_re -getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result +getResult (Clean re) = Just re +getResult (Dirty m_re) = m_re +getResult (Running _ m_re) = m_re -- watch out: this returns the previous result getDeps :: Status -> ResultDeps -getDeps (Clean re) = resultDeps re -getDeps (Dirty (Just re)) = resultDeps re -getDeps (Dirty Nothing) = UnknownDeps -getDeps (Running _ _ re _) = resultDeps re - -waitRunning :: Status -> IO () -waitRunning Running{..} = runningWait -waitRunning _ = return () +getDeps (Clean re) = resultDeps re +getDeps (Dirty (Just re)) = resultDeps re +getDeps (Dirty Nothing) = UnknownDeps +getDeps (Running _ re) = maybe mempty resultDeps re + +-- waitRunning :: Status -> IO () +-- waitRunning Running{..} = runningWait +-- waitRunning _ = return () data Result = Result { resultValue :: !Value, From a21981034d3d8ffbb7b04f0792b0f86859038c95 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 6 Sep 2025 07:09:08 +0800 Subject: [PATCH 069/107] update hls-graph runtime --- ghcide/ghcide.cabal | 1 - .../session-loader/Development/IDE/Session.hs | 18 +- ghcide/src/Development/IDE/Core/Compile.hs | 4 +- ghcide/src/Development/IDE/Core/FileStore.hs | 8 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 13 +- .../Development/IDE/Core/PositionMapping.hs | 1 - ghcide/src/Development/IDE/Core/Rules.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 337 ++++++++---------- .../src/Development/IDE/Core/WorkerThread.hs | 59 --- ghcide/src/Development/IDE/GHC/Compat.hs | 1 - .../src/Development/IDE/LSP/LanguageServer.hs | 206 +++++++---- ghcide/src/Development/IDE/Plugin/Test.hs | 4 +- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 1 - hls-graph/hls-graph.cabal | 6 + hls-graph/src/Development/IDE/Graph.hs | 3 +- .../src/Development/IDE/Graph/Database.hs | 34 +- .../Development/IDE/Graph/Internal/Action.hs | 52 ++- .../IDE/Graph/Internal/Database.hs | 269 ++++---------- .../Development/IDE/Graph/Internal/Types.hs | 100 ++++-- hls-graph/src/Development/IDE/WorkerThread.hs | 164 +++++++++ hls-graph/test/ActionSpec.hs | 71 ++-- hls-graph/test/DatabaseSpec.hs | 36 +- 22 files changed, 733 insertions(+), 657 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Core/WorkerThread.hs create mode 100644 hls-graph/src/Development/IDE/WorkerThread.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index d1c6d907a3..359b742771 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -142,7 +142,6 @@ library Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.Core.UseStale - Development.IDE.Core.WorkerThread Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.CmdLine diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 678acb13f4..2d43724f3f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -81,7 +81,6 @@ import Data.Void import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) -import Control.Concurrent.STM.TQueue import Control.Monad.Trans.Cont (ContT (ContT, runContT)) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) @@ -89,7 +88,6 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (withWorkerQueue) import Development.IDE.Session.Dependency import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Session.Ghc hiding (Log) @@ -108,6 +106,7 @@ import qualified Control.Monad.STM as STM import Control.Monad.Trans.Reader import qualified Development.IDE.Session.Ghc as Ghc import qualified Development.IDE.Session.OrderedSet as S +import Development.IDE.WorkerThread import qualified Focus import qualified StmContainers.Map as STM @@ -133,10 +132,13 @@ data Log | LogLookupSessionCache !FilePath | LogTime !String | LogSessionGhc Ghc.Log + | LogSessionWorkerThread LogWorkerThread deriving instance Show Log + instance Pretty Log where pretty = \case + LogSessionWorkerThread lt -> pretty lt LogTime s -> "Time:" <+> pretty s LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp @@ -362,7 +364,7 @@ runWithDb recorder fp = ContT $ \k -> do _ <- withWriteDbRetryable deleteMissingRealFiles _ <- withWriteDbRetryable garbageCollectTypeNames - runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan -> + runContT (withWorkerQueue (logWith (cmapWithPrio LogSessionWorkerThread recorder) Debug) "hiedb thread" (writer withWriteDbRetryable)) $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) where writer withHieDbRetryable l = do @@ -589,7 +591,7 @@ newSessionState = do -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] @@ -617,7 +619,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- see Note [Serializing runs in separate thread] -- Start the getOptionsLoop if the queue is empty - liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ do + liftIO $ atomically $ Extra.whenM (isEmptyTaskQueue que) $ do let newSessionLoadingOptions = SessionLoadingOptions { findCradle = cradleLoc , .. @@ -636,7 +638,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , sessionLoadingOptions = newSessionLoadingOptions } - writeTQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) + writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. @@ -935,7 +937,7 @@ loadCradleWithNotifications recorder sessionState loadCradle hieYaml cfp = do when (isNothing hieYaml) $ logWith recorder Warning $ LogCradleNotFound lfpLog cradle <- liftIO $ loadCradle hieYaml rootDir - when (isTesting) $ mRunLspT lspEnv $ + when isTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is @@ -1034,7 +1036,7 @@ data PackageSetupException { compileTime :: !Version , runTime :: !Version } - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception PackageSetupException diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 1e77a4c2f3..8065e56325 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -114,7 +114,6 @@ import qualified GHC.Runtime.Loader as Loader import GHC.Tc.Gen.Splice import GHC.Types.Error import GHC.Types.ForeignStubs -import GHC.Types.HpcInfo import GHC.Types.TypeEnv -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -151,6 +150,7 @@ import GHC.Iface.Ext.Types (NameEntityInfo) #if MIN_VERSION_ghc(9,12,0) import Development.IDE.Import.FindImports +import Development.IDE.WorkerThread (writeTaskQueue) #endif --Simple constants to make sure the source is consistently named @@ -883,7 +883,7 @@ indexHieFile se mod_summary srcPath !hash hf = do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \withHieDb -> do + writeTaskQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2cde86713f..07b104d26d 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -25,7 +25,6 @@ module Development.IDE.Core.FileStore( ) where import Control.Concurrent.STM.Stats (STM, atomically) -import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Exception import Control.Lens ((^.)) import Control.Monad.Extra @@ -52,6 +51,7 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options import Development.IDE.Types.Shake (toKey) +import Development.IDE.WorkerThread (writeTaskQueue) import HieDb.Create (deleteMissingRealFiles) import Ide.Logger (Pretty (pretty), Priority (Info), @@ -82,7 +82,6 @@ data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) | LogShake Shake.Log - | LogGetModificationTime !NormalizedFilePath deriving Show instance Pretty Log where @@ -95,8 +94,6 @@ instance Pretty Log where <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) LogShake msg -> pretty msg - LogGetModificationTime path -> - "Getting modification time for" <+> viaShow path addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do @@ -113,7 +110,6 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogSha getModificationTimeRule :: Recorder (WithPriority Log) -> Rules () getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> do - logWith recorder Info $ LogGetModificationTime file getModificationTimeImpl missingFileDiags file getModificationTimeImpl @@ -306,7 +302,7 @@ typecheckParentsAction recorder nfp = do setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index abdc224898..19e0f40e24 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -57,6 +57,10 @@ instance Pretty Log where pretty = \case LogShake msg -> pretty msg +newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + +instance IsIdeGlobal OfInterestVar + -- | The rule that initialises the files of interest state. ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do @@ -75,6 +79,9 @@ ofInterestRules recorder = do summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 +------------------------------------------------------------ +newtype GarbageCollectVar = GarbageCollectVar (Var Bool) +instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API @@ -147,6 +154,10 @@ kick = do liftIO $ progressUpdate progress ProgressCompleted + GarbageCollectVar var <- getIdeGlobalAction + garbageCollectionScheduled <- liftIO $ readVar var + when garbageCollectionScheduled $ do + void garbageCollectDirtyKeys + liftIO $ writeVar var False signal (Proxy @"kick/done") - diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index de02f5b1f7..41f9ca50e0 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -28,7 +28,6 @@ import Control.Lens ((^.)) import Control.Monad import Data.Algorithm.Diff import Data.Bifunctor -import Data.List import qualified Data.Text as T import qualified Data.Vector.Unboxed as V import qualified Language.LSP.Protocol.Lens as L diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index c123c9d4a8..8273570aca 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -722,7 +722,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do itExists <- getFileExists nfp when itExists $ void $ do use_ GetPhysicalModificationTime nfp - logWith recorder Logger.Info $ LogDependencies file deps + logWith recorder Logger.Debug $ LogDependencies file deps mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 99db32ae94..94bf9f733c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -24,10 +24,8 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets(..), Target(..), GarbageCollectVar(..), - OfInterestVar(..), - toKnownFiles, unionKnownTargets, mkKnownTargets, - IdeRule, IdeResult, + KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, + IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, @@ -73,6 +71,8 @@ module Development.IDE.Core.Shake( HieDb, HieDbWriter(..), addPersistentRule, + garbageCollectDirtyKeys, + garbageCollectDirtyKeysOlderThan, Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), @@ -94,6 +94,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) import Data.Default import Data.Dynamic @@ -128,13 +129,10 @@ import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Int (Int64) -import Data.IORef.Extra (atomicModifyIORef'_, - readIORef) +import Control.Exception (Exception (fromException)) +import Data.Either (isLeft, isRight, + lefts) import Development.IDE.Core.Tracing -import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, initNameCache, @@ -143,14 +141,17 @@ import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue, action) import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database (AsyncParentKill (..), - ShakeDatabase, +import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, - shakeRunDatabaseForKeys) -import Development.IDE.Graph.Internal.Database (garbageCollectKeys1) + shakeRunDatabaseForKeys, + shakeShutDatabase) +import Development.IDE.Graph.Internal.Action (runActionInDb) +import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) +import Development.IDE.Graph.Internal.Types (Step (..), + getShakeStep) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -160,6 +161,7 @@ import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Shake +import Development.IDE.WorkerThread import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) @@ -182,33 +184,33 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import UnliftIO (MonadUnliftIO (withRunInIO), - newIORef) +import UnliftIO (MonadUnliftIO (withRunInIO)) +import qualified UnliftIO.Exception as UE + data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] ![Key] !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds - | LogBuildSessionFinish !(Maybe SomeException) + | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()]) | LogDiagsDiffButNoLspEnv ![FileDiagnostic] | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic | LogCancelledAction !T.Text | LogSessionInitialised | LogLookupPersistentKey !T.Text - | LogShakeGarbageCollection !T.Text ![Key] !Seconds + | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] - | LogMonitering !T.Text !Int64 + | LogShakeText !T.Text deriving Show instance Pretty Log where pretty = \case - LogMonitering name value -> - "Monitoring:" <+> pretty name <+> "value:" <+> pretty value + LogShakeText msg -> pretty msg LogCreateHieDbExportsMapStart -> "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> @@ -217,7 +219,7 @@ instance Pretty Log where vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) - , "Keys:" <+> pretty (map show keyBackLog) + , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" @@ -225,10 +227,18 @@ instance Pretty Log where hsep [ "Finished:" <+> pretty (actionName delayedAct) , "Took:" <+> pretty (showDuration seconds) ] - LogBuildSessionFinish e -> + LogBuildSessionFinish step e -> vcat [ "Finished build session" - , pretty (fmap displayException e) ] + , "Step:" <+> pretty (show step) + , "Result:" <+> case e of + Left ex -> "Exception:" <+> pretty (show ex) + Right rs -> + if all isRight rs then + "Success" + else + "Exceptions in actions:" <+> pretty (fmap displayException $ lefts rs) + ] LogDiagsDiffButNoLspEnv fileDiagnostics -> "updateFileDiagnostics published different from new diagnostics - file diagnostics:" <+> pretty (showDiagnosticsColored fileDiagnostics) @@ -243,10 +253,8 @@ instance Pretty Log where LogSessionInitialised -> "Shake session initialized" LogLookupPersistentKey key -> "LOOKUP PERSISTENT FOR:" <+> pretty key - LogShakeGarbageCollection label victims duration -> - "ShakeGarbageCollect" <+> pretty (showDuration duration) <+> ", reson" <+> pretty label - <+> "removed" <+> pretty (length victims) <+> "keys" - <> hang 2 (pretty (map show victims)) + LogShakeGarbageCollection label number duration -> + pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")" LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) @@ -265,12 +273,15 @@ data HieDbWriter -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality -type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type RestartQueue = TaskQueue (IO ()) +type LoaderQueue = TaskQueue (IO ()) + data ThreadQueue = ThreadQueue { tIndexQueue :: IndexQueue - , tRestartQueue :: TQueue (IO ()) - , tLoaderQueue :: TQueue (IO ()) + , tRestartQueue :: RestartQueue + , tLoaderQueue :: LoaderQueue } -- Note [Semantic Tokens Cache Location] @@ -339,9 +350,11 @@ data ShakeExtras = ShakeExtras -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , restartQueue :: TQueue (IO ()) + , dirtyKeys :: TVar KeySet + -- ^ Set of dirty rule keys since the last Shake run + , restartQueue :: RestartQueue -- ^ Queue of restart actions to be run. - , loaderQueue :: TQueue (IO ()) + , loaderQueue :: LoaderQueue -- ^ Queue of loader actions to be run. } @@ -398,14 +411,14 @@ addPersistentRule k getVal = do void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where -newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) -instance IsIdeGlobal OfInterestVar +-- data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras - pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map + let file = Map.lookup (filePathToUri' nf) vfs + pure $! file -- Don't leak a reference to the entire map -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS @@ -670,7 +683,7 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting - withHieDb threadQueue opts argMonitoring rules rootDir = mdo + withHieDb threadQueue opts monitoring rules rootDir = mdo -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue restartQueue = tRestartQueue threadQueue @@ -712,11 +725,13 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase + restartQueue opts { shakeExtra = newShakeExtra shakeExtras } rules shakeSession <- newEmptyMVar @@ -729,18 +744,13 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer checkParents <- optCheckParents - logMonitoring <- newLogMonitoring recorder - let monitoring = logMonitoring <> argMonitoring -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = return 0 + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb - readNumActionsRunning = fromIntegral . length <$> atomically (peekInProgress $ actionQueue shakeExtras) - readIsActionQueueEmpty = let boolToInt b = if b then 1 else 0 - in boolToInt <$> atomically (isActionQueueEmpty $ actionQueue shakeExtras) registerGauge monitoring "ghcide.values_count" readValuesCounter registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys @@ -748,30 +758,12 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer registerGauge monitoring "ghcide.exports_map_count" readExportsMap registerGauge monitoring "ghcide.database_count" readDatabaseCount registerCounter monitoring "ghcide.num_builds" readDatabaseStep - registerCounter monitoring "ghcide.num_actions_runnning" readNumActionsRunning - registerCounter monitoring "ghcide.isActionQueueEmpty" readIsActionQueueEmpty stopMonitoring <- start monitoring let ideState = IdeState{..} return ideState -newLogMonitoring :: MonadIO m => Recorder (WithPriority Log) -> m Monitoring -newLogMonitoring logger = do - actions <- newIORef [] - let registerCounter name readA = do - let update = do - val <- readA - logWith logger Info $ LogMonitering name (fromIntegral val) - atomicModifyIORef'_ actions (update :) - registerGauge = registerCounter - let start = do - a <- regularly 10 $ sequence_ =<< readIORef actions - return (cancel a) - return Monitoring{..} - where - regularly :: Seconds -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> sleep delay) getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . stateValues @@ -782,7 +774,7 @@ shakeSessionInit recorder IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) - initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" Nothing + initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" putMVar shakeSession initSession logWith recorder Debug LogSessionInitialised @@ -831,22 +823,21 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - newDirtyKeys <- ioActionBetweenShakeSession + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + keys <- ioActionBetweenShakeSession -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - -- atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - + backlog <- readTVarIO $ dirtyKeys shakeExtras -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue newDirtyKeys stopTime res - return newDirtyKeys + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 - (\newDirtyKeys -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason (Just newDirtyKeys)) + (\() -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where logErrorAfter :: Seconds -> IO () -> IO () logErrorAfter seconds action = flip withAsync (const action) $ do @@ -864,7 +855,7 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue let wait' barrier = waitBarrier barrier `catches` - [ Handler (\BlockedIndefinitelyOnMVar -> + [ Handler(\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) , Handler (\e@AsyncCancelled -> do @@ -877,28 +868,17 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do data VFSModified = VFSUnmodified | VFSModified !VFS ------------------------------------------------------------- -newtype GarbageCollectVar = GarbageCollectVar (Var Bool) -instance IsIdeGlobal GarbageCollectVar - - -getFilesOfInterest :: ShakeExtras -> IO [NormalizedFilePath] -getFilesOfInterest state = do - OfInterestVar var <- getIdeGlobalExtras state - mm <- readVar var - return $ map fst $ HashMap.toList mm - -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. --- newSession --- :: Recorder (WithPriority Log) --- -> ShakeExtras --- -> VFSModified --- -> ShakeDatabase --- -> [DelayedActionInternal] --- -> String --- -> IO ShakeSession -newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKeys = do +newSession + :: Recorder (WithPriority Log) + -> ShakeExtras + -> VFSModified + -> ShakeDatabase + -> [DelayedActionInternal] + -> String + -> IO ShakeSession +newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do -- Take a new VFS snapshot case vfsMod of @@ -906,18 +886,28 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe VFSModified vfs -> atomically $ writeTVar vfsVar vfs IdeOptions{optRunSubset} <- getIdeOptionsIO extras - isActionQueueEmpty <- fmap ((&&) (null acts)) $ atomicallyNamed "actionQueue - is empty" $ isActionQueueEmpty actionQueue - reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue + step <- getShakeStep shakeDb + allPendingKeys <- + if optRunSubset + then Just <$> readTVarIO dirtyKeys + else return Nothing let -- A daemon-like action used to inject additional work -- Runs actions from the work queue sequentially - pumpActionThread otSpan = do + logResult :: Show a => String -> [Either SomeException a] -> IO () + logResult label results = for_ results $ \case + Left e | Just (AsyncParentKill _ _) <- fromException e -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " failed: " ++ show e) + Left e -> logWith recorder Error $ LogShakeText (T.pack $ label ++ " failed: " ++ show e) + Right r -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " finished: " ++ show r) + pumpActionThread = do d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue - actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan + r <- runActionInDb [run d] + liftIO $ logResult "pumpActionThread" r + pumpActionThread -- TODO figure out how to thread the otSpan into defineEarlyCutoff - run _otSpan d = do + run d = do start <- liftIO offsetTime getAction d liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue @@ -925,66 +915,34 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason newDirtyKe logWith recorder (actionPriority d) $ LogDelayedAction d runTime -- The inferred type signature doesn't work in ghc >= 9.0.1 - workRun :: (forall b. IO b -> IO b) -> IO (IO ()) + workRun :: (forall b. IO b -> IO b) -> IO () workRun restore = withSpan "Shake session" $ \otSpan -> do setTag otSpan "reason" (fromString reason) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) - -- whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) - let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) + whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) + let keysActs = pumpActionThread : map run (reenqueued ++ acts) res <- try @SomeException $ - restore $ shakeRunDatabaseForKeys (if optRunSubset then newDirtyKeys else Nothing) shakeDb keysActs - -- We only do garbage collection if the action queue is empty - -- and if it has been scheduled - $ \db -> do - GarbageCollectVar var <- getIdeGlobalExtras extras - -- checkParentsOpt <- optCheckParents =<< getIdeOptionsIO extras - -- isGarbageCollectionScheduled <- readVar var - let isGarbageCollectionScheduled = False - when (isActionQueueEmpty && isGarbageCollectionScheduled) $ do - -- reset garbage collection flag - liftIO $ writeVar var False - start <- offsetTime - -- todo do not remove keys that have FOI as its reverse deps. - -- top level - foiFiles <- getFilesOfInterest extras - -- We find a list of keys that are FOI and their dependencies, - -- and mark them as "needed". Then we delete all dirty keys not marked as needed. - let isFoiRules :: Key -> Bool - isFoiRules k = case fromKeyType k of - Just (_, path) | path `elem` foiFiles || path == "" -> True - _ -> False - - -- victims <- garbageCollectKeys db (isRelevantKey checkParentsOpt) - victims <- garbageCollectKeys1 db isFoiRules - -- also remove the keys from the stateValues map - (mapM_ $ \k -> STM.focus Focus.delete k stateValues) - when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) - (toJSON $ mapMaybe (fmap (show . Q) . fromKeyType) victims) - runTime <- liftIO start - logWith recorder Info $ LogShakeGarbageCollection (T.pack reason) victims runTime - return $ do - let exception = - case res of - Left e -> Just e - _ -> Nothing - logWith recorder Debug $ LogBuildSessionFinish exception + restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs + logWith recorder Debug $ LogBuildSessionFinish step $ res -- Do the work in a background thread - workThread <- asyncWithUnmask workRun + parentTid <- myThreadId + workThread <- asyncWithUnmask $ \x -> do + childThreadId <- myThreadId + logWith recorder Info $ LogShakeText ("Starting shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")") + workRun x - -- run the wrap up in a separate thread since it contains interruptible - -- commands (and we are not using uninterruptible mask) - -- TODO: can possibly swallow exceptions? - _ <- async $ join $ wait workThread -- Cancelling is required to flush the Shake database when either -- the filesystem or the Ghc configuration have changed - step <- shakeGetBuildStep shakeDb + let cancelShakeSession :: IO () cancelShakeSession = do + logWith recorder Info $ LogShakeText ("Starting shake cancellation: " <> " (" <> T.pack (show reason) <> ")") tid <- myThreadId cancelWith workThread $ AsyncParentKill tid step + shakeShutDatabase shakeDb + pure (ShakeSession{..}) @@ -1020,60 +978,50 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do -- * position mapping store -- * indexing queue -- * exports map --- garbageCollectDirtyKeys :: Action [Key] --- garbageCollectDirtyKeys = do --- IdeOptions{optCheckParents} <- getIdeOptions --- checkParents <- liftIO optCheckParents --- garbageCollectDirtyKeysOlderThan TVar KeySet 0 checkParents - --- garbageCollectDirtyKeysOlderThan :: TVar KeySet -> Int -> CheckParents -> Action [Key] --- garbageCollectDirtyKeysOlderThan dirtyKeys maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do --- dirtySet <- getDirtySet --- garbageCollectKeys dirtyKeys "dirty GC" maxAge checkParents dirtySet - --- garbageCollectKeys :: Database -> String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] --- garbageCollectKeys = undefined --- garbageCollectKeys dirtyKeys label maxAge checkParents agedKeys = do --- start <- liftIO offsetTime --- ShakeExtras{stateValues, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras --- (n::Int, garbage) <- liftIO $ --- foldM (removeDirtyKey dirtyKeys stateValues) (0,[]) agedKeys --- -- let n = 0 --- -- let garbage = [] --- t <- liftIO start --- when (n>0) $ liftIO $ do --- logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t --- when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ --- LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) --- (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) --- return garbage - --- where --- showKey = show . Q --- removeDirtyKey dk values st@(!counter, keys) (k, age) --- | age > maxAge --- , Just (kt,_) <- fromKeyType k --- , not(kt `HSet.member` preservedKeys checkParents) --- = atomicallyNamed "GC" $ do --- gotIt <- STM.focus (Focus.member <* Focus.delete) k values --- when gotIt $ --- modifyTVar' dk (insertKeySet k) --- return $ if gotIt then (counter+1, k:keys) else st --- | otherwise = pure st +garbageCollectDirtyKeys :: Action [Key] +garbageCollectDirtyKeys = do + IdeOptions{optCheckParents} <- getIdeOptions + checkParents <- liftIO optCheckParents + garbageCollectDirtyKeysOlderThan 0 checkParents + +garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] +garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do + dirtySet <- getDirtySet + garbageCollectKeys "dirty GC" maxAge checkParents dirtySet + +garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +garbageCollectKeys label maxAge checkParents agedKeys = do + start <- liftIO offsetTime + ShakeExtras{stateValues, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras + (n::Int, garbage) <- liftIO $ + foldM (removeDirtyKey dirtyKeys stateValues) (0,[]) agedKeys + t <- liftIO start + when (n>0) $ liftIO $ do + logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t + when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) + (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) + return garbage + + where + showKey = show . Q + removeDirtyKey dk values st@(!counter, keys) (k, age) + | age > maxAge + , Just (kt,_) <- fromKeyType k + , not(kt `HSet.member` preservedKeys checkParents) + = atomicallyNamed "GC" $ do + gotIt <- STM.focus (Focus.member <* Focus.delete) k values + when gotIt $ + modifyTVar' dk (insertKeySet k) + return $ if gotIt then (counter+1, k:keys) else st + | otherwise = pure st countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType) --- A key is relevant if it is not in the preserved set --- i.e. it is a key that can be garbage collected -isRelevantKey :: CheckParents -> Key -> Bool -isRelevantKey p k = maybe False (not . (`HSet.member` preservedKeys p) . fst) (fromKeyType k) - preservedKeys :: CheckParents -> HashSet TypeRep preservedKeys checkParents = HSet.fromList $ - -- always preserved - -- always preserved -- always preserved [ typeOf GetFileExists , typeOf GetModificationTime @@ -1236,7 +1184,6 @@ usesWithStale key files = do traverse (lastValue key) files -- we use separate fingerprint rules to trigger the rebuild of the rule --- fingerKey should depend on the key, so we can use it to trigger a rebuild useWithSeparateFingerprintRule :: (IdeRule k v, IdeRule k1 Fingerprint) => k1 -> k -> NormalizedFilePath -> Action (Maybe v) @@ -1321,7 +1268,7 @@ defineEarlyCutoff' -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do - ShakeExtras{stateValues, progress} <- getShakeExtras + ShakeExtras{stateValues, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions let trans g x = withRunInIO $ \run -> g (run x) (if optSkipProgress options key then id else trans (inProgress progress file)) $ do @@ -1372,6 +1319,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- this hook needs to be run in the same transaction as the key is marked clean -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] setValues stateValues key file res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file @@ -1453,8 +1401,9 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics let uri' = filePathToUri' fp - let delay = if null newDiags then 0.1 else 0 - registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do + -- let delay = if null newDiags then 0.1 else 0 + -- registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do + withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do join $ mask_ $ do lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs deleted file mode 100644 index 6d141c7ef3..0000000000 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- -Module : Development.IDE.Core.WorkerThread -Author : @soulomoon -SPDX-License-Identifier: Apache-2.0 - -Description : This module provides an API for managing worker threads in the IDE. -see Note [Serializing runs in separate thread] --} -module Development.IDE.Core.WorkerThread - (withWorkerQueue, awaitRunInThread) - where - -import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled), - withAsync) -import Control.Concurrent.STM -import Control.Concurrent.Strict (newBarrier, signalBarrier, - waitBarrier) -import Control.Exception.Safe (Exception (fromException), - SomeException, throwIO, try) -import Control.Monad (forever) -import Control.Monad.Cont (ContT (ContT)) - -{- -Note [Serializing runs in separate thread] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to take long-running actions using some resource that cannot be shared. -In this instance it is useful to have a queue of jobs to run using the resource. -Like the db writes, session loading in session loader, shake session restarts. - -Originally we used various ways to implement this, but it was hard to maintain and error prone. -Moreover, we can not stop these threads uniformly when we are shutting down the server. --} - --- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker --- thread which polls the queue for requests and runs the given worker --- function on them. -withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) -withWorkerQueue workerAction = ContT $ \mainAction -> do - q <- newTQueueIO - withAsync (writerThread q) $ \_ -> mainAction q - where - writerThread q = - forever $ do - l <- atomically $ readTQueue q - workerAction l - --- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, --- and then blocks until the result is computed. If the action throws an --- non-async exception, it is rethrown in the calling thread. -awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result -awaitRunInThread q act = do - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - barrier <- newBarrier - atomically $ writeTQueue q $ try act >>= signalBarrier barrier - resultOrException <- waitBarrier barrier - case resultOrException of - Left e -> throwIO (e :: SomeException) - Right r -> return r diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index befd22c8de..d4750f1a2e 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -115,7 +115,6 @@ module Development.IDE.GHC.Compat( import Control.Applicative ((<|>)) import qualified Data.ByteString as BS import Data.Coerce (coerce) -import Data.List (foldl') import qualified Data.Map as Map import qualified Data.Set as S import Data.String (IsString (fromString)) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 918e024a4f..8948d719d1 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -12,6 +12,8 @@ module Development.IDE.LSP.LanguageServer , ThreadQueue , runWithWorkerThreads , Setup (..) + , InitializationContext (..) + , untilMVar' ) where import Control.Concurrent.STM @@ -35,32 +37,56 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier, + signalBarrier, + waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service (shutdown) import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Core.WorkerThread (withWorkerQueue) import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..)) +import Development.IDE.WorkerThread import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) +import System.Time.Extra (Seconds, sleep) +import System.Timeout (timeout) data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException | LogReactorMessageActionException !SomeException - | LogReactorThreadStopped + | LogReactorThreadStopped Int | LogCancelledRequest !SomeLspId | LogSession Session.Log | LogLspServer LspServerLog - | LogServerShutdownMessage + | LogReactorShutdownRequested Bool + | LogShutDownTimeout Int + | LogServerExitWith (Either () Int) + | LogReactorShutdownConfirmed !T.Text + | LogInitializeIdeStateTookTooLong Seconds deriving Show instance Pretty Log where pretty = \case + LogInitializeIdeStateTookTooLong seconds -> + "Building the initial session took more than" <+> pretty seconds <+> "seconds" + LogReactorShutdownRequested b -> + "Requested reactor shutdown; stop signal posted: " <+> pretty b + LogReactorShutdownConfirmed msg -> + "Reactor shutdown confirmed: " <+> pretty msg + LogServerExitWith (Right 0) -> + "Server exited successfully" + LogServerExitWith (Right code) -> + "Server exited with failure code" <+> pretty code + LogServerExitWith (Left _) -> + "Server forcefully exited due to exception in reactor thread" + LogShutDownTimeout seconds -> + "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds <+> "seconds" LogRegisteringIdeConfig ideConfig -> -- This log is also used to identify if HLS starts successfully in vscode-haskell, -- don't forget to update the corresponding test in vscode-haskell if the text in @@ -74,13 +100,38 @@ instance Pretty Log where vcat [ "ReactorMessageActionException" , pretty $ displayException e ] - LogReactorThreadStopped -> - "Reactor thread stopped" + LogReactorThreadStopped i -> + "Reactor thread stopped" <+> pretty i LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId LogSession msg -> pretty msg LogLspServer msg -> pretty msg - LogServerShutdownMessage -> "Received shutdown message" + +-- | Context for initializing the LSP language server. +-- This record encapsulates all the configuration and callback functions +-- needed to set up and run the language server initialization process. +data InitializationContext config = InitializationContext + { ctxRecorder :: Recorder (WithPriority Log) + -- ^ Logger for recording server events and diagnostics + , ctxDefaultRoot :: FilePath + -- ^ Default root directory for the workspace, see Note [Root Directory] + , ctxGetHieDbLoc :: FilePath -> IO FilePath + -- ^ Function to determine the HIE database location for a given root path + , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState + -- ^ Function to create and initialize the IDE state with the given environment + , ctxUntilReactorStopSignal :: IO () -> IO () + -- ^ Lifetime control: MVar to signal reactor shutdown + , ctxconfirmReactorShutdown :: T.Text -> IO () + -- ^ Callback to log/confirm reactor shutdown with a reason + , ctxForceShutdown :: IO () + -- ^ Action to forcefully exit the server when exception occurs + , ctxClearReqId :: SomeLspId -> IO () + -- ^ Function to clear/cancel a request by its ID + , ctxWaitForCancel :: SomeLspId -> IO () + -- ^ Function to wait for a request cancellation by its ID + , ctxClientMsgChan :: Chan ReactorMessage + -- ^ Channel for communicating with the reactor message loop + } data Setup config m a = MkSetup @@ -136,8 +187,8 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh outH serverDefinition - untilMVar clientMsgVar $ - runServer `finally` sequence_ onExit + untilMVar' clientMsgVar runServer `finally` sequence_ onExit + >>= logWith recorder Info . LogServerExitWith setupLSP :: forall config. @@ -155,8 +206,21 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full - reactorLifetime <- newEmptyMVar - let stopReactorLoop = void $ tryPutMVar reactorLifetime () + reactorStopSignal <- newEmptyMVar + reactorConfirmBarrier <- newBarrier + let + untilReactorStopSignal = untilMVar reactorStopSignal + confirmReactorShutdown reason = do + logWith recorder Debug $ LogReactorShutdownConfirmed reason + signalBarrier reactorConfirmBarrier () + requestReactorShutdown = do + k <- tryPutMVar reactorStopSignal () + logWith recorder Info $ LogReactorShutdownRequested k + let timeOutSeconds = 2 + timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case + Just () -> pure () + -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. + Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -185,49 +249,63 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler exit - , shutdownHandler recorder stopReactorLoop + , shutdownHandler recorder requestReactorShutdown ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let initParams = InitializationContext + { ctxRecorder = recorder + , ctxDefaultRoot = defaultRoot + , ctxGetHieDbLoc = getHieDbLoc + , ctxGetIdeState = getIdeState + , ctxUntilReactorStopSignal = untilReactorStopSignal + , ctxconfirmReactorShutdown = confirmReactorShutdown + , ctxForceShutdown = exit + , ctxClearReqId = clearReqId + , ctxWaitForCancel = waitForCancel + , ctxClientMsgChan = clientMsgChan + } + + let doInitialize = handleInit initParams let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - - let onExit = [stopReactorLoop, exit] + let onExit = [void $ tryPutMVar reactorStopSignal ()] pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit - :: Recorder (WithPriority Log) - -> FilePath -- ^ root directory, see Note [Root Directory] - -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) - -> MVar () - -> IO () - -> (SomeLspId -> IO ()) - -> (SomeLspId -> IO ()) - -> Chan ReactorMessage + :: InitializationContext config -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - -- only shift if lsp root is different from the rootDir - -- see Note [Root Directory] + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + let + recorder = ctxRecorder initParams + defaultRoot = ctxDefaultRoot initParams + untilReactorStopSignal = ctxUntilReactorStopSignal initParams + lifetimeConfirm = ctxconfirmReactorShutdown initParams root <- case LSP.resRootPath env of - Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot - _ -> pure defaultRoot - dbLoc <- getHieDbLoc root + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- ctxGetHieDbLoc initParams root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig - dbMVar <- newEmptyMVar - - - let handleServerException (Left e) = do - logWith recorder Error $ LogReactorThreadException e - exitClientMsg - handleServerException (Right _) = pure () + ideMVar <- newEmptyMVar + + let handleServerExceptionOrShutDown me = do + -- shutdown shake + tryReadMVar ideMVar >>= mapM_ shutdown + case me of + Left e -> do + lifetimeConfirm "due to exception in reactor thread" + logWith recorder Error $ LogReactorThreadException e + ctxForceShutdown initParams + _ -> do + lifetimeConfirm "due to shutdown message" + return () exceptionInHandler e = do logWith recorder Error $ LogReactorMessageActionException e @@ -235,13 +313,13 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () checkCancelled _id act k = let sid = SomeLspId _id - in flip finally (clearReqId sid) $ + in flip finally (ctxClearReqId initParams sid) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel sid) act + cancelOrRes <- race (ctxWaitForCancel initParams sid) act case cancelOrRes of Left () -> do logWith recorder Debug $ LogCancelledRequest sid @@ -250,20 +328,22 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c ) $ \(e :: SomeException) -> do exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do - putMVar dbMVar (WithHieDbShield withHieDb',threadQueue') - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logWith recorder Info LogReactorThreadStopped - - (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb threadQueue + _ <- flip forkFinally handleServerExceptionOrShutDown $ do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> + do + ide <- ctxGetIdeState initParams env root withHieDb' threadQueue' + putMVar ideMVar ide + -- We might be blocked indefinitly at initialization if reactorStop is signaled + -- before we putMVar. + untilReactorStopSignal $ forever $ do + msg <- readChan $ ctxClientMsgChan initParams + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + + ide <- readMVar ideMVar registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) @@ -273,9 +353,9 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c -- see Note [Serializing runs in separate thread] runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () runWithWorkerThreads recorder dbLoc f = evalContT $ do - sessionRestartTQueue <- withWorkerQueue id - sessionLoaderTQueue <- withWorkerQueue id (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + sessionRestartTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "RestartTQueue" + sessionLoaderTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "SessionLoaderTQueue" liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. @@ -286,6 +366,9 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () untilMVar mvar io = race_ (readMVar mvar) io +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b) +untilMVar' mvar io = race (readMVar mvar) io + cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> liftIO $ cancelRequest (SomeLspId (toLspId _id)) @@ -294,18 +377,11 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T toLspId (InR y) = IdString y shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) -shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do - (_, ide) <- ask - liftIO $ logWith recorder Debug LogServerShutdownMessage - -- stop the reactor to free up the hiedb connection - liftIO stopReactor - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide +shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do + -- stop the reactor to free up the hiedb connection and shut down shake + liftIO requestReactorShutdown resp $ Right Null -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit - modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index be03cd5a8a..8c0733b22f 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -39,7 +39,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, shakeGetCleanKeys) import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited), - Step) + Step (..)) import qualified Development.IDE.Graph.Internal.Types as Graph import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) @@ -140,7 +140,7 @@ getDatabaseKeys :: (Graph.Result -> Step) getDatabaseKeys field db = do keys <- shakeGetCleanKeys db step <- shakeGetBuildStep db - return [ k | (k, res) <- keys, field res == step] + return [ k | (k, res) <- keys, field res == Step step] parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 1c2ed1732f..26eb8d5395 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -54,7 +54,6 @@ newHscEnvEq :: HscEnv -> IO HscEnvEq newHscEnvEq hscEnv' = do mod_cache <- newIORef emptyInstalledModuleEnv - file_cache <- newIORef M.empty -- This finder cache is for things which are outside of things which are tracked -- by HLS. For example, non-home modules, dependent object files etc #if MIN_VERSION_ghc(9,11,0) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 5eccb4d75e..d1bbb61c31 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -65,11 +65,14 @@ library Development.IDE.Graph.KeyMap Development.IDE.Graph.KeySet Development.IDE.Graph.Rule + Development.IDE.WorkerThread Paths_hls_graph autogen-modules: Paths_hls_graph hs-source-dirs: src build-depends: + , mtl ^>=2.3.1 + , safe-exceptions ^>=0.1.7.4 , aeson , async >=2.0 , base >=4.12 && <5 @@ -92,6 +95,7 @@ library , transformers , unliftio , unordered-containers + , prettyprinter if flag(embed-files) cpp-options: -DFILE_EMBED @@ -129,6 +133,7 @@ test-suite tests -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts build-depends: + , transformers ^>=0.6.1.2 , base , extra , hls-graph @@ -138,5 +143,6 @@ test-suite tests , tasty , tasty-hspec >= 1.2 , tasty-rerun + , transformers build-tool-depends: hspec-discover:hspec-discover diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 81ad3b3dfd..bb973c6130 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -5,7 +5,7 @@ module Development.IDE.Graph( Action, action, pattern Key, newKey, renderKey, - actionFinally, actionBracket, actionCatch, actionFork, + actionFinally, actionBracket, actionCatch, -- * Configuration ShakeOptions(shakeAllowRedefineRules, shakeExtra), getShakeExtra, getShakeExtraRules, newShakeExtra, @@ -18,6 +18,7 @@ module Development.IDE.Graph( -- * Actions for inspecting the keys in the database getDirtySet, getKeysAndVisitedAge, + module Development.IDE.Graph.KeyMap, module Development.IDE.Graph.KeySet, ) where diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 65d946b547..c7b4e6a6be 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -1,5 +1,4 @@ module Development.IDE.Graph.Database( - AsyncParentKill(..), ShakeDatabase, ShakeValue, shakeNewDatabase, @@ -9,9 +8,11 @@ module Development.IDE.Graph.Database( shakeGetBuildStep, shakeGetDatabaseKeys, shakeGetDirtySet, - shakeGetCleanKeys, - shakeGetBuildEdges) where + shakeGetCleanKeys + ,shakeGetBuildEdges, + shakeShutDatabase) where import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Exception (SomeException) import Data.Dynamic import Data.Maybe import Development.IDE.Graph.Classes () @@ -22,20 +23,24 @@ import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import Development.IDE.WorkerThread (TaskQueue) -- Placeholder to be the 'extra' if the user doesn't set it data NonExportedType = NonExportedType -shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase -shakeNewDatabase opts rules = do +shakeShutDatabase :: ShakeDatabase -> IO () +shakeShutDatabase (ShakeDatabase _ _ db) = shutDatabase db + +shakeNewDatabase :: TaskQueue (IO ()) -> ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabase que opts rules = do let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts (theRules, actions) <- runRules extra rules - db <- newDatabase extra theRules + db <- newDatabase que extra theRules pure $ ShakeDatabase (length actions) actions db -shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a] -shakeRunDatabase a b = shakeRunDatabaseForKeys Nothing a b (const $ pure ()) +shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [Either SomeException a] +shakeRunDatabase = shakeRunDatabaseForKeys Nothing -- | Returns the set of dirty keys annotated with their age (in # of builds) shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] @@ -43,9 +48,9 @@ shakeGetDirtySet (ShakeDatabase _ _ db) = Development.IDE.Graph.Internal.Database.getDirtySet db -- | Returns the build number -shakeGetBuildStep :: ShakeDatabase -> IO Step +shakeGetBuildStep :: ShakeDatabase -> IO Int shakeGetBuildStep (ShakeDatabase _ _ db) = do - s <- readTVarIO $ databaseStep db + Step s <- readTVarIO $ databaseStep db return s -- Only valid if we never pull on the results, which we don't @@ -58,12 +63,11 @@ shakeRunDatabaseForKeys -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] - -> (Database -> IO ()) - -> IO [a] -shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 garbageCollect = do + -> IO [Either SomeException a] +shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged - garbageCollect db - fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 + drop lenAs1 <$> runActions db (map unvoid as1 ++ as2) + -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 30ef078ffe..ce1e7e432d 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -2,7 +2,6 @@ module Development.IDE.Graph.Internal.Action ( ShakeValue -, actionFork , actionBracket , actionCatch , actionFinally @@ -14,6 +13,7 @@ module Development.IDE.Graph.Internal.Action , runActions , Development.IDE.Graph.Internal.Action.getDirtySet , getKeysAndVisitedAge +, runActionInDb ) where import Control.Concurrent.Async @@ -31,6 +31,9 @@ import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Types import System.Exit +import UnliftIO (atomically, + newEmptyTMVarIO, + putTMVar, readTMVar) type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) @@ -40,45 +43,36 @@ alwaysRerun = do ref <- Action $ asks actionDeps liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) -parallel :: [Action a] -> Action [a] -parallel [] = pure [] -parallel [x] = fmap (:[]) x +parallel :: [Action a] -> Action [Either SomeException a] +parallel [] = return [] parallel xs = do a <- Action ask deps <- liftIO $ readIORef $ actionDeps a + case deps of UnknownDeps -> -- if we are already in the rerun mode, nothing we do is going to impact our state - liftIO $ mapConcurrently (ignoreState a) xs - deps -> do - (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs - liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps - pure res - where - usingState a x = do - ref <- newIORef mempty - res <- runReaderT (fromAction x) a{actionDeps=ref} - deps <- readIORef ref - pure (deps, res) + runActionInDb xs + deps -> error $ "parallel not supported when we have precise dependencies: " ++ show deps + -- (newDeps, res) <- liftIO $ unzip <$> runActionInDb usingState xs + -- liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps + -- return () + +runActionInDb :: [Action a] -> Action [Either SomeException a] +runActionInDb acts = do + a <- Action ask + xs <- mapM (\x -> do + barrier <- newEmptyTMVarIO + return (x, barrier)) acts + liftIO $ atomically $ runInDataBase (actionDatabase a) (map (\(x, b) -> (ignoreState a x >>= (atomically . putTMVar b . Right), atomically . putTMVar b . Left)) xs) + results <- liftIO $ mapM (atomically . readTMVar) $ fmap snd xs + return results ignoreState :: SAction -> Action b -> IO b ignoreState a x = do ref <- newIORef mempty runReaderT (fromAction x) a{actionDeps=ref} -actionFork :: Action a -> (Async a -> Action b) -> Action b -actionFork act k = do - a <- Action ask - deps <- liftIO $ readIORef $ actionDeps a - let db = actionDatabase a - case deps of - UnknownDeps -> do - -- if we are already in the rerun mode, nothing we do is going to impact our state - [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as] - return res - _ -> - error "please help me" - isAsyncException :: SomeException -> Bool isAsyncException e | Just (_ :: SomeAsyncException) <- fromException e = True @@ -130,7 +124,7 @@ applyWithoutDependency ks = do (_, vs) <- liftIO $ build db stack ks pure vs -runActions :: Database -> [Action a] -> IO [a] +runActions :: Database -> [Action a] -> IO [Either SomeException a] runActions db xs = do deps <- newIORef mempty runReaderT (fromAction $ parallel xs) $ SAction db deps emptyStack diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 0d27b73a11..83ded5168d 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,13 +8,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, AsyncParentKill(..), garbageCollectKeys, garbageCollectKeys1) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, AsyncParentKill(..)) where import Prelude hiding (unzip) -import Control.Concurrent.Async -import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats (STM, TVar, atomically, +import Control.Concurrent.STM.Stats (STM, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, readTVarIO, @@ -31,7 +29,7 @@ import Data.IORef.Extra import Data.Maybe import Data.Traversable (for) import Data.Tuple.Extra -import Debug.Trace (traceM) +import Debug.Trace (traceEvent) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules @@ -39,102 +37,40 @@ import Development.IDE.Graph.Internal.Types import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap -import qualified StmContainers.Set as SSet -import System.Time.Extra (duration, sleep) -import UnliftIO (MonadUnliftIO (withRunInIO)) -import qualified UnliftIO.Exception as UE +import System.Time.Extra (duration) #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) #else import Data.List.NonEmpty (unzip) #endif +import Development.IDE.WorkerThread (TaskQueue) -newDatabase :: Dynamic -> TheRules -> IO Database -newDatabase databaseExtra databaseRules = do +newDatabase :: TaskQueue (IO ()) -> Dynamic -> TheRules -> IO Database +newDatabase databaseQueue databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 + databaseThreads <- newTVarIO [] databaseValues <- atomically SMap.new - databaseDirtyKeys <- atomically SSet.new pure Database{..} -garbageCollectKeys1 :: Database -> (Key -> Bool) -> ([Key] -> STM ()) -> IO [Key] -garbageCollectKeys1 db pred garbageCollectHook = do - -- GC policy: - -- We find a list of keys that are FOI and their dependencies, - -- and mark them as "needed". Then we delete all dirty keys not marked as needed. - let maxAge = 0 -- builds; tune as needed or make configurable upstream - -- on idle but still dirty keys - ks <- getKeysAndVisitAge db - let foiks = [ k | (k, _) <- ks, pred k ] - toKeep <- atomically $ transitiveSet db foiks - dirtyWithAge <- Development.IDE.Graph.Internal.Database.getDirtySet db - let victims = [k | (k, age) <- dirtyWithAge - , age >= maxAge - , not (k `memberKeySet` toKeep)] - unless (null victims) $ do - -- Delete victim keys and remove them from the dirty set - atomically $ do - forM_ victims $ \k -> do - SMap.focus cleanupDirty k (databaseValues db) - -- Remove the victim keys from reverse-dependency sets of remaining keys - let list = SMap.listT (databaseValues db) - ListT.traverse_ (\(k', _) -> - SMap.focus (Focus.adjust (onKeyReverseDeps (\ks -> foldr deleteKeySet ks victims))) k' (databaseValues db) - ) list - garbageCollectHook victims - pure () - return victims - -garbageCollectKeys :: Database -> (Key -> Bool) -> ([Key] -> STM ()) -> IO [Key] -garbageCollectKeys db pred garbageCollectHook = do - -- GC policy: - -- - Select dirty keys whose age >= maxAge and that satisfy the given predicate 'pred'. - -- - For each selected key (a victim), drop its previous result by setting its status to Dirty Nothing - -- and remove that key from every other key's reverse-dependency set. - -- - Finally, run the provided 'garbageCollectHook victims' within the same STM transaction. - let maxAge = 0 -- builds; tune as needed or make configurable upstream - -- on idle but still dirty keys - dirtyWithAge <- Development.IDE.Graph.Internal.Database.getDirtySet db - let victims = [k | (k, age) <- dirtyWithAge, age >= maxAge, pred k] - unless (null victims) $ do - -- Delete victim keys and remove them from the dirty set - atomically $ do - forM_ victims $ \k -> do - SMap.focus cleanupDirty k (databaseValues db) - -- Remove the victim keys from reverse-dependency sets of remaining keys - let list = SMap.listT (databaseValues db) - ListT.traverse_ (\(k', _) -> - SMap.focus (Focus.adjust (onKeyReverseDeps (\ks -> foldr deleteKeySet ks victims))) k' (databaseValues db) - ) list - garbageCollectHook victims - pure () - return victims - - -cleanupDirty :: Monad m => Focus.Focus KeyDetails m () -cleanupDirty = Focus.adjust $ \(KeyDetails status rdeps) -> - let status' - | Dirty _ <- status = Dirty Nothing - | otherwise = status - in KeyDetails status' rdeps - -- | Increment the step and mark dirty. -- Assumes that the database is not running a build incDatabase :: Database -> Maybe [Key] -> IO () -- only some keys are dirty incDatabase db (Just kk) = do - atomicallyNamed "incDatabase" $ do - modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 - for_ kk $ \k -> SSet.insert k (databaseDirtyKeys db) - keys <- ListT.toList $ SSet.listT (databaseDirtyKeys db) - transitiveDirtyKeys <- transitiveDirtySet db keys - for_ (toListKeySet transitiveDirtyKeys) $ \k -> SMap.focus updateDirty k (databaseValues db) - + atomicallyNamed "incDatabase" $ modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 + transitiveDirtyKeys <- transitiveDirtySet db kk + for_ (toListKeySet transitiveDirtyKeys) $ \k -> + -- Updating all the keys atomically is not necessary + -- since we assume that no build is mutating the db. + -- Therefore run one transaction per key to minimise contention. + atomicallyNamed "incDatabase" $ SMap.focus updateDirty k (databaseValues db) -- all keys are dirty incDatabase db Nothing = do atomically $ modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 let list = SMap.listT (databaseValues db) + -- all running keys are also dirty atomicallyNamed "incDatabase - all " $ flip ListT.traverse_ list $ \(k,_) -> SMap.focus updateDirty k (databaseValues db) @@ -152,51 +88,54 @@ build -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do step <- readTVarIO $ databaseStep db - !built <- runAIO step $ builder db stack (fmap newKey keys) - let (ids, vs) = unzip built - pure (ids, fmap (asV . resultValue) vs) + go `catch` \e@(AsyncParentKill i s) -> do + if s == step + then throw e + else throw $ AsyncParentKill i $ Step (-1) where - asV :: Value -> value - asV (Value x) = unwrapDynamic x + go = do + -- step <- readTVarIO $ databaseStep db + -- built <- mapConcurrently (builderOne db stack) (fmap newKey keys) + built <- builder db stack (fmap newKey keys) + let (ids, vs) = unzip built + pure (ids, fmap (asV . resultValue) vs) + where + asV :: Value -> value + asV (Value x) = unwrapDynamic x + -- | Build a list of keys and return their results. -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. -builder :: (Traversable f) => Database -> Stack -> f Key -> AIO (f (Key, Result)) +builder :: (Traversable f) => Database -> Stack -> f Key -> IO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined -builder db stack keys = do - keyWaits <- for keys $ \k -> builderOne db stack k - !res <- for keyWaits $ \(k, waitR) -> do - !v<- liftIO waitR - return (k, v) - return res +builder db stack keys = for keys $ \k -> builderOne db stack k -builderOne :: Database -> Stack -> Key -> AIO (Key, IO Result) -builderOne db@Database {..} stack id = UE.mask $ \restore -> do - current <- liftIO $ readTVarIO databaseStep - (k, registerWaitResult) <- liftIO $ atomicallyNamed "builder" $ do +builderOne :: Database -> Stack -> Key -> IO (Key, Result) +builderOne db@Database {..} stack id = do + traceEvent ("builderOne: " ++ show id) return () + res <- liftIO $ atomicallyNamed "builder" $ do -- Spawn the id if needed status <- SMap.lookup id databaseValues - val <- - let refreshRsult s = do - let act = - restore $ asyncWithCleanUp $ - refresh db stack id s - `UE.onException` (UE.uninterruptibleMask_ $ liftIO (atomicallyNamed "builder - onException" (SMap.focus updateDirty id databaseValues))) + current <- readTVar databaseStep + + val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Dirty s -> do + SMap.focus (updateStatus $ Running current s) id databaseValues + traceEvent ("Starting build of key: " ++ show id ++ ", step "++ show current) + $ runOneInDataBase db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + return Nothing + Clean r -> return $ Just r + -- force here might contains async exceptions from previous runs + Running _step _s + | memberStack id stack -> throw $ StackException stack + | otherwise -> retry + Exception _ e _s -> throw e + pure val + case res of + Just r -> return (id, r) + Nothing -> builderOne db stack id - SMap.focus (updateStatus $ Running current s) id databaseValues - return act - in case viewDirty current $ maybe (Dirty Nothing) keyStatus status of - Dirty mbr -> refreshRsult mbr - Running step _mbr - | step /= current -> error $ "Inconsistent database state: key " ++ show id ++ " is marked Running at step " ++ show step ++ " but current step is " ++ show current - | memberStack id stack -> throw $ StackException stack - | otherwise -> retry - Clean r -> pure . pure . pure $ r - -- force here might contains async exceptions from previous runs - pure (id, val) - waitR <- registerWaitResult - return (k, waitR) -- | isDirty -- only dirty when it's build time is older than the changed time of one of its dependencies isDirty :: Foldable t => Result -> t (a, Result) -> Bool @@ -209,30 +148,27 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself -refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result +refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> IO Result refreshDeps visited db stack key result = \case -- no more deps to refresh - [] -> compute' db stack key RunDependenciesSame (Just result) + [] -> compute db stack key RunDependenciesSame (Just result) (dep:deps) -> do let newVisited = dep <> visited res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) if isDirty result res -- restart the computation if any of the deps are dirty - then compute' db stack key RunDependenciesChanged (Just result) + then compute db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps else refreshDeps newVisited db stack key result deps -- refresh :: Database -> Stack -> Key -> Maybe Result -> IO Result -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined -refresh :: Database -> Stack -> Key -> Maybe Result -> AIO Result +refresh :: Database -> Stack -> Key -> Maybe Result -> IO Result refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) - (Right stack, _) -> compute' db stack key RunDependenciesChanged result - -compute' :: Database -> Stack -> Key -> RunMode -> Maybe Result -> AIO Result -compute' db stack key mode result = liftIO $ compute db stack key mode result + (Right stack, _) -> compute db stack key RunDependenciesChanged result -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined @@ -273,7 +209,6 @@ compute db@Database{..} stack key mode result = do liftIO $ atomicallyNamed "compute and run hook" $ do runHook SMap.focus (updateStatus $ Clean res) key databaseValues - SSet.delete key databaseDirtyKeys pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () @@ -328,97 +263,15 @@ updateReverseDeps myId db prev new = do getReverseDependencies :: Database -> Key -> STM (Maybe KeySet) getReverseDependencies db = (fmap.fmap) keyReverseDeps . flip SMap.lookup (databaseValues db) -transitiveDirtySet :: Foldable t => Database -> t Key -> STM KeySet +transitiveDirtySet :: Foldable t => Database -> t Key -> IO KeySet transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop where loop x = do seen <- State.get if x `memberKeySet` seen then pure () else do State.put (insertKeySet x seen) - next <- lift $ getReverseDependencies database x + next <- lift $ atomically $ getReverseDependencies database x traverse_ loop (maybe mempty toListKeySet next) -getDependencies :: Database -> Key -> STM (Maybe KeySet) -getDependencies db k = do - m <- SMap.lookup k (databaseValues db) - pure $ do - KeyDetails st _ <- m - case getDeps st of - UnknownDeps -> Nothing - rd -> Just (getResultDepsDefault mempty rd) - -transitiveSet :: Foldable t => Database -> t Key -> STM KeySet -transitiveSet database = flip State.execStateT mempty . traverse_ loop - where - loop x = do - seen <- State.get - if x `memberKeySet` seen then pure () else do - State.put (insertKeySet x seen) - next <- lift $ getDependencies database x - traverse_ loop (maybe mempty toListKeySet next) - --------------------------------------------------------------------------------- --- Asynchronous computations with cancellation - --- | A simple monad to implement cancellation on top of 'Async', --- generalizing 'withAsync' to monadic scopes. -newtype AIO a = AIO { unAIO :: ReaderT (TVar [Async ()]) IO a } - deriving newtype (Applicative, Functor, Monad, MonadIO) - -data AsyncParentKill = AsyncParentKill ThreadId Step - deriving (Show, Eq) - -instance Exception AsyncParentKill where - toException = asyncExceptionToException - fromException = asyncExceptionFromException - --- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises -runAIO :: Step -> AIO a -> IO a -runAIO s (AIO act) = do - asyncsRef <- newTVarIO [] - -- Log the exact exception (including async exceptions) before cleanup, - -- then rethrow to preserve previous semantics. - runReaderT act asyncsRef `onException` do - asyncs <- atomically $ do - r <- readTVar asyncsRef - modifyTVar' asyncsRef $ const [] - return r - tid <- myThreadId - cleanupAsync asyncs tid s - --- | Like 'async' but with built-in cancellation. --- Returns an IO action to wait on the result. -asyncWithCleanUp :: AIO a -> AIO (IO a) -asyncWithCleanUp act = do - st <- AIO ask - io <- unliftAIO act - -- mask to make sure we keep track of the spawned async - liftIO $ uninterruptibleMask $ \restore -> do - a <- async $ restore io - atomically $ modifyTVar' st (void a :) - return $ wait a - -unliftAIO :: AIO a -> AIO (IO a) -unliftAIO act = do - st <- AIO ask - return $ runReaderT (unAIO act) st -instance MonadUnliftIO AIO where - withRunInIO k = do - st <- AIO ask - liftIO $ k (\aio -> runReaderT (unAIO aio) st) -cleanupAsync :: [Async a] -> ThreadId -> Step -> IO () --- mask to make sure we interrupt all the asyncs -cleanupAsync asyncs tid step = uninterruptibleMask $ \unmask -> do - -- interrupt all the asyncs without waiting - -- mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs - mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) asyncs - -- Wait until all the asyncs are done - -- But if it takes more than 10 seconds, log to stderr - unless (null asyncs) $ do - let warnIfTakingTooLong = unmask $ forever $ do - sleep 10 - traceM "cleanupAsync: waiting for asyncs to finish" - withAsync warnIfTakingTooLong $ \_ -> - mapM_ waitCatch asyncs diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 03e1f0b657..08b911e765 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -5,7 +5,8 @@ module Development.IDE.Graph.Internal.Types where -import Control.Concurrent.STM (STM) +import Control.Concurrent.STM (STM, modifyTVar') +import Control.Monad (forever, unless) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -19,16 +20,25 @@ import Data.IORef import Data.List (intercalate) import Data.Maybe import Data.Typeable +import Debug.Trace (traceEventIO, traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key +import Development.IDE.WorkerThread (TaskQueue, + awaitRunInThreadStmInNewThreads) import GHC.Conc (TVar, atomically) import GHC.Generics (Generic) import qualified ListT import qualified StmContainers.Map as SMap import StmContainers.Map (Map) -import StmContainers.Set (Set) -import System.Time.Extra (Seconds) -import UnliftIO (MonadUnliftIO) +import System.Time.Extra (Seconds, sleep) +import UnliftIO (Async (asyncThreadId), + MonadUnliftIO, + asyncExceptionFromException, + asyncExceptionToException, + readTVar, readTVarIO, + throwTo, waitCatch, + withAsync) +import UnliftIO.Concurrent (ThreadId, myThreadId) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -89,14 +99,16 @@ getDatabase = Action $ asks actionDatabase data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int - deriving newtype (Eq,Ord,Hashable,Show,Num,Enum,Real,Integral) - ---------------------------------------------------------------------- --- Keys - + deriving newtype (Eq,Ord,Hashable,Show) +getShakeStep :: MonadIO m => ShakeDatabase -> m Step +getShakeStep (ShakeDatabase _ _ db) = do + s <- readTVarIO $ databaseStep db + return s +--------------------------------------------------------------------- +-- Keys newtype Value = Value Dynamic data KeyDetails = KeyDetails { @@ -109,15 +121,56 @@ onKeyReverseDeps f it@KeyDetails{..} = it{keyReverseDeps = f keyReverseDeps} data Database = Database { - databaseExtra :: Dynamic, - databaseRules :: TheRules, - databaseStep :: !(TVar Step), - databaseValues :: !(Map Key KeyDetails), - databaseDirtyKeys :: !(Set Key) - -- ^ The set of dirty keys, which are the keys that have been marked as dirty - -- by the client, it would be removed once the target key is marked as clean. + databaseExtra :: Dynamic, + + databaseThreads :: TVar [Async ()], + databaseQueue :: TaskQueue (IO ()), + + databaseRules :: TheRules, + databaseStep :: !(TVar Step), + databaseValues :: !(Map Key KeyDetails) } +runInDataBase :: Database -> [(IO result, SomeException -> IO ())] -> STM () +runInDataBase db acts = do + s <- getDataBaseStepInt db + awaitRunInThreadStmInNewThreads (getDataBaseStepInt db) s (databaseQueue db) (databaseThreads db) acts + +runOneInDataBase :: Database -> IO result -> (SomeException -> IO ()) -> STM () +runOneInDataBase db act handler = do + s <- getDataBaseStepInt db + awaitRunInThreadStmInNewThreads (getDataBaseStepInt db) s (databaseQueue db) (databaseThreads db) [(act, handler)] + +getDataBaseStepInt :: Database -> STM Int +getDataBaseStepInt db = do + Step s <- readTVar $ databaseStep db + return s + +data AsyncParentKill = AsyncParentKill ThreadId Step + deriving (Show, Eq) + +instance Exception AsyncParentKill where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +shutDatabase :: Database -> IO () +shutDatabase Database{..} = uninterruptibleMask $ \unmask -> do + -- wait for all threads to finish + asyncs <- readTVarIO databaseThreads + step <- readTVarIO databaseStep + tid <- myThreadId + traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step) + mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) asyncs + atomically $ modifyTVar' databaseThreads (const []) + -- Wait until all the asyncs are done + -- But if it takes more than 10 seconds, log to stderr + unless (null asyncs) $ do + let warnIfTakingTooLong = unmask $ forever $ do + sleep 10 + traceM "cleanupAsync: waiting for asyncs to finish" + withAsync warnIfTakingTooLong $ \_ -> + mapM_ waitCatch asyncs + -- waitForDatabaseRunningKeys :: Database -> IO () -- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) @@ -131,6 +184,7 @@ getDatabaseValues = atomically data Status = Clean !Result | Dirty (Maybe Result) + | Exception !Step !SomeException !(Maybe Result) | Running { runningStep :: !Step, -- runningWait :: !(IO ()), @@ -140,18 +194,14 @@ data Status viewDirty :: Step -> Status -> Status viewDirty currentStep (Running s re) | currentStep /= s = Dirty re +viewDirty currentStep (Exception s _ re) | currentStep /= s = Dirty re viewDirty _ other = other getResult :: Status -> Maybe Result -getResult (Clean re) = Just re -getResult (Dirty m_re) = m_re -getResult (Running _ m_re) = m_re -- watch out: this returns the previous result - -getDeps :: Status -> ResultDeps -getDeps (Clean re) = resultDeps re -getDeps (Dirty (Just re)) = resultDeps re -getDeps (Dirty Nothing) = UnknownDeps -getDeps (Running _ re) = maybe mempty resultDeps re +getResult (Clean re) = Just re +getResult (Dirty m_re) = m_re +getResult (Running _ m_re) = m_re -- watch out: this returns the previous result +getResult (Exception _ _ m_re) = m_re -- waitRunning :: Status -> IO () -- waitRunning Running{..} = runningWait diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs new file mode 100644 index 0000000000..2f496f6cff --- /dev/null +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -0,0 +1,164 @@ +{- +Module : Development.IDE.WorkerThread +Author : @soulomoon +SPDX-License-Identifier: Apache-2.0 + +Description : This module provides an API for managing worker threads in the IDE. +see Note [Serializing runs in separate thread] +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Development.IDE.WorkerThread + ( LogWorkerThread (..), + withWorkerQueue, + awaitRunInThread, + TaskQueue, + writeTaskQueue, + withWorkerQueueSimple, + awaitRunInThreadStm, + awaitRunInThreadStmInNewThread, + awaitRunInThreadStmInNewThreads, + isEmptyTaskQueue + ) where + +import Control.Concurrent.Async (Async, async, withAsync) +import Control.Concurrent.STM +import Control.Exception.Safe (MonadMask (..), + SomeException (SomeException), + finally, throw, try) +import Control.Monad.Cont (ContT (ContT)) +import qualified Data.Text as T + +import Control.Concurrent +import Control.Exception (catch) +import Control.Monad (void, when) +import Prettyprinter + +data LogWorkerThread + = LogThreadEnding !T.Text + | LogThreadEnded !T.Text + | LogSingleWorkStarting !T.Text + | LogSingleWorkEnded !T.Text + | LogMainThreadId !T.Text !ThreadId + deriving (Show) + +instance Pretty LogWorkerThread where + pretty = \case + LogThreadEnding t -> "Worker thread ending:" <+> pretty t + LogThreadEnded t -> "Worker thread ended:" <+> pretty t + LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t + LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t + LogMainThreadId t tid -> "Main thread for" <+> pretty t <+> "is" <+> pretty (show tid) + + +{- +Note [Serializing runs in separate thread] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to take long-running actions using some resource that cannot be shared. +In this instance it is useful to have a queue of jobs to run using the resource. +Like the db writes, session loading in session loader, shake session restarts. + +Originally we used various ways to implement this, but it was hard to maintain and error prone. +Moreover, we can not stop these threads uniformly when we are shutting down the server. +-} +data TaskQueue a = TaskQueue (TQueue a) +newTaskQueueIO :: IO (TaskQueue a) +newTaskQueueIO = TaskQueue <$> newTQueueIO +data ExitOrTask t = Exit | Task t +type Logger = LogWorkerThread -> IO () + +-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker +-- thread which polls the queue for requests and runs the given worker +-- function on them. +withWorkerQueueSimple :: Logger -> T.Text -> ContT () IO (TaskQueue (IO ())) +withWorkerQueueSimple log title = withWorkerQueue log title id +withWorkerQueue :: Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) +withWorkerQueue log title workerAction = ContT $ \mainAction -> do + tid <- myThreadId + log (LogMainThreadId title tid) + q <- newTaskQueueIO + -- Use a TMVar as a stop flag to coordinate graceful shutdown. + -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately, + -- ensuring that no new work is started after shutdown is requested. + -- This mechanism is necessary because some downstream code may swallow async exceptions, + -- making 'cancel' unreliable for stopping the thread in all cases. + -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job), + -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant. + b <- newEmptyTMVarIO + withAsync (writerThread q b) $ \_ -> do + mainAction q + -- if we want to debug the exact location the worker swallows an async exception, we can + -- temporarily comment out the `finally` clause. + `finally` atomically (putTMVar b ()) + log (LogThreadEnding title) + log (LogThreadEnded title) + where + -- writerThread :: TaskQueue t -> TMVar () -> (forall a. IO a -> IO a) -> IO () + writerThread q b = + -- See above: check stop flag before dequeuing, exit if set, otherwise run next job. + do + task <- atomically $ do + task <- tryReadTaskQueue q + isEm <- isEmptyTMVar b + case (isEm, task) of + (False, _) -> return Exit -- stop flag set, exit + (_, Just t) -> return $ Task t -- got a task, run it + (_, Nothing) -> retry -- no task, wait + case task of + Exit -> return () + Task t -> do + log $ LogSingleWorkStarting title + workerAction t + log $ LogSingleWorkEnded title + writerThread q b + + +-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, +-- and then blocks until the result is computed. If the action throws an +-- non-async exception, it is rethrown in the calling thread. +awaitRunInThreadStm :: TaskQueue (IO ()) -> IO result -> STM result +awaitRunInThreadStm (TaskQueue q) act = do + barrier <- newEmptyTMVar + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + writeTQueue q (try act >>= atomically . putTMVar barrier) + resultOrException <- takeTMVar barrier + case resultOrException of + Left e -> throw (e :: SomeException) + Right r -> return r + +awaitRunInThreadStmInNewThread :: STM Int -> Int -> TaskQueue (IO ()) -> TVar [Async ()] -> IO result -> (SomeException -> IO ()) -> STM () +awaitRunInThreadStmInNewThread getStep deliverStep q tthreads act handler = awaitRunInThreadStmInNewThreads getStep deliverStep q tthreads [(act, handler)] + +awaitRunInThreadStmInNewThreads :: STM Int -> Int -> TaskQueue (IO ()) -> TVar [Async ()] -> [(IO result, SomeException -> IO ())] -> STM () +awaitRunInThreadStmInNewThreads getStep deliverStep (TaskQueue q) tthreads acts = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + writeTQueue q (uninterruptibleMask $ \restore -> do + curStep <- atomically getStep + when (curStep == deliverStep) $ do + syncs <- mapM (\(act, handler) -> async (restore (void act `catch` \(SomeException e) -> handler (SomeException e)))) acts + atomically $ modifyTVar' tthreads (syncs++) + ) + +awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result +awaitRunInThread (TaskQueue q) act = do + barrier <- newEmptyTMVarIO + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + atomically $ writeTQueue q (try act >>= atomically . putTMVar barrier) + resultOrException <- atomically $ takeTMVar barrier + case resultOrException of + Left e -> throw (e :: SomeException) + Right r -> return r + +writeTaskQueue :: TaskQueue a -> a -> STM () +writeTaskQueue (TaskQueue q) = writeTQueue q + +tryReadTaskQueue :: TaskQueue a -> STM (Maybe a) +tryReadTaskQueue (TaskQueue q) = tryReadTQueue q + +isEmptyTaskQueue :: TaskQueue a -> STM Bool +isEmptyTaskQueue (TaskQueue q) = isEmptyTQueue q + diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 3a0b8d6829..826d542e21 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -7,6 +7,7 @@ import Control.Concurrent (MVar, readMVar) import qualified Control.Concurrent as C import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Graph (shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, @@ -15,15 +16,28 @@ import Development.IDE.Graph.Internal.Database (build, incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule +import Development.IDE.WorkerThread (TaskQueue, + withWorkerQueueSimple) import Example import qualified StmContainers.Map as STM import Test.Hspec +itInThread :: String -> (TaskQueue (IO ()) -> IO ()) -> SpecWith () +itInThread name ex = it name $ evalContT $ do + thread <- withWorkerQueueSimple (const $ return ()) "hls-graph test" + liftIO $ ex thread + +shakeRunDatabaseFromRight :: ShakeDatabase -> [Action a] -> IO [a] +shakeRunDatabaseFromRight db as = do + res <- shakeRunDatabase db as + case sequence res of + Left e -> error $ "shakeRunDatabaseFromRight: unexpected exception: " ++ show e + Right v -> return v spec :: Spec spec = do - describe "apply1" $ it "Test build update, Buggy dirty mechanism in hls-graph #4237" $ do + describe "apply1" $ itInThread "Test build update, Buggy dirty mechanism in hls-graph #4237" $ \q -> do let ruleStep1 :: MVar Int -> Rules () ruleStep1 m = addRule $ \CountRule _old mode -> do -- depends on ruleSubBranch, it always changed if dirty @@ -39,68 +53,65 @@ spec = do return $ RunResult ChangedNothing "" r (return ()) count <- C.newMVar 0 count1 <- C.newMVar 0 - db <- shakeNewDatabase shakeOptions $ do + db <- shakeNewDatabase q shakeOptions $ do ruleSubBranch count ruleStep1 count1 -- bootstrapping the database - _ <- shakeRunDatabase db $ pure $ apply1 CountRule -- count = 1 + _ <- shakeRunDatabaseFromRight db $ pure $ apply1 CountRule -- count = 1 let child = newKey SubBranchRule let parent = newKey CountRule -- instruct to RunDependenciesChanged then CountRule should be recomputed -- result should be changed 0, build 1 - _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] $ \_ -> return () - -- count = 2 + _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2 -- since child changed = parent build -- instruct to RunDependenciesSame then CountRule should not be recomputed -- result should be changed 0, build 1 - _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] $ \_ -> return () - -- count = 2 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 -- invariant child changed = parent build should remains after RunDependenciesSame -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238 - _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] $ \_ -> return () - -- count = 2 + _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2 c1 <- readMVar count1 c1 `shouldBe` 2 - describe "apply1" $ do - it "computes a rule with no dependencies" $ do - db <- shakeNewDatabase shakeOptions ruleUnit - res <- shakeRunDatabase db $ + describe "apply1" $ do + itInThread "computes a rule with no dependencies" $ \q -> do + db <- shakeNewDatabase q shakeOptions ruleUnit + res <- shakeRunDatabaseFromRight db $ pure $ apply1 (Rule @()) res `shouldBe` [()] - it "computes a rule with one dependency" $ do - db <- shakeNewDatabase shakeOptions $ do + itInThread "computes a rule with one dependency" $ \q -> do + db <- shakeNewDatabase q shakeOptions $ do ruleUnit ruleBool - res <- shakeRunDatabase db $ pure $ apply1 Rule + res <- shakeRunDatabaseFromRight db $ pure $ apply1 Rule res `shouldBe` [True] - it "tracks direct dependencies" $ do - db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + itInThread "tracks direct dependencies" $ \q -> do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do ruleUnit ruleBool let theKey = Rule @Bool - res <- shakeRunDatabase db $ + res <- shakeRunDatabaseFromRight db $ pure $ apply1 theKey res `shouldBe` [True] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())] - it "tracks reverse dependencies" $ do - db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do + itInThread "tracks reverse dependencies" $ \q -> do + db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase q shakeOptions $ do ruleUnit ruleBool let theKey = Rule @Bool - res <- shakeRunDatabase db $ + res <- shakeRunDatabaseFromRight db $ pure $ apply1 theKey res `shouldBe` [True] Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues keyReverseDeps `shouldBe` singletonKeySet (newKey theKey) - it "rethrows exceptions" $ do - db <- shakeNewDatabase shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" - let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + itInThread "rethrows exceptions" $ \q -> do + db <- shakeNewDatabase q shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" + let res = shakeRunDatabaseFromRight db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall - it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do + itInThread "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ \q -> do cond <- C.newMVar True count <- C.newMVar 0 - (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do ruleUnit ruleCond cond ruleSubBranch count @@ -119,15 +130,15 @@ spec = do countRes <- build theDb emptyStack [SubBranchRule] snd countRes `shouldBe` [1 :: Int] - describe "applyWithoutDependency" $ it "does not track dependencies" $ do - db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + describe "applyWithoutDependency" $ itInThread "does not track dependencies" $ \q -> do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] return $ RunResult ChangedRecomputeDiff "" True $ return () let theKey = Rule @Bool - res <- shakeRunDatabase db $ + res <- shakeRunDatabaseFromRight db $ pure $ applyWithoutDependency [theKey] res `shouldBe` [[True]] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 9061bfa89d..64ace32ce5 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -2,6 +2,13 @@ module DatabaseSpec where +import Control.Exception (Exception (..), + SomeException, + evaluate, throw) +import Control.Monad (join) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Cont (evalContT) +import Debug.Trace (traceM) import Development.IDE.Graph (newKey, shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) @@ -9,28 +16,43 @@ import Development.IDE.Graph.Internal.Action (apply1) import Development.IDE.Graph.Internal.Database (compute, incDatabase) import Development.IDE.Graph.Internal.Rules (addRule) import Development.IDE.Graph.Internal.Types +import Development.IDE.WorkerThread import Example import System.Time.Extra (timeout) import Test.Hspec +itInThread :: String -> (TaskQueue (IO ()) -> IO ()) -> SpecWith () +itInThread name ex = it name $ evalContT $ do + thread <- withWorkerQueueSimple (const $ return ()) "hls-graph test" + liftIO $ ex thread + +exractException :: [Either SomeException ()] -> Maybe StackException +exractException [] = Nothing +exractException (Left e : _) | Just ne@StackException{} <- fromGraphException e = return ne +exractException (_: xs) = exractException xs + + spec :: Spec spec = do describe "Evaluation" $ do - it "detects cycles" $ do - db <- shakeNewDatabase shakeOptions $ do + itInThread "detects cycles" $ \q -> do + db <- shakeNewDatabase q shakeOptions $ do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) return $ RunResult ChangedRecomputeDiff "" () (return ()) - let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) - timeout 1 res `shouldThrow` \StackException{} -> True + res <- timeout 1 $ shakeRunDatabase db $ pure $ apply1 (Rule @()) + let x = exractException =<< res + let throwStack x = case x + of Just e -> throw e + Nothing -> error "Expected a StackException, got none" + throwStack x `shouldThrow` \StackException{} -> True describe "compute" $ do - it "build step and changed step updated correctly" $ do - (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + itInThread "build step and changed step updated correctly" $ \q -> do + (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do ruleStep - let k = newKey $ Rule @() -- ChangedRecomputeSame r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing From 86fff58d7db312060d0ffcd60720c1e2782e146c Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 6 Sep 2025 08:01:58 +0800 Subject: [PATCH 070/107] exit --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 8 +++++++- hls-graph/test/DatabaseSpec.hs | 6 +----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 8948d719d1..bff90cb66f 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -216,7 +216,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar requestReactorShutdown = do k <- tryPutMVar reactorStopSignal () logWith recorder Info $ LogReactorShutdownRequested k - let timeOutSeconds = 2 + let timeOutSeconds = 3 timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case Just () -> pure () -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. @@ -250,6 +250,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar [ userHandlers , cancelHandler cancelRequest , shutdownHandler recorder requestReactorShutdown + , exitHandler recorder exit ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. @@ -382,6 +383,11 @@ shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Sh liftIO requestReactorShutdown resp $ Right Null +exitHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) +exitHandler _recorder exit = LSP.notificationHandler SMethod_Exit $ \_ -> do + -- stop the reactor to free up the hiedb connection and shut down shake + liftIO exit + modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 64ace32ce5..427dd2ceea 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -2,13 +2,9 @@ module DatabaseSpec where -import Control.Exception (Exception (..), - SomeException, - evaluate, throw) -import Control.Monad (join) +import Control.Exception (SomeException, throw) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Cont (evalContT) -import Debug.Trace (traceM) import Development.IDE.Graph (newKey, shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) From 558f861a5202822c109ce786c64fab39dcac04e9 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 6 Sep 2025 22:29:12 +0800 Subject: [PATCH 071/107] debounce empty diags --- ghcide/src/Development/IDE/Core/Shake.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 94bf9f733c..b0870df27b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -197,6 +197,7 @@ data Log | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()]) | LogDiagsDiffButNoLspEnv ![FileDiagnostic] + | LogDiagsPublishLog !Key ![FileDiagnostic] ![FileDiagnostic] | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic | LogCancelledAction !T.Text @@ -210,6 +211,12 @@ data Log instance Pretty Log where pretty = \case + LogDiagsPublishLog key lastDiags diags -> + vcat + [ "Publishing diagnostics for" <+> pretty (show key) + , "Last published:" <+> pretty (showDiagnosticsColored lastDiags) <+> "diagnostics" + , "New:" <+> pretty (showDiagnosticsColored diags) <+> "diagnostics" + ] LogShakeText msg -> pretty msg LogCreateHieDbExportsMapStart -> "Initializing exports map from hiedb" @@ -1401,9 +1408,8 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics let uri' = filePathToUri' fp - -- let delay = if null newDiags then 0.1 else 0 - -- registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do - withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do + let delay = if null newDiags then 0.1 else 0 + registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do join $ mask_ $ do lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of @@ -1412,6 +1418,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) + -- logWith recorder Debug $ LogDiagsPublishLog k lastPublish newDiags LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) return action From 51c1ceba20e22cb73c02f0633e9d4cca7a4b2d48 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 6 Sep 2025 23:15:56 +0800 Subject: [PATCH 072/107] refactor progress reporting: remove unused parameters and simplify function calls --- .../Development/IDE/Core/ProgressReporting.hs | 45 +++++++------------ ghcide/src/Development/IDE/Core/Shake.hs | 3 +- 2 files changed, 16 insertions(+), 32 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 20dfbe9e69..3d8a2bf989 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -39,11 +39,7 @@ import Language.LSP.Server (ProgressAmount (..), ProgressCancellable (..), withProgress) import qualified Language.LSP.Server as LSP -import qualified ListT as L import qualified StmContainers.Map as STM -import qualified StmContainers.Set as S -import qualified StmContainers.Set as Set -import StmContainers.Set import UnliftIO (Async, async, bracket, cancel) data ProgressEvent @@ -128,25 +124,24 @@ updateState _ StopProgress st = pure st data InProgressState = InProgressState { -- | Number of files to do - todoVar :: TVar Int, + todoVar :: TVar Int, -- | Number of files done - doneVar :: TVar Int, - currentVar :: STM.Map NormalizedFilePath Int, - workingFileVar :: S.Set NormalizedFilePath + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int } newInProgress :: IO InProgressState -newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO <*> newIO +newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () recordProgress InProgressState {..} file shift = do (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar atomicallyNamed "recordProgress2" $ case (prev, new) of (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1) - (Nothing, _) -> modifyTVar' todoVar (+ 1) >> S.insert file workingFileVar + (Nothing, _) -> modifyTVar' todoVar (+ 1) (Just 0, 0) -> pure () (Just 0, _) -> modifyTVar' doneVar pred - (Just _, 0) -> modifyTVar' doneVar (+ 1) >> S.delete file workingFileVar + (Just _, 0) -> modifyTVar' doneVar (+ 1) (Just _, _) -> pure () where alterPrevAndNew = do @@ -163,18 +158,16 @@ recordProgress InProgressState {..} file shift = do progressReportingNoTrace :: STM Int -> STM Int -> - STM (Maybe T.Text)-> Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> IO ProgressReporting -progressReportingNoTrace _ _ _ Nothing _title _optProgressStyle = return noProgressReporting -progressReportingNoTrace todo done mf (Just lspEnv) title optProgressStyle = do +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting +progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do progressState <- newVar NotStarted - let _progressUpdate event = do - liftIO $ updateStateVar $ Event event + let _progressUpdate event = liftIO $ updateStateVar $ Event event _progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done mf) + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) return ProgressReporting {..} -- | `progressReporting` initiates a new progress reporting session. @@ -189,18 +182,12 @@ progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) - (readTVar $ doneVar inProgressState) (getFile $ workingFileVar inProgressState) (Just lspEnv) title optProgressStyle + (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle let inProgress :: NormalizedFilePath -> IO a -> IO a inProgress = updateStateForFile inProgressState return PerFileProgressReporting {..} where - getFile :: Set.Set NormalizedFilePath -> STM (Maybe T.Text) - getFile set = do - let lst = S.listT set - x <- L.head lst - return (T.pack . fromNormalizedFilePath <$> x) - updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const where -- This functions are deliberately eta-expanded to avoid space leaks. @@ -216,25 +203,23 @@ progressCounter :: ProgressReportingStyle -> STM Int -> STM Int -> - STM (Maybe T.Text)-> IO () -progressCounter lspEnv title optProgressStyle getTodo getDone mf = +progressCounter lspEnv title optProgressStyle getTodo getDone = LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 where loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do - (todo, done, nextPct,file) <- liftIO $ atomically $ do + (todo, done, nextPct) <- liftIO $ atomically $ do todo <- getTodo done <- getDone - file <- mf let nextFrac :: Double nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo nextPct :: UInt nextPct = floor $ 100 * nextFrac when (nextPct == prevPct) retry - pure (todo, done, nextPct, file) + pure (todo, done, nextPct) - _ <- update (ProgressAmount (Just nextPct) (Just $ (T.pack $ show done) <> "/" <> (T.pack $ show todo) <> maybe mempty (":" <>) file)) + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) loop update nextPct mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b0870df27b..4c78655697 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -713,8 +713,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer semanticTokensId <- newTVarIO 0 indexProgressReporting <- progressReportingNoTrace (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted) ) - (readTVar indexCompleted) (pure $ Nothing) - lspEnv "Indexing" optProgressStyle + (readTVar indexCompleted) lspEnv "Indexing" optProgressStyle let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb From 1ed5fcb474fe9c5b4767c225c1a1c2397397d052 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 04:25:05 +0800 Subject: [PATCH 073/107] fix old actions runs because we did not increment the step before releasing the serialized queue --- ghcide/src/Development/IDE/Core/Shake.hs | 85 +++++++++++++------ .../src/Development/IDE/Graph/Database.hs | 33 +++++-- .../Development/IDE/Graph/Internal/Action.hs | 24 ++++-- .../IDE/Graph/Internal/Database.hs | 2 +- .../Development/IDE/Graph/Internal/Types.hs | 36 ++++++-- hls-graph/src/Development/IDE/WorkerThread.hs | 43 +++++----- hls-test-utils/src/Test/Hls.hs | 5 +- 7 files changed, 156 insertions(+), 72 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4c78655697..98d446f06d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -129,9 +129,9 @@ import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import Control.Exception (Exception (fromException)) -import Data.Either (isLeft, isRight, - lefts) +import Data.Either (isRight, lefts) +import Data.Int (Int64) +import Data.IORef.Extra (atomicModifyIORef'_) import Development.IDE.Core.Tracing import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, @@ -142,13 +142,15 @@ import Development.IDE.Graph hiding (ShakeValue, action) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, + shakeGetActionQueueLength, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys, + shakeRunDatabaseForKeysSep, shakeShutDatabase) -import Development.IDE.Graph.Internal.Action (runActionInDb) +import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) import Development.IDE.Graph.Internal.Types (Step (..), getShakeStep) @@ -184,15 +186,15 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import UnliftIO (MonadUnliftIO (withRunInIO)) -import qualified UnliftIO.Exception as UE +import UnliftIO (MonadUnliftIO (withRunInIO), + newIORef, readIORef) data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()]) @@ -207,10 +209,13 @@ data Log -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] | LogShakeText !T.Text + | LogMonitering !T.Text !Int64 deriving Show instance Pretty Log where pretty = \case + LogMonitering name value -> + "Monitoring:" <+> pretty name <+> "value:" <+> pretty value LogDiagsPublishLog key lastDiags diags -> vcat [ "Publishing diagnostics for" <+> pretty (show key) @@ -222,11 +227,12 @@ instance Pretty Log where "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize - LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath -> + LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath step -> vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) + , "Current step:" <+> pretty (show step) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" @@ -690,7 +696,7 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting - withHieDb threadQueue opts monitoring rules rootDir = mdo + withHieDb threadQueue opts argMonitoring rules rootDir = mdo -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue restartQueue = tRestartQueue threadQueue @@ -717,12 +723,12 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb - -- TODO: exceptions can be swallowed here? - _ <- async $ do + async <- async $ do logWith recorder Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) + link async progress <- if reportProgress @@ -750,6 +756,9 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer checkParents <- optCheckParents + + logMonitoring <- newLogMonitoring recorder + let monitoring = logMonitoring <> argMonitoring -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) @@ -757,6 +766,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb + readDatabaseActionQueueCount = fromIntegral <$> shakeGetActionQueueLength shakeDb registerGauge monitoring "ghcide.values_count" readValuesCounter registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys @@ -764,12 +774,28 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer registerGauge monitoring "ghcide.exports_map_count" readExportsMap registerGauge monitoring "ghcide.database_count" readDatabaseCount registerCounter monitoring "ghcide.num_builds" readDatabaseStep + registerCounter monitoring "ghcide.database_action_queue_count" readDatabaseActionQueueCount stopMonitoring <- start monitoring let ideState = IdeState{..} return ideState - +newLogMonitoring :: MonadIO m => Recorder (WithPriority Log) -> m Monitoring +newLogMonitoring logger = do + actions <- newIORef [] + let registerCounter name readA = do + let update = do + val <- readA + logWith logger Info $ LogMonitering name (fromIntegral val) + atomicModifyIORef'_ actions (update :) + registerGauge = registerCounter + let start = do + a <- regularly 10 $ sequence_ =<< readIORef actions + return (cancel a) + return Monitoring{..} + where + regularly :: Seconds -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> sleep delay) getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . stateValues @@ -837,7 +863,8 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + step <- shakeGetBuildStep shakeDb + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res step ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. @@ -859,12 +886,13 @@ shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do (b, dai) <- instantiateDelayedAction act atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue + logWith shakeRecorder Debug $ LogShakeText (T.pack $ "Enqueued action: " <> actionName act) let wait' barrier = waitBarrier barrier `catches` [ Handler(\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) - , Handler (\e@AsyncCancelled -> do + , Handler (\e@(SomeAsyncException _) -> do logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act) atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue @@ -892,6 +920,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do VFSModified vfs -> atomically $ writeTVar vfsVar vfs IdeOptions{optRunSubset} <- getIdeOptionsIO extras + reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue step <- getShakeStep shakeDb allPendingKeys <- @@ -907,13 +936,14 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do Left e -> logWith recorder Error $ LogShakeText (T.pack $ label ++ " failed: " ++ show e) Right r -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " finished: " ++ show r) pumpActionThread = do - d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue - r <- runActionInDb [run d] - liftIO $ logResult "pumpActionThread" r + logWith recorder Debug $ LogShakeText (T.pack $ "Starting action" ++ "(step: " <> show step) + d <- runActionInDbCb actionName run (popQueue actionQueue) (logResult "pumpActionThread" . return) + step <- getShakeStep shakeDb + logWith recorder Debug $ LogShakeText (T.pack $ "started action" ++ "(step: " <> show step <> "): " <> actionName d) pumpActionThread -- TODO figure out how to thread the otSpan into defineEarlyCutoff - run d = do + run d = do start <- liftIO offsetTime getAction d liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue @@ -921,23 +951,24 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do logWith recorder (actionPriority d) $ LogDelayedAction d runTime -- The inferred type signature doesn't work in ghc >= 9.0.1 - workRun :: (forall b. IO b -> IO b) -> IO () - workRun restore = withSpan "Shake session" $ \otSpan -> do + -- workRun :: (forall b. IO b -> IO b) -> IO () + workRun start restore = withSpan "Shake session" $ \otSpan -> do setTag otSpan "reason" (fromString reason) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) - let keysActs = pumpActionThread : map run (reenqueued ++ acts) - res <- try @SomeException $ - restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs - logWith recorder Debug $ LogBuildSessionFinish step $ res + res <- try @SomeException $ restore start + logWith recorder Debug $ LogBuildSessionFinish step res + + let keysActs = pumpActionThread : map run (reenqueued ++ acts) + -- first we increase the step, so any actions started from here on + start <- shakeRunDatabaseForKeysSep (toListKeySet <$> allPendingKeys) shakeDb keysActs -- Do the work in a background thread parentTid <- myThreadId workThread <- asyncWithUnmask $ \x -> do childThreadId <- myThreadId logWith recorder Info $ LogShakeText ("Starting shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")") - workRun x - + workRun start x -- Cancelling is required to flush the Shake database when either -- the filesystem or the Ghc configuration have changed @@ -949,7 +980,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do cancelWith workThread $ AsyncParentKill tid step shakeShutDatabase shakeDb - + -- should wait until the step has increased pure (ShakeSession{..}) instantiateDelayedAction diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index c7b4e6a6be..0b072974cb 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -4,15 +4,19 @@ module Development.IDE.Graph.Database( shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys, + shakeRunDatabaseForKeysSep, shakeProfileDatabase, shakeGetBuildStep, shakeGetDatabaseKeys, shakeGetDirtySet, shakeGetCleanKeys ,shakeGetBuildEdges, - shakeShutDatabase) where -import Control.Concurrent.STM.Stats (readTVarIO) + shakeShutDatabase, + shakeGetActionQueueLength) where +import Control.Concurrent.STM.Stats (atomically, + readTVarIO) import Control.Exception (SomeException) +import Control.Monad (join) import Data.Dynamic import Data.Maybe import Development.IDE.Graph.Classes () @@ -40,7 +44,7 @@ shakeNewDatabase que opts rules = do pure $ ShakeDatabase (length actions) actions db shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [Either SomeException a] -shakeRunDatabase = shakeRunDatabaseForKeys Nothing +shakeRunDatabase s xs = shakeRunDatabaseForKeys Nothing s xs -- | Returns the set of dirty keys annotated with their age (in # of builds) shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] @@ -58,15 +62,26 @@ unvoid :: Functor m => m () -> m a unvoid = fmap undefined -- | Assumes that the database is not running a build -shakeRunDatabaseForKeys +-- The nested IO is to +-- seperate incrementing the step from running the build +shakeRunDatabaseForKeysSep :: Maybe [Key] -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] - -> IO [Either SomeException a] -shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do + -> IO (IO [Either SomeException a]) +shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged - drop lenAs1 <$> runActions db (map unvoid as1 ++ as2) + return $ drop lenAs1 <$> runActions db (map unvoid as1 ++ as2) + +shakeRunDatabaseForKeys + :: Maybe [Key] + -- ^ Set of keys changed since last run. 'Nothing' means everything has changed + -> ShakeDatabase + -> [Action a] + -> (IO [Either SomeException a]) +shakeRunDatabaseForKeys keysChanged sdb as2 = join $ shakeRunDatabaseForKeysSep keysChanged sdb as2 + -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. @@ -90,3 +105,7 @@ shakeGetBuildEdges (ShakeDatabase _ _ db) = do -- annotated with how long ago (in # builds) they were visited shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)] shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db + +shakeGetActionQueueLength :: ShakeDatabase -> IO Int +shakeGetActionQueueLength (ShakeDatabase _ _ db) = + atomically $ databaseGetActionQueueLength db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ce1e7e432d..8624c490e8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -13,10 +13,11 @@ module Development.IDE.Graph.Internal.Action , runActions , Development.IDE.Graph.Internal.Action.getDirtySet , getKeysAndVisitedAge -, runActionInDb +, runActionInDbCb ) where import Control.Concurrent.Async +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class @@ -31,7 +32,7 @@ import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Types import System.Exit -import UnliftIO (atomically, +import UnliftIO (STM, atomically, newEmptyTMVarIO, putTMVar, readTMVar) @@ -48,23 +49,32 @@ parallel [] = return [] parallel xs = do a <- Action ask deps <- liftIO $ readIORef $ actionDeps a - case deps of UnknownDeps -> -- if we are already in the rerun mode, nothing we do is going to impact our state - runActionInDb xs + runActionInDb "parallel" xs deps -> error $ "parallel not supported when we have precise dependencies: " ++ show deps -- (newDeps, res) <- liftIO $ unzip <$> runActionInDb usingState xs -- liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps -- return () -runActionInDb :: [Action a] -> Action [Either SomeException a] -runActionInDb acts = do +-- non-blocking version of runActionInDb +runActionInDbCb :: (a -> String) -> (a -> Action result) -> STM a -> (Either SomeException result -> IO ()) -> Action a +runActionInDbCb getTitle work getAct handler = do + a <- Action ask + liftIO $ atomicallyNamed "action queue - pop" $ do + act <- getAct + runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)] + return act + +runActionInDb :: String -> [Action a] -> Action [Either SomeException a] +runActionInDb title acts = do a <- Action ask xs <- mapM (\x -> do barrier <- newEmptyTMVarIO return (x, barrier)) acts - liftIO $ atomically $ runInDataBase (actionDatabase a) (map (\(x, b) -> (ignoreState a x >>= (atomically . putTMVar b . Right), atomically . putTMVar b . Left)) xs) + liftIO $ atomically $ runInDataBase title (actionDatabase a) + (map (\(x, b) -> (ignoreState a x, atomically . putTMVar b)) xs) results <- liftIO $ mapM (atomically . readTMVar) $ fmap snd xs return results diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 83ded5168d..853be75d5f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -123,7 +123,7 @@ builderOne db@Database {..} stack id = do Dirty s -> do SMap.focus (updateStatus $ Running current s) id databaseValues traceEvent ("Starting build of key: " ++ show id ++ ", step "++ show current) - $ runOneInDataBase db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + $ runOneInDataBase (show id) db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues return Nothing Clean r -> return $ Just r -- force here might contains async exceptions from previous runs diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 08b911e765..fae69da565 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Development.IDE.Graph.Internal.Types where @@ -23,8 +24,9 @@ import Data.Typeable import Debug.Trace (traceEventIO, traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key -import Development.IDE.WorkerThread (TaskQueue, - awaitRunInThreadStmInNewThreads) +import Development.IDE.WorkerThread (DeliverStatus (..), + TaskQueue, counTaskQueue, + runInThreadStmInNewThreads) import GHC.Conc (TVar, atomically) import GHC.Generics (Generic) import qualified ListT @@ -131,15 +133,31 @@ data Database = Database { databaseValues :: !(Map Key KeyDetails) } -runInDataBase :: Database -> [(IO result, SomeException -> IO ())] -> STM () -runInDataBase db acts = do - s <- getDataBaseStepInt db - awaitRunInThreadStmInNewThreads (getDataBaseStepInt db) s (databaseQueue db) (databaseThreads db) acts -runOneInDataBase :: Database -> IO result -> (SomeException -> IO ()) -> STM () -runOneInDataBase db act handler = do +databaseGetActionQueueLength :: Database -> STM Int +databaseGetActionQueueLength db = do + counTaskQueue (databaseQueue db) + +runInDataBase :: String -> Database -> [(IO result, Either SomeException result -> IO ())] -> STM () +runInDataBase title db acts = do s <- getDataBaseStepInt db - awaitRunInThreadStmInNewThreads (getDataBaseStepInt db) s (databaseQueue db) (databaseThreads db) [(act, handler)] + runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) acts + +runOneInDataBase :: String -> Database -> IO result -> (SomeException -> IO ()) -> STM () +runOneInDataBase title db act handler = do + s <- getDataBaseStepInt db + runInThreadStmInNewThreads + (getDataBaseStepInt db) + (DeliverStatus s title) + (databaseQueue db) + (databaseThreads db) + [ ( act, + \case + Left e -> handler e + Right _ -> return () + ) + ] + getDataBaseStepInt :: Database -> STM Int getDataBaseStepInt db = do diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 2f496f6cff..344971483f 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -11,15 +11,15 @@ see Note [Serializing runs in separate thread] module Development.IDE.WorkerThread ( LogWorkerThread (..), + DeliverStatus(..), withWorkerQueue, awaitRunInThread, TaskQueue, writeTaskQueue, withWorkerQueueSimple, - awaitRunInThreadStm, - awaitRunInThreadStmInNewThread, - awaitRunInThreadStmInNewThreads, - isEmptyTaskQueue + runInThreadStmInNewThreads, + isEmptyTaskQueue, + counTaskQueue ) where import Control.Concurrent.Async (Async, async, withAsync) @@ -33,6 +33,7 @@ import qualified Data.Text as T import Control.Concurrent import Control.Exception (catch) import Control.Monad (void, when) +import Debug.Trace (traceM) import Prettyprinter data LogWorkerThread @@ -117,28 +118,22 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- and then blocks until the result is computed. If the action throws an -- non-async exception, it is rethrown in the calling thread. -awaitRunInThreadStm :: TaskQueue (IO ()) -> IO result -> STM result -awaitRunInThreadStm (TaskQueue q) act = do - barrier <- newEmptyTMVar - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - writeTQueue q (try act >>= atomically . putTMVar barrier) - resultOrException <- takeTMVar barrier - case resultOrException of - Left e -> throw (e :: SomeException) - Right r -> return r -awaitRunInThreadStmInNewThread :: STM Int -> Int -> TaskQueue (IO ()) -> TVar [Async ()] -> IO result -> (SomeException -> IO ()) -> STM () -awaitRunInThreadStmInNewThread getStep deliverStep q tthreads act handler = awaitRunInThreadStmInNewThreads getStep deliverStep q tthreads [(act, handler)] +data DeliverStatus = DeliverStatus + { deliverStep :: Int + , deliverName :: String + } deriving (Show) -awaitRunInThreadStmInNewThreads :: STM Int -> Int -> TaskQueue (IO ()) -> TVar [Async ()] -> [(IO result, SomeException -> IO ())] -> STM () -awaitRunInThreadStmInNewThreads getStep deliverStep (TaskQueue q) tthreads acts = do +runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (IO ()) -> TVar [Async ()] -> [(IO result, Either SomeException result -> IO ())] -> STM () +runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do -- Take an action from TQueue, run it and -- use barrier to wait for the result writeTQueue q (uninterruptibleMask $ \restore -> do curStep <- atomically getStep - when (curStep == deliverStep) $ do - syncs <- mapM (\(act, handler) -> async (restore (void act `catch` \(SomeException e) -> handler (SomeException e)))) acts + traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) + when (curStep == deliverStep deliver) $ do + syncs <- mapM (\(act, handler) -> + async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))) acts atomically $ modifyTVar' tthreads (syncs++) ) @@ -162,3 +157,11 @@ tryReadTaskQueue (TaskQueue q) = tryReadTQueue q isEmptyTaskQueue :: TaskQueue a -> STM Bool isEmptyTaskQueue (TaskQueue q) = isEmptyTQueue q +-- look and count the number of items in the queue +-- do not remove them +counTaskQueue :: TaskQueue a -> STM Int +counTaskQueue (TaskQueue q) = do + xs <- flushTQueue q + mapM_ (unGetTQueue q) (reverse xs) + return $ length xs + diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0ab203fe36..3ac4413860 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -770,7 +770,10 @@ runSessionWithTestConfig TestConfig{..} session = let plugins = testPluginDescriptor recorder <> lspRecorderPlugin timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" - let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig + , messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logStdErr = True + } arguments = testingArgs serverRoot recorderIde plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) From df6a8f4b35d628fed1af48627dc249260f8fd6e0 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 05:05:11 +0800 Subject: [PATCH 074/107] fix build --- hls-graph/hls-graph.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index d1bbb61c31..b1553580d3 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -133,7 +133,7 @@ test-suite tests -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts build-depends: - , transformers ^>=0.6.1.2 + , transformers , base , extra , hls-graph @@ -143,6 +143,5 @@ test-suite tests , tasty , tasty-hspec >= 1.2 , tasty-rerun - , transformers build-tool-depends: hspec-discover:hspec-discover From 80733e7131a0c905157c5ffa4673d22e6067cf19 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 05:24:18 +0800 Subject: [PATCH 075/107] remove unused imports from various modules --- hls-graph/src/Development/IDE/WorkerThread.hs | 5 ++--- plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs | 1 - plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs | 6 ++---- .../src/Ide/Plugin/ExplicitFields.hs | 3 +-- plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs | 1 - .../src/Ide/Plugin/StylishHaskell.hs | 1 - 6 files changed, 5 insertions(+), 12 deletions(-) diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 344971483f..1b527e089d 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -32,8 +32,7 @@ import qualified Data.Text as T import Control.Concurrent import Control.Exception (catch) -import Control.Monad (void, when) -import Debug.Trace (traceM) +import Control.Monad (when) import Prettyprinter data LogWorkerThread @@ -130,7 +129,7 @@ runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do -- use barrier to wait for the result writeTQueue q (uninterruptibleMask $ \restore -> do curStep <- atomically getStep - traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) + -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) when (curStep == deliverStep deliver) $ do syncs <- mapM (\(act, handler) -> async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))) acts diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs index bb0994442a..0bd40b13cc 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -6,7 +6,6 @@ module Ide.Plugin.Class.ExactPrint where import Control.Monad.Trans.Maybe import Data.Either.Extra (eitherToMaybe) -import Data.Functor.Identity (Identity) import qualified Data.Text as T import Development.IDE.GHC.Compat import GHC.Parser.Annotation diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 1669aba43d..0fa6b4890a 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -22,7 +22,6 @@ import Development.IDE import Development.IDE.Core.PluginUtils (useMT) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) -import Development.IDE.GHC.Compat.Util (bagToList) import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils @@ -226,9 +225,8 @@ getInstanceBindTypeSigsRule recorder = do whenMaybe (isBindingName name) $ do env <- tcInitTidyEnv #if MIN_VERSION_ghc(9,11,0) - let ty = + let ty = tidyOpenType env (idType id) #else - let (_, ty) = + let (_, ty) = tidyOpenType env (idType id) #endif - tidyOpenType env (idType id) pure $ InstanceBindTypeSig name ty diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index a111e9062b..e2f8eb38f6 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -57,8 +57,7 @@ import Development.IDE.GHC.Compat (FieldLabel (flSelector), HsConDetails (RecCon), HsExpr (HsApp, HsVar, XExpr), HsFieldBind (hfbLHS), - HsRecFields (..), - HsWrap (HsWrap), LPat, + HsRecFields (..), LPat, Located, NamedThing (getName), Outputable, diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs index db1696d94b..5ca86baecc 100644 --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -5,7 +5,6 @@ import Control.Monad.Except (ExceptT, MonadError, throwError) import Control.Monad.IO.Class (liftIO) import qualified Data.Array as A -import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 767cc061df..0f78e67d7e 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -25,7 +25,6 @@ import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.Stylish import Language.LSP.Protocol.Types as LSP -import System.Directory import System.FilePath data Log From 26045a12ce5b08ba36f98fb25f852a67e83283ec Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 07:22:52 +0800 Subject: [PATCH 076/107] upgrade lsp version --- cabal.project | 6 ++++++ ghcide/src/Development/IDE/Core/FileStore.hs | 4 ++-- ghcide/src/Development/IDE/Core/Rules.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 7 +++++-- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 2 +- .../hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs | 2 +- .../hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 2 +- 7 files changed, 18 insertions(+), 9 deletions(-) diff --git a/cabal.project b/cabal.project index 8d8bd080af..d83e432492 100644 --- a/cabal.project +++ b/cabal.project @@ -56,3 +56,9 @@ if impl(ghc >= 9.11) allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, + +source-repository-package + type: git + location: https://github.com/soulomoon/lsp.git + tag: 640c7c755bf16128e3cb19c257688aa3305ff9f5 + subdir: lsp lsp-types lsp-test diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 07b104d26d..0bdec3874e 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -252,8 +252,8 @@ getVersionedTextDoc doc = do maybe (pure Nothing) getVirtualFile $ uriToNormalizedFilePath $ toNormalizedUri uri let ver = case mvf of - Just (VirtualFile lspver _ _) -> lspver - Nothing -> 0 + Just (VirtualFile lspver _ _ _) -> lspver + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 8273570aca..3e1d7f09ea 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -516,8 +516,8 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybe vfsRef <- asks vfsVar vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of - Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + Just (Open vf) -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + _ -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 98d446f06d..51c34e61e2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -147,7 +147,6 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, - shakeRunDatabaseForKeys, shakeRunDatabaseForKeysSep, shakeShutDatabase) import Development.IDE.Graph.Internal.Action (runActionInDbCb) @@ -427,10 +426,14 @@ class Typeable a => IsIdeGlobal a where -- data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile -- | Read a virtual file from the current snapshot +getOpenFile :: VirtualFileEntry -> Maybe VirtualFile +getOpenFile (Open vf) = Just vf +getOpenFile _ = Nothing +-- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras - let file = Map.lookup (filePathToUri' nf) vfs + let file = getOpenFile =<< Map.lookup (filePathToUri' nf) vfs pure $! file -- Don't leak a reference to the entire map -- Take a snapshot of the current LSP VFS diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 0a5cecaca8..6c59a5ffe5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -857,7 +857,7 @@ mergeListsBy cmp all_lists = merge_lists all_lists -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo getCompletionPrefixFromRope pos@(Position l c) ropetext = diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index 638d14c51d..6f2bd70ab4 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -7,7 +7,7 @@ import Development.IDE.GHC.Compat hiding (LocatedA, import Development.IDE.GHC.Compat.ExactPrint (ExactPrint, exactPrint) import Development.IDE.GHC.Compat.Util import Generics.SYB (ext1Q, ext2Q, extQ) -import GHC.Hs hiding (AnnLet) +import GHC.Hs import GHC.Hs.Dump import GHC.Plugins hiding (AnnLet) import Prelude hiding ((<>)) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index a0d1648fb3..7daae0df51 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -90,7 +90,7 @@ docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Sessio docLspSemanticTokensString doc = do res <- Test.getSemanticTokens doc textContent <- documentContents doc - let vfs = VirtualFile 0 0 (Rope.fromText textContent) + let vfs = VirtualFile 0 0 (Rope.fromText textContent) (Just LanguageKind_Haskell) case res ^? Language.LSP.Protocol.Types._L of Just tokens -> do either (error . show) pure $ recoverLspSemanticTokens vfs tokens From 74e190921f476efc4810e5479fec46262fb95e97 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 09:39:45 +0800 Subject: [PATCH 077/107] fix build in older verions --- ghcide/src/Development/IDE/Core/Compile.hs | 6 +++++- ghcide/src/Development/IDE/Core/PositionMapping.hs | 1 + ghcide/src/Development/IDE/Core/Shake.hs | 3 ++- ghcide/src/Development/IDE/GHC/Compat.hs | 1 + ghcide/src/Development/IDE/LSP/LanguageServer.hs | 2 +- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 3 --- plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs | 1 + plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs | 1 + .../src/Ide/Plugin/ExplicitFields.hs | 3 ++- plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs | 1 + plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs | 2 +- plugins/hls-signature-help-plugin/test/Main.hs | 3 ++- .../src/Ide/Plugin/StylishHaskell.hs | 1 + 13 files changed, 19 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 8065e56325..2b25fb08c0 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -115,9 +115,14 @@ import GHC.Tc.Gen.Splice import GHC.Types.Error import GHC.Types.ForeignStubs import GHC.Types.TypeEnv +import Development.IDE.WorkerThread (writeTaskQueue) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,11,0) +import GHC.Types.HpcInfo +#endif + #if MIN_VERSION_ghc(9,7,0) import Data.Foldable (toList) import GHC.Unit.Module.Warnings @@ -150,7 +155,6 @@ import GHC.Iface.Ext.Types (NameEntityInfo) #if MIN_VERSION_ghc(9,12,0) import Development.IDE.Import.FindImports -import Development.IDE.WorkerThread (writeTaskQueue) #endif --Simple constants to make sure the source is consistently named diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index 41f9ca50e0..de02f5b1f7 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -28,6 +28,7 @@ import Control.Lens ((^.)) import Control.Monad import Data.Algorithm.Diff import Data.Bifunctor +import Data.List import qualified Data.Text as T import qualified Data.Vector.Unboxed as V import qualified Language.LSP.Protocol.Lens as L diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 51c34e61e2..4552fc6457 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -107,7 +107,8 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (partition, takeEnd) +import Data.List.Extra (foldl', partition, + takeEnd) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index d4750f1a2e..befd22c8de 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -115,6 +115,7 @@ module Development.IDE.GHC.Compat( import Control.Applicative ((<|>)) import qualified Data.ByteString as BS import Data.Coerce (coerce) +import Data.List (foldl') import qualified Data.Map as Map import qualified Data.Set as S import Data.String (IsString (fromString)) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index bff90cb66f..9a56f02137 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -54,7 +54,7 @@ import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) -import System.Time.Extra (Seconds, sleep) +import System.Time.Extra (Seconds) import System.Timeout (timeout) data Log = LogRegisteringIdeConfig !IdeConfiguration diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 26eb8d5395..e14ab56847 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -15,7 +15,6 @@ import Control.Exception (evaluate, mask, throwIO) import Control.Monad.Extra (eitherM, join, mapMaybeM) import Data.Either (fromRight) import Data.IORef -import qualified Data.Map as M import Data.Unique (Unique) import qualified Data.Unique as Unique import Development.IDE.GHC.Compat hiding (newUnique) @@ -25,9 +24,7 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) import GHC.Driver.Env (hsc_all_home_unit_ids) -import Ide.PluginUtils (toAbsolute) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) -- | An 'HscEnv' with equality. Two values are considered equal diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs index 0bd40b13cc..bb0994442a 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -6,6 +6,7 @@ module Ide.Plugin.Class.ExactPrint where import Control.Monad.Trans.Maybe import Data.Either.Extra (eitherToMaybe) +import Data.Functor.Identity (Identity) import qualified Data.Text as T import Development.IDE.GHC.Compat import GHC.Parser.Annotation diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 0fa6b4890a..ee2a3fda7f 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -22,6 +22,7 @@ import Development.IDE import Development.IDE.Core.PluginUtils (useMT) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) +import Development.IDE.GHC.Compat.Util (bagToList) import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index e2f8eb38f6..a111e9062b 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -57,7 +57,8 @@ import Development.IDE.GHC.Compat (FieldLabel (flSelector), HsConDetails (RecCon), HsExpr (HsApp, HsVar, XExpr), HsFieldBind (hfbLHS), - HsRecFields (..), LPat, + HsRecFields (..), + HsWrap (HsWrap), LPat, Located, NamedThing (getName), Outputable, diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs index 5ca86baecc..db1696d94b 100644 --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -5,6 +5,7 @@ import Control.Monad.Except (ExceptT, MonadError, throwError) import Control.Monad.IO.Class (liftIO) import qualified Data.Array as A +import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index 6f2bd70ab4..638d14c51d 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -7,7 +7,7 @@ import Development.IDE.GHC.Compat hiding (LocatedA, import Development.IDE.GHC.Compat.ExactPrint (ExactPrint, exactPrint) import Development.IDE.GHC.Compat.Util import Generics.SYB (ext1Q, ext2Q, extQ) -import GHC.Hs +import GHC.Hs hiding (AnnLet) import GHC.Hs.Dump import GHC.Plugins hiding (AnnLet) import Prelude hiding ((<>)) diff --git a/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs index 4ac665e7d1..f6518552ae 100644 --- a/plugins/hls-signature-help-plugin/test/Main.hs +++ b/plugins/hls-signature-help-plugin/test/Main.hs @@ -11,7 +11,8 @@ import qualified Data.Text as T import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (PosPrefixInfo)) import Ide.Plugin.SignatureHelp (descriptor) import qualified Language.LSP.Protocol.Lens as L -import Test.Hls +import Test.Hls hiding + (getSignatureHelp) import Test.Hls.FileSystem (VirtualFileTree, directCradle, file, mkVirtualFileTree, diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 0f78e67d7e..767cc061df 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -25,6 +25,7 @@ import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.Stylish import Language.LSP.Protocol.Types as LSP +import System.Directory import System.FilePath data Log From 8f3737973f58a6313ae9690922a84d6a6a9ee98e Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sun, 7 Sep 2025 14:42:32 +0800 Subject: [PATCH 078/107] prefer shakeRestart if there are others in queue --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- hls-graph/src/Development/IDE/WorkerThread.hs | 14 +++++++++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4552fc6457..e8f2022f27 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -854,7 +854,7 @@ delayedAction a = do -- but actions added via 'shakeEnqueue' will be requeued. shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = - void $ awaitRunInThread (restartQueue shakeExtras) $ do + void $ awaitRunInThreadAtHead (restartQueue shakeExtras) $ do withMVar' shakeSession (\runner -> do diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 1b527e089d..fd6a5c7695 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -19,7 +19,8 @@ module Development.IDE.WorkerThread withWorkerQueueSimple, runInThreadStmInNewThreads, isEmptyTaskQueue, - counTaskQueue + counTaskQueue, + awaitRunInThreadAtHead ) where import Control.Concurrent.Async (Async, async, withAsync) @@ -147,6 +148,17 @@ awaitRunInThread (TaskQueue q) act = do Left e -> throw (e :: SomeException) Right r -> return r +awaitRunInThreadAtHead :: TaskQueue (IO ()) -> IO result -> IO result +awaitRunInThreadAtHead (TaskQueue q) act = do + barrier <- newEmptyTMVarIO + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + atomically $ unGetTQueue q (try act >>= atomically . putTMVar barrier) + resultOrException <- atomically $ takeTMVar barrier + case resultOrException of + Left e -> throw (e :: SomeException) + Right r -> return r + writeTaskQueue :: TaskQueue a -> a -> STM () writeTaskQueue (TaskQueue q) = writeTQueue q From 1fd46bfae18aa23b775c7b6d242da54b7e7418a1 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 8 Sep 2025 06:48:17 +0800 Subject: [PATCH 079/107] 1. mergeMultiple restarts if they appear at once. 2. spawns only if need when building a key, see `builderOneCoroutine` --- ghcide/src/Development/IDE/Core/Shake.hs | 163 +++++++++++++----- .../src/Development/IDE/LSP/LanguageServer.hs | 24 ++- ghcide/src/Development/IDE/Main.hs | 8 +- .../src/Development/IDE/Graph/Database.hs | 5 +- .../IDE/Graph/Internal/Database.hs | 73 +++++--- .../Development/IDE/Graph/Internal/Types.hs | 4 +- hls-graph/src/Development/IDE/WorkerThread.hs | 47 +++-- hls-graph/test/ActionSpec.hs | 8 +- hls-graph/test/DatabaseSpec.hs | 9 +- 9 files changed, 235 insertions(+), 106 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e8f2022f27..639ad28c91 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -25,6 +25,8 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, + ShakeRestartArgs(..), + shakeRestart, IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, @@ -76,7 +78,7 @@ module Development.IDE.Core.Shake( Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), - runWithSignal + runWithSignal, runRestartTask, runRestartTaskDync, dynShakeRestart ) where import Control.Concurrent.Async @@ -107,8 +109,7 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) +import Data.List.Extra (partition, takeEnd) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL @@ -152,7 +153,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeShutDatabase) import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) -import Development.IDE.Graph.Internal.Types (Step (..), +import Development.IDE.Graph.Internal.Types (DBQue, Step (..), getShakeStep) import Development.IDE.Graph.Rule import Development.IDE.Types.Action @@ -194,7 +195,7 @@ import UnliftIO (MonadUnliftIO (withRun data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int + | LogBuildSessionRestart !ShakeRestartArgs ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()]) @@ -227,9 +228,10 @@ instance Pretty Log where "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize - LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath step -> + LogBuildSessionRestart restartArgs actionQueue keyBackLog abortDuration shakeProfilePath step -> vcat - [ "Restarting build session due to" <+> pretty reason + [ "Restarting build session due to" <+> pretty (sraReason restartArgs) + , "Restarts num:" <+> pretty (sraCount $ restartArgs) , "Action Queue:" <+> pretty (map actionName actionQueue) , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) , "Current step:" <+> pretty (show step) @@ -287,7 +289,9 @@ data HieDbWriter -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) -type RestartQueue = TaskQueue (IO ()) +-- type RestartQueue = TaskQueue ShakeRestartArgs +type ShakeQueue = DBQue +type RestartQueue = ShakeQueue type LoaderQueue = TaskQueue (IO ()) @@ -716,7 +720,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets - let restartShakeSession = shakeRestart recorder ideState + let restartShakeSession = shakeRestart restartQueue persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -761,11 +765,11 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer checkParents <- optCheckParents - logMonitoring <- newLogMonitoring recorder - let monitoring = logMonitoring <> argMonitoring + -- logMonitoring <- newLogMonitoring recorder + let monitoring = argMonitoring -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO (dirtyKeys shakeExtras) readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb @@ -784,6 +788,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer let ideState = IdeState{..} return ideState + newLogMonitoring :: MonadIO m => Recorder (WithPriority Log) -> m Monitoring newLogMonitoring logger = do actions <- newIORef [] @@ -849,37 +854,102 @@ delayedAction a = do liftIO $ shakeEnqueue extras a +data ShakeRestartArgs = ShakeRestartArgs + { sraVfs :: !VFSModified + , sraReason :: !String + , sraActions :: ![DelayedAction ()] + , sraBetweenSessions :: IO [Key] + , sraReStartQueue :: !RestartQueue + , sraCount :: !Int + , sraWaitMVars :: ![MVar ()] + -- ^ Just for debugging, how many restarts have been requested so far + } + +instance Show ShakeRestartArgs where + show ShakeRestartArgs{..} = + "ShakeRestartArgs { sraReason = " ++ show sraReason + ++ ", sraActions = " ++ show (map actionName sraActions) + ++ ", sraCount = " ++ show sraCount + ++ " }" + +instance Semigroup ShakeRestartArgs where + a <> b = ShakeRestartArgs + { sraVfs = sraVfs a <> sraVfs b + , sraReason = sraReason a ++ "; " ++ sraReason b + , sraActions = sraActions a ++ sraActions b + , sraBetweenSessions = (++) <$> sraBetweenSessions a <*> sraBetweenSessions b + , sraReStartQueue = sraReStartQueue a + , sraCount = sraCount a + sraCount b + , sraWaitMVars = sraWaitMVars a ++ sraWaitMVars b + } + -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = - void $ awaitRunInThreadAtHead (restartQueue shakeExtras) $ do - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - keys <- ioActionBetweenShakeSession - -- it is every important to update the dirty keys after we enter the critical section - -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - -- this log is required by tests - step <- shakeGetBuildStep shakeDb - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res step - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) +shakeRestart :: RestartQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do + waitMVar <- newEmptyMVar + void $ submitWork rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] + -- Wait until the restart is done + takeMVar waitMVar + +dynShakeRestart :: Dynamic -> ShakeRestartArgs +dynShakeRestart dy = case fromDynamic dy of + Just shakeRestartArgs -> shakeRestartArgs + Nothing -> error "Internal error, dynShakeRestart, got invalid dynamic type" + +-- runRestartTask :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +-- runRestartTask recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = +runRestartTaskDync :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () +runRestartTaskDync recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) + +runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () +runRestartTask recorder ideStateVar shakeRestartArgs = do + IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar + let prepareRestart sra@ShakeRestartArgs {..} = do + keys <- sraBetweenSessions + -- it is every important to update the dirty keys after we enter the critical section + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + -- Check if there is another restart request pending, if so, we run that one too + readAndGo sra sraReStartQueue + readAndGo sra sraReStartQueue = do + nextRestartArg <- atomically $ tryReadTaskQueue sraReStartQueue + case nextRestartArg of + Nothing -> return sra + Just (Left dy) -> do + res <- prepareRestart $ dynShakeRestart dy + return $ sra <> res + Just (Right _) -> readAndGo sra sraReStartQueue + withMVar' + shakeSession + ( \runner -> do + -- takeShakeLock shakeDb + (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + restartArgs <- prepareRestart shakeRestartArgs + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + res <- shakeDatabaseProfile shakeDb + backlog <- readTVarIO $ dirtyKeys shakeExtras + -- this log is required by tests + step <- shakeGetBuildStep shakeDb + logWith recorder Info $ LogBuildSessionRestart restartArgs queue backlog stopTime res step + return restartArgs + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + ( \(ShakeRestartArgs {..}) -> + do + (,()) <$> newSession recorder shakeExtras sraVfs shakeDb sraActions sraReason + `finally` for_ sraWaitMVars (`putMVar` ()) + ) + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) + -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. @@ -893,7 +963,7 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do logWith shakeRecorder Debug $ LogShakeText (T.pack $ "Enqueued action: " <> actionName act) let wait' barrier = waitBarrier barrier `catches` - [ Handler(\BlockedIndefinitelyOnMVar -> + [ Handler (\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) , Handler (\e@(SomeAsyncException _) -> do @@ -906,6 +976,10 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do data VFSModified = VFSUnmodified | VFSModified !VFS +instance Semigroup VFSModified where + x <> VFSUnmodified = x + _ <> x = x + -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. newSession @@ -1049,7 +1123,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do removeDirtyKey dk values st@(!counter, keys) (k, age) | age > maxAge , Just (kt,_) <- fromKeyType k - , not(kt `HSet.member` preservedKeys checkParents) + , not (kt `HSet.member` preservedKeys checkParents) = atomicallyNamed "GC" $ do gotIt <- STM.focus (Focus.member <* Focus.delete) k values when gotIt $ @@ -1424,12 +1498,12 @@ updateFileDiagnostics :: MonadIO m -> [FileDiagnostic] -- ^ current results -> m () updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do - liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do + liftIO $ withTrace ("update diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a - addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v + addTagUnsafe msg t x v = unsafePerformIO (addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store current = map (fdLspDiagnosticL %~ diagsFromRule) current0 @@ -1556,3 +1630,4 @@ runWithSignal msgStart msgEnd files rule = do kickSignal testing lspEnv files msgStart void $ uses rule files kickSignal testing lspEnv files msgEnd + diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9a56f02137..9c90a1b463 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -41,11 +41,13 @@ import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.Trans.Cont (ContT, evalContT) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service (shutdown) import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing +import Development.IDE.Graph.Internal.Types (DBQue) import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..)) @@ -63,6 +65,7 @@ data Log | LogReactorThreadStopped Int | LogCancelledRequest !SomeLspId | LogSession Session.Log + | LogShake Shake.Log | LogLspServer LspServerLog | LogReactorShutdownRequested Bool | LogShutDownTimeout Int @@ -73,6 +76,7 @@ data Log instance Pretty Log where pretty = \case + LogShake msg -> pretty msg LogInitializeIdeStateTookTooLong seconds -> "Building the initial session took more than" <+> pretty seconds <+> "seconds" LogReactorShutdownRequested b -> @@ -330,7 +334,7 @@ handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Init exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerExceptionOrShutDown $ do - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> + runWithWorkerThreads recorder ideMVar dbLoc $ \withHieDb' threadQueue' -> do ide <- ctxGetIdeState initParams env root withHieDb' threadQueue' putMVar ideMVar ide @@ -349,14 +353,20 @@ handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Init pure $ Right (env,ide) +runShakeThread :: Recorder (WithPriority Log) -> MVar IdeState -> ContT () IO DBQue +runShakeThread recorder mide = + withWorkerQueue + (logWith (cmapWithPrio (LogSession . Session.LogSessionWorkerThread) recorder) Debug) + "ShakeRestartQueue" + (eitherWorker (runRestartTaskDync (cmapWithPrio LogShake recorder) mide) id) -- | runWithWorkerThreads -- create several threads to run the session, db and session loader -- see Note [Serializing runs in separate thread] -runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () -runWithWorkerThreads recorder dbLoc f = evalContT $ do - (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc - sessionRestartTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "RestartTQueue" - sessionLoaderTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio Session.LogSessionWorkerThread recorder) Debug) "SessionLoaderTQueue" +runWithWorkerThreads :: Recorder (WithPriority Log) -> MVar IdeState -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithWorkerThreads recorder mide dbLoc f = evalContT $ do + (WithHieDbShield hiedb, threadQueue) <- runWithDb (cmapWithPrio LogSession recorder) dbLoc + sessionRestartTQueue <- runShakeThread recorder mide + sessionLoaderTQueue <- withWorkerQueueSimple (logWith (cmapWithPrio (LogSession . Session.LogSessionWorkerThread) recorder) Debug) "SessionLoaderTQueue" liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index ad4a36327a..afb50de96f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -374,7 +374,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Check argFiles -> do let dir = argsProjectRoot dbLoc <- getHieDbLoc dir - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + ideMVar <- newEmptyMVar + runWithWorkerThreads (cmapWithPrio LogLanguageServer recorder) ideMVar dbLoc $ \hiedb threadQueue -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -403,6 +404,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir + putMVar ideMVar ide shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -432,7 +434,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Custom (IdeCommand c) -> do let root = argsProjectRoot dbLoc <- getHieDbLoc root - runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \hiedb threadQueue -> do + ideMVar <- newEmptyMVar + runWithWorkerThreads (cmapWithPrio LogLanguageServer recorder) ideMVar dbLoc $ \hiedb threadQueue -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options @@ -441,6 +444,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root + putMVar ideMVar ide shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 0b072974cb..18b2ff026a 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -27,7 +27,6 @@ import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types -import Development.IDE.WorkerThread (TaskQueue) -- Placeholder to be the 'extra' if the user doesn't set it @@ -36,7 +35,7 @@ data NonExportedType = NonExportedType shakeShutDatabase :: ShakeDatabase -> IO () shakeShutDatabase (ShakeDatabase _ _ db) = shutDatabase db -shakeNewDatabase :: TaskQueue (IO ()) -> ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabase :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase shakeNewDatabase que opts rules = do let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts (theRules, actions) <- runRules extra rules @@ -79,7 +78,7 @@ shakeRunDatabaseForKeys -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] - -> (IO [Either SomeException a]) + -> IO [Either SomeException a] shakeRunDatabaseForKeys keysChanged sdb as2 = join $ shakeRunDatabaseForKeysSep keysChanged sdb as2 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 853be75d5f..56b2380217 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -44,10 +44,9 @@ import Data.Functor (unzip) #else import Data.List.NonEmpty (unzip) #endif -import Development.IDE.WorkerThread (TaskQueue) -newDatabase :: TaskQueue (IO ()) -> Dynamic -> TheRules -> IO Database +newDatabase :: DBQue -> Dynamic -> TheRules -> IO Database newDatabase databaseQueue databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 databaseThreads <- newTVarIO [] @@ -109,32 +108,54 @@ build db stack keys = do -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. builder :: (Traversable f) => Database -> Stack -> f Key -> IO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined -builder db stack keys = for keys $ \k -> builderOne db stack k +builder db stack keys = do + waits <- for keys (\k -> builderOneCoroutine skipThread db stack k) + for waits interpreBuildContinue + where skipThread = if length keys == 1 then IsSingleton else NotSingleton -builderOne :: Database -> Stack -> Key -> IO (Key, Result) -builderOne db@Database {..} stack id = do - traceEvent ("builderOne: " ++ show id) return () - res <- liftIO $ atomicallyNamed "builder" $ do - -- Spawn the id if needed - status <- SMap.lookup id databaseValues - current <- readTVar databaseStep +data IsSingletonTask = IsSingleton | NotSingleton +-- the first run should not block +data RunFirst = RunFirst | RunLater deriving stock (Eq, Show) +data BuildContinue = BCContinue (IO BuildContinue) | BCStop Key Result - val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of - Dirty s -> do - SMap.focus (updateStatus $ Running current s) id databaseValues - traceEvent ("Starting build of key: " ++ show id ++ ", step "++ show current) - $ runOneInDataBase (show id) db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues - return Nothing - Clean r -> return $ Just r - -- force here might contains async exceptions from previous runs - Running _step _s - | memberStack id stack -> throw $ StackException stack - | otherwise -> retry - Exception _ e _s -> throw e - pure val - case res of - Just r -> return (id, r) - Nothing -> builderOne db stack id +interpreBuildContinue :: BuildContinue -> IO (Key, Result) +interpreBuildContinue (BCStop k v) = return (k, v) +interpreBuildContinue (BCContinue ioR) = ioR >>= interpreBuildContinue + +builderOneCoroutine :: IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue +builderOneCoroutine isSingletonTask db stack id = + builderOneCoroutine' RunFirst isSingletonTask db stack id + where + builderOneCoroutine' :: RunFirst -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue + builderOneCoroutine' rf isSingletonTask db@Database {..} stack id = mask $ \restore -> do + traceEvent ("builderOne: " ++ show id) return () + liftIO $ atomicallyNamed "builder" $ do + -- Spawn the id if needed + status <- SMap.lookup id databaseValues + current <- readTVar databaseStep + case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Dirty s -> do + SMap.focus (updateStatus $ Running current s) id databaseValues + case isSingletonTask of + IsSingleton -> + return $ + BCContinue $ fmap (BCStop id) $ + restore (refresh db stack id s) `catch` \e@(SomeException _) -> do + atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + throw e + NotSingleton -> do + traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) $ + runOneInDataBase (show id) db (refresh db stack id s) $ + \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id + Clean r -> return $ BCStop id r + -- force here might contains async exceptions from previous runs + Running _step _s + | memberStack id stack -> throw $ StackException stack + | otherwise -> if rf == RunFirst + then return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id + else retry + Exception _ e _s -> throw e -- | isDirty -- only dirty when it's build time is older than the changed time of one of its dependencies diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index fae69da565..9f7b5bbf96 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -122,11 +122,13 @@ onKeyReverseDeps :: (KeySet -> KeySet) -> KeyDetails -> KeyDetails onKeyReverseDeps f it@KeyDetails{..} = it{keyReverseDeps = f keyReverseDeps} + +type DBQue = TaskQueue (Either Dynamic (IO ())) data Database = Database { databaseExtra :: Dynamic, databaseThreads :: TVar [Async ()], - databaseQueue :: TaskQueue (IO ()), + databaseQueue :: DBQue, databaseRules :: TheRules, databaseStep :: !(TVar Step), diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index fd6a5c7695..c3b592ecb0 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -8,19 +8,25 @@ see Note [Serializing runs in separate thread] -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.WorkerThread ( LogWorkerThread (..), DeliverStatus(..), withWorkerQueue, awaitRunInThread, - TaskQueue, + TaskQueue(..), writeTaskQueue, withWorkerQueueSimple, runInThreadStmInNewThreads, isEmptyTaskQueue, counTaskQueue, - awaitRunInThreadAtHead + submitWork, + eitherWorker, + Worker, + tryReadTaskQueue, + awaitRunInThreadAtHead, + withWorkerQueueSimpleRight ) where import Control.Concurrent.Async (Async, async, withAsync) @@ -34,6 +40,7 @@ import qualified Data.Text as T import Control.Concurrent import Control.Exception (catch) import Control.Monad (when) +import Data.Dynamic (Dynamic) import Prettyprinter data LogWorkerThread @@ -74,6 +81,9 @@ type Logger = LogWorkerThread -> IO () -- function on them. withWorkerQueueSimple :: Logger -> T.Text -> ContT () IO (TaskQueue (IO ())) withWorkerQueueSimple log title = withWorkerQueue log title id + +withWorkerQueueSimpleRight :: Logger -> T.Text -> ContT () IO (TaskQueue (Either Dynamic (IO ()))) +withWorkerQueueSimpleRight log title = withWorkerQueue log title $ eitherWorker (const $ return ()) id withWorkerQueue :: Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) withWorkerQueue log title workerAction = ContT $ \mainAction -> do tid <- myThreadId @@ -124,18 +134,33 @@ data DeliverStatus = DeliverStatus , deliverName :: String } deriving (Show) -runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (IO ()) -> TVar [Async ()] -> [(IO result, Either SomeException result -> IO ())] -> STM () +runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(IO result, Either SomeException result -> IO ())] -> STM () runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do -- Take an action from TQueue, run it and -- use barrier to wait for the result - writeTQueue q (uninterruptibleMask $ \restore -> do - curStep <- atomically getStep - -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) - when (curStep == deliverStep deliver) $ do - syncs <- mapM (\(act, handler) -> - async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))) acts - atomically $ modifyTVar' tthreads (syncs++) - ) + writeTQueue q $ Right $ do + uninterruptibleMask $ \restore -> do + do + curStep <- atomically getStep + -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) + when (curStep == deliverStep deliver) $ do + syncs <- mapM (\(act, handler) -> + async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))) acts + atomically $ modifyTVar' tthreads (syncs++) + +type Worker arg = arg -> IO () + +eitherWorker :: Worker a -> Worker b -> Worker (Either a b) +eitherWorker w1 w2 = \case + Left a -> w1 a + Right b -> w2 b + +-- submitWork without waiting for the result +submitWork :: TaskQueue arg -> arg -> IO () +submitWork (TaskQueue q) arg = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + atomically $ writeTQueue q arg awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result awaitRunInThread (TaskQueue q) act = do diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 826d542e21..3e9aa7018b 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -16,17 +16,17 @@ import Development.IDE.Graph.Internal.Database (build, incDatabase) import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule -import Development.IDE.WorkerThread (TaskQueue, - withWorkerQueueSimple) +import Development.IDE.WorkerThread import Example import qualified StmContainers.Map as STM import Test.Hspec -itInThread :: String -> (TaskQueue (IO ()) -> IO ()) -> SpecWith () + +itInThread :: String -> (DBQue -> IO ()) -> SpecWith () itInThread name ex = it name $ evalContT $ do - thread <- withWorkerQueueSimple (const $ return ()) "hls-graph test" + thread <- withWorkerQueueSimpleRight (const $ return ()) "hls-graph test" liftIO $ ex thread shakeRunDatabaseFromRight :: ShakeDatabase -> [Action a] -> IO [a] diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 427dd2ceea..8036e4d5a8 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -2,9 +2,8 @@ module DatabaseSpec where +import ActionSpec (itInThread) import Control.Exception (SomeException, throw) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Graph (newKey, shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) @@ -12,17 +11,11 @@ import Development.IDE.Graph.Internal.Action (apply1) import Development.IDE.Graph.Internal.Database (compute, incDatabase) import Development.IDE.Graph.Internal.Rules (addRule) import Development.IDE.Graph.Internal.Types -import Development.IDE.WorkerThread import Example import System.Time.Extra (timeout) import Test.Hspec -itInThread :: String -> (TaskQueue (IO ()) -> IO ()) -> SpecWith () -itInThread name ex = it name $ evalContT $ do - thread <- withWorkerQueueSimple (const $ return ()) "hls-graph test" - liftIO $ ex thread - exractException :: [Either SomeException ()] -> Maybe StackException exractException [] = Nothing exractException (Left e : _) | Just ne@StackException{} <- fromGraphException e = return ne From f9e10239a9749bf7682b49a876a3308d4947599c Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 8 Sep 2025 07:04:19 +0800 Subject: [PATCH 080/107] prefer restart than other actions in shakeControlQueu --- ghcide/src/Development/IDE/Core/Shake.hs | 56 ++--- .../src/Development/IDE/LSP/LanguageServer.hs | 4 +- hlint.eventlog | Bin 0 -> 111127 bytes hls-graph/src/Development/IDE/WorkerThread.hs | 13 +- scripts/eventlog-dump.fish | 117 ++++++++++ scripts/flaky-test-loop.sh | 200 ++++++++++++++++++ scripts/flaky-test-patterns.txt | 28 +++ 7 files changed, 384 insertions(+), 34 deletions(-) create mode 100644 hlint.eventlog create mode 100755 scripts/eventlog-dump.fish create mode 100755 scripts/flaky-test-loop.sh create mode 100644 scripts/flaky-test-patterns.txt diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 639ad28c91..1e559cedc0 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -27,7 +27,7 @@ module Development.IDE.Core.Shake( KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, ShakeRestartArgs(..), shakeRestart, - IdeRule, IdeResult, RestartQueue, + IdeRule, IdeResult, ShakeControlQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, @@ -78,7 +78,7 @@ module Development.IDE.Core.Shake( Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), - runWithSignal, runRestartTask, runRestartTaskDync, dynShakeRestart + runWithSignal, runRestartTask, runRestartTaskDyn, dynShakeRestart ) where import Control.Concurrent.Async @@ -289,16 +289,16 @@ data HieDbWriter -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) --- type RestartQueue = TaskQueue ShakeRestartArgs +-- type ShakeControlQueue = TaskQueue ShakeRestartArgs type ShakeQueue = DBQue -type RestartQueue = ShakeQueue +type ShakeControlQueue = ShakeQueue type LoaderQueue = TaskQueue (IO ()) data ThreadQueue = ThreadQueue { - tIndexQueue :: IndexQueue - , tRestartQueue :: RestartQueue - , tLoaderQueue :: LoaderQueue + tIndexQueue :: IndexQueue + , tShakeControlQueue :: ShakeControlQueue + , tLoaderQueue :: LoaderQueue } -- Note [Semantic Tokens Cache Location] @@ -369,7 +369,7 @@ data ShakeExtras = ShakeExtras -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run - , restartQueue :: RestartQueue + , shakeControlQueue :: ShakeControlQueue -- ^ Queue of restart actions to be run. , loaderQueue :: LoaderQueue -- ^ Queue of loader actions to be run. @@ -707,7 +707,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer withHieDb threadQueue opts argMonitoring rules rootDir = mdo -- see Note [Serializing runs in separate thread] let indexQueue = tIndexQueue threadQueue - restartQueue = tRestartQueue threadQueue + shakeControlQueue = tShakeControlQueue threadQueue loaderQueue = tLoaderQueue threadQueue ideNc <- initNameCache 'r' knownKeyNames @@ -720,7 +720,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets - let restartShakeSession = shakeRestart restartQueue + let restartShakeSession = shakeRestart shakeControlQueue persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -751,7 +751,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase - restartQueue + shakeControlQueue opts { shakeExtra = newShakeExtra shakeExtras } rules shakeSession <- newEmptyMVar @@ -855,13 +855,13 @@ delayedAction a = do data ShakeRestartArgs = ShakeRestartArgs - { sraVfs :: !VFSModified - , sraReason :: !String - , sraActions :: ![DelayedAction ()] - , sraBetweenSessions :: IO [Key] - , sraReStartQueue :: !RestartQueue - , sraCount :: !Int - , sraWaitMVars :: ![MVar ()] + { sraVfs :: !VFSModified + , sraReason :: !String + , sraActions :: ![DelayedAction ()] + , sraBetweenSessions :: IO [Key] + , sraShakeControlQueue :: !ShakeControlQueue + , sraCount :: !Int + , sraWaitMVars :: ![MVar ()] -- ^ Just for debugging, how many restarts have been requested so far } @@ -878,7 +878,7 @@ instance Semigroup ShakeRestartArgs where , sraReason = sraReason a ++ "; " ++ sraReason b , sraActions = sraActions a ++ sraActions b , sraBetweenSessions = (++) <$> sraBetweenSessions a <*> sraBetweenSessions b - , sraReStartQueue = sraReStartQueue a + , sraShakeControlQueue = sraShakeControlQueue a , sraCount = sraCount a + sraCount b , sraWaitMVars = sraWaitMVars a ++ sraWaitMVars b } @@ -886,10 +886,12 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: RestartQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart :: ShakeControlQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do waitMVar <- newEmptyMVar - void $ submitWork rts $ Left $ + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] -- Wait until the restart is done takeMVar waitMVar @@ -901,8 +903,8 @@ dynShakeRestart dy = case fromDynamic dy of -- runRestartTask :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -- runRestartTask recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = -runRestartTaskDync :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () -runRestartTaskDync recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) +runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () +runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do @@ -913,15 +915,15 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys -- Check if there is another restart request pending, if so, we run that one too - readAndGo sra sraReStartQueue - readAndGo sra sraReStartQueue = do - nextRestartArg <- atomically $ tryReadTaskQueue sraReStartQueue + readAndGo sra sraShakeControlQueue + readAndGo sra sraShakeControlQueue = do + nextRestartArg <- atomically $ tryReadTaskQueue sraShakeControlQueue case nextRestartArg of Nothing -> return sra Just (Left dy) -> do res <- prepareRestart $ dynShakeRestart dy return $ sra <> res - Just (Right _) -> readAndGo sra sraReStartQueue + Just (Right _) -> readAndGo sra sraShakeControlQueue withMVar' shakeSession ( \runner -> do diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9c90a1b463..f38fd1be8b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -357,8 +357,8 @@ runShakeThread :: Recorder (WithPriority Log) -> MVar IdeState -> ContT () IO DB runShakeThread recorder mide = withWorkerQueue (logWith (cmapWithPrio (LogSession . Session.LogSessionWorkerThread) recorder) Debug) - "ShakeRestartQueue" - (eitherWorker (runRestartTaskDync (cmapWithPrio LogShake recorder) mide) id) + "ShakeShakeControlQueue" + (eitherWorker (runRestartTaskDyn (cmapWithPrio LogShake recorder) mide) id) -- | runWithWorkerThreads -- create several threads to run the session, db and session loader -- see Note [Serializing runs in separate thread] diff --git a/hlint.eventlog b/hlint.eventlog new file mode 100644 index 0000000000000000000000000000000000000000..501382a6944a1484550984af97485477b893710d GIT binary patch literal 111127 zcmce934B!5_5YhJv#|vTkdOo(5MY3W3m`ET)5;Q8U5me$z zkZR*nJ6h3Lw^)mfxG*l*D2Qp@QrX5mxU|7)jjh)I+3vjiGPJ*+!|(IIO5Qo=eeb#7 zd(M6Ly?OKQn_xxlvS4NXGWg$sk^=t*%&V;|tFJWcgRreYYh`^U`~!f40N#abS08C_ zlHmn#zeV*mp(E{1rpklPCAVhn+SRMemQ`2U{HGXB&E7u;e z6%RT@5@ogZRjXH+r_Dn>)&pb+yHBlJT~!yXtmwPDAMGBtuyW1X%DQ^94!5i8tIDeT z0{atir~-z{YRjstE8}2;sLw+sqICdUd8E*!eg8eOII(DX%G$cBn$axrFjLJ#0-_6zg z9Kn+**aJ?-4zD)r>TCNB+9^gFR3CIc9FS%?9WwP*tL%d}k9_o(si?YaS*4v{KG7c> zH@Iz`n988Ifo%g75NOCLRdqNDv=M1T`PtQcni2mKXqthOj(KiPJxoWz%CZm~>#J&N zFEuM6Jtp+FrW__sdm5)xoq~C5YiTS|t-7kqDox+&wX2pvwVLHtO>@;U3|AdRKQ;#( zLoSBfTvS)V(NzCy%2;j;mMDOl8}BJdKxrJi*4#zq1i+WX@j|g82`!0Y~lfnp$(&+7;%wwrd66(RJ2xhw4%KEi1sP*K66*_G$SY&f@0rdywy--bUJpm}I zkWBGOI1eNs_>D2qz1MUp^@`pO7GLdBcbo3 zd`vkqec!SwocKe*s`9exNk^)FKT#WXE=(~vRbw3Oy{RuNUujE0E72PfYp~43`AJo_ zK_4LJ{ZCqLo?bHF#4KED+rN$W52bOrtZH=`Oa@1~e(1nTM%KxdD_~HR*Q_p==>RV! z%uukb&OST7OlRy&jNktZeuaFGi}Q`gcI@bdxuDN^br)AVQXBuR+HR_r9oJgjC6$$- zBXs3e!qZUDy7HgUduSTYIWGiLTO}NfFu%ea35O#PC`?_I*AM-!gJHkQu z2DWTW_|J8g(fG30gwGb0!3v0B8GL@gDH=XR?Cya-biH6CO>To8WRg883(wmIcY9{+PvaNuiO$ zmI)mOUHYC@JTL#asne!Uoo?3F*Ifvoh>TH;nA~REg;E8iB!6|~C3W?eR#z4*TU%9K zQBYP^TOK@iMt)6QL&1t*xp*jm<7{PRb#;Dq+3FQ*;SxU|F4y7Aoj-l*v}sfQQ~d?? zh_0%r%&&*f9(Cf(X3`a73YqW`okX%H~geq zn4y$tp|NMM2QSSlhOwc#3EX)N7daIK+4>9On)YJY*B{0_7Dgx=UQrvyHUH>dHK_1x04G*@HhS!tg!_hCf0pwwfaP)HpNYfGhXJej5 z2%`TPEu?8o9m+UmX1}D2&+*NB_rsq~V8t#bdy6QIJ(D1I}R|Hbh02 zjtE9bvmw@D6k|Rb{qYE~G1CF>xCz01LD_JyZ3ysA(ex3ZQA8aB-bEG?QO7{DG^VM( z>NdkMs3C(8I?q8HI%Bl}aeX)*AvWeYXiF#_@k^^^@Nq{GA@sZrdZYtvZpoX{Y&@Q5 zAq4k)a78g_xSv}cyt9Y)YNOUM_~kCJ$*6S<{!=Sy`dAqJX0wJE(!VGUp={jBkQ1?W zHLjV-&}oHW!yItTmCiMWZa|+y^drGB^!hZi3F4;Sc*M<7u=S_&vEdkcYX@j<@GmuP zZ==236VCilvSIv$#Usp0YCM5l`>=Q}LN-Bs*%XIJck4XU`^EE29~9Mmqz^@&_EyqI zAXha4(^rM#5to+gh@Tb3Bgm%mnBL|Fgl+b5q(2p*THKfP9j&D4M+)19L3B7?=`S=3 zM%RbMj-2#e0oWgF^WQ$w^zk_Cf^M)mB_|_hpg*TA&m$Jt5a+kYBQ9*xeUyjd5i5&y zL=EzA>NBrngxI+6O4FH+xUNz2k@1IO(sV?|OUQJzjJJ%pkQH8Ku+NNlkk@D<75=Ij zkZq$B;=Ll+!NYh)*EcBDj4Sx+s=9~=JUSSx^LYl3`O|4{$wJ16mvBf7aE@M@T&o+UkT9g*Z z7DGIb{Kx9o8IEkSsr=?l=>|lucw|j^;lp=?2+wKkFf#Bb_6feqK^G zL0lanJYOq`&liix7V{~()OZb9tDbO;QI~M5s)o|J#;7YI@iktJk}Xz4bgA*D4y^|F zZ1j(?M!L)+qt8af5IFj{#^}W@v{%o^=zB3^>b$Qs&X4$P4eN*(uxDkMNiH2_A#!Dfvcr8CPhKQ(Eu-o{vGhOLIuxyIPRomvg% zJ#I=G*i`(-P3Czj@!{l zntlW*o3!#paXdn7%qusi2oTma66@+JfpexX>KZ9`jE}r>8@VOuN!4JU$|i`PcWVe~ zmu%L!$Q50kadOvV%vDd7rpGt;xe`F|cM*mo_hpkbJ)XHeez2(=Db42NOU%0){)6He zKNNF3V z+pw1O(IS45hAlqj1Z&T1uuJ~AdYgu%w&0vV2p>zYW@=ZuMm+rfr0X5JIO!W!y)Ht`#* zG2V9V=j*`U4wlj7+l@IL3?8ts4_{{htCn0oRdGq{W8!kNZ&h947hWIJ=cepUmyRr>5yar;QdAp8K zkHL`;LlmROnQ}hk=;e!z+sqG?#_(!H=T{Vw%?*DI z$JCS{Y=%SZxd!VqZ8=jIsWAdsTK$^(LMM69BQf>0CbCJ5*F&}%1%uJUa9h?3a$3p8 zEDFZsxafnJ=GPI&fzlUI#7x-7Mc+gTL2-f60mX6AcO85O&9QQQ3*SL=tlWv`cij7P zvk*L@^zqs>v3>kesj`8@IJ=GRFgm&imtajOc>gq;B)SLZ=+2=ikmZ!Wwi@)!pQAgk z6*33K(d}=heaticU^{Cx0^x3N52}1-_ugXCK85KIgTady@^%bM;tiEiU;2&deXWit zST2aOJ_IDjvh|E^+$L0b40e~}sFNclY2wBpY1;7^vr(p!YChrIYne)_`J#a{l@xlo zmot?V`mBL7kW^RY=d6%KSxH)dQm@!hI+Bg@k+i<7FxIz?KkDXuB&`p1aXv_j0gQ1E zK#-v%&1$0Us5IPgKFkh|l)@x$_HjOv)>rp%#BOp0tafIWVobq-n$2B=MN8**7HC$qtTyaM+$1u6#-4>23Nfg&U zHaY^5D>I6z9q!FUk}2ZJm1c(QF^rd6gBi!wt+kleXy~~uW9O~?ntf0hM z`8KUxY$$Q;zn#~JHL*DQr*ul}zdfTwVvmwl@|s~VLP>hHnYMYflVhKEottffL4{_Y zWb{GvO!Bu23JC*$v?yy<$ESW3a@ zHnE(X*+4>GCvGH$O~}#0piD6&9~8rsI}6*hv8^v7tm!PM!Wqm+FY4d7Gc3oI3rV4IE{X6aXT46CN>eNK}U5FQ0X-D3d9ML5-rE zI{hEbJW_RUNky=qqHMEff^{tXGg6O9!agTfD9WkFWMWPw%BlCg(oLE+Qd95S(qHGun)BkT#j<|Es z^(6+)%Q0_=`!(>S(XLyQBCv<@V6*0$k_YFY+i`RzR;UloLCzz5Si28+5eW=fh3N(Wt#(Y9!GZ0n1G_0G~`$r%g#BI{1RD|ta4In zCn>4Rduh8Qf*X!((f2{JDGVw!mdP8(a85qw|hK zh9@*)PDo3u;*sJ!;i@iWgAa!%{UJ?h=5j%tv>kh@e4PAogft#!be-Zn`O{WD9-Q-D z3i9#bocDQy+yBH0+h~QC{3hnx2R9GutH(75z=gL&e!m67$RV%X1`7 zlsFG|8y^qrQgB32NxJ#F63N55{_+{fiIP>!+7?n$f7wmjQ+ja2c`&Q7pN63@D03dr z2j@ZarsYAmh9EFwv8r=jdTfNC{(}nVVI2`tF*4OI2iZB-zttmo*x+fGnBO(gl;Z&<&cj_(+{y+L=i#oi{pbTr((B<; z$-`ZX@h$=sCrVZ^*R+z7dRLUTlZtR7d01IUHibcj^MF1$4|n~zn=tT4%Y$ycKBDq) z*V0af{lQz#!(D4ip{B~i-G0m~X@MmY<-2DDlnwg2)t5n<9_6hC-4f-kcl#yETRVy* zqC2v~5>b>m%61z^dB?0?@JuCn=*}*Q@{ZY2i84x7F|Xh#rS9QvP6+o&lrP0zz-Si? z${c0%!BN({X;Id#zid`f-f?0Fx=5&Sly@vDf!Zp{JDx^=q=n9xC~G!|@(VAz6{7K6 zLA>zC9%Tc>&R;}H)AO*iMefr$cYYC;JiO#hlbF9*szx?SoCmv&^YCU}06bGkK6ho4 ztGG>Hu!&%!h$A^lcFe}gO;;fMmx+;x% zLtO6^Ii_@LGDd}RsaunpApCR&ah-5d3sz33P#;_;{GT; zB(Y!iqconmTqs$^tcjA6(%Fq$NB=h5$PrV;o)iZ6&=KQWcB)+a>)x~|Yi%U`qFF_G z**Q^kkx=0%FRKhfZ56``x(i5Jq*$U{QE6(3V0A!go%00|3>7OIjQT30lQcaKRVi}4 z&V${?dARKDLhwu_W!UR&l84LQ>ybR5WEC^$XXu{; zxOFfe$wOHLZHB_2%y~c`G;_H$Z(1HSYf`vK<>9hVBIqKa!g;tn3E8SV{Cpk95N59E z$r9zCH|nGP%8U-e>rqAbW4@`R+`7s859a}Wa2_;oS{^iO(jOtSJhwmcaVfe;sBjD)`8SVV7~c?w-?>fLV9Xt9 z$4Qib*WWERMEw4XLelgoqm4)Vw(>@a^0uF=D8Kk*u|ydqjRRXUW|?8!sVkzK2a+fc zeQcBmcj^@-;F(J5`B%t2I(Olfnk5hJ)a$t|^z%at#mSv|dn;6wJh+|5BWId*O7c0%Zs%Oi4b4k#@8qyT z1SSi@JGDvk(eI5QX<8oK{kr5{sk{Goa;@VYkS?DD+}Rm&eMu7M!EWO`WFNy31^1~f zaOdM#5Da(r?6BkkC99Zg0;Hs#ok80>NtNT_q8_p-3@V%l^uc-1ylHvRttnBJhwKwE z0*MvQL-wLHsIKxb>Ney|c?jW?Pf*;J4Yje;dkLXOdF-)K9_{XNo=%?q-Q#A+b&Y%0 zRp=4xqQp_Q+c?Uzep7@fEU8_mmq?UnJt$Z9Zj`KI)(1#Qt%%Z=Zt|+pzDlAj7zA*X z(FaFa^QJ{vx0)p?%CmmQZBRo$@DImu*7J=}Per*frCT&dW3EKG(A}va=FE00MDrLy z%$bY5QamTo>eKaMnBpe~>F9 zk`O>V9S>X;LB(*N?#7Md{V;AgYrj0Z6cvSW{OEegny27#A3p^V^M<$=;b}X{rEX0v zfn67%AKjXKzA3r%6g=O7dlM?u2T#EP6KYE?J<|>cNYg&0d8U0;tRaqhqEWOY6IUxh z@mMz0X5HFG2rZYMS+~m_X;0x4`R3SDxF#eyI;W>Y@`e)U?VK;$lno@#&cboc*d7+w z9rHUSI}1;i^R#E-sqMU%{+cTTv~_)rd<@55NR?x%qKEb=3@UU?dC(i@LGz~NL9-^8 zfk!%~JPWI$=pv!QF3JxH=UN$`R0N#^+3=LkkHSXz z_;FVuX?h-hywBug%CqD*r98KJmb@i%nh#SWx^f?LP$0=SVVuMVPOC=ALRW%R*O*1Ty^ z)~v}*0TtzI?`c672^Eg=wcFiLTgC9YiO3JNqznHkQNC_UiH5lGvm%A4`C1T`4R(1p zJ={PDJrA263rHTCf2>A(^DpIIspsCSgOUf7I1hFk=i%Om&@&bHPaf};(SGmmizN>z zS;eg7Si6sHLZjop5N;$7D|=Cadqa#tne%`?I1idPEf1PC`47u$k7!9(d?``3Y_QAo+oy^YV$)$k{C0;=Y=k&~eY2g(J--DToyk29{z^Wj zc^-`PO3a@;tY&|dI1hFk=V8025Ij?H|Eg5J8Src$AXii*DFDP+?peE+P%Q^7T~~Sd zPxq|J2j^k?V7GFn8XjWC{f4${AZ1*)l4V8yy?#JqMJpB5v5@pKc(XY}^6=*4MH2JF zu2Nutby4Cx*lnDL!}DWt_Kcd?Ewj$y^W+I=4@y=sSA|J&*ST@)sKeo*^02~>ilHzl za~{wK=RxzPzbgV%EMQ1W|YzX+J_S5uNu-cMDH=h zr0G%ao#mG(_kN^C`!~))j;Pn`h;o!kq9}X4sWQ)yL{av73!A|+70*x4@N<;C-eS3u zAxQxsf){s^;=T^~7>?3L+{kFB?^rDi?x84?4~nwx&5E*aO@6OPqU`mSpohc?#mVbk z5rXOxWpDpH>?zGD2jAl;d;9xw3@Jp~vNnbI+d)BCHrVAId{QYPv^;nR&oAOUc!#9R zeShx|cv^&Go_Doe>v&N*l8y6__j_!cis!C>q)8s~o^Iq>$BU9x%m$Mb_ua_HaGXh% zB@b)Zlfoc?^MF1$51KbE51KXkuW2d|c`ufri-Zd2A@5)-)K*dUuj&*n>HB>WWxxJJ zk9Wq&aiiTk<5U^#-Wh+EGpKjQ7ikjFVzUtZL-7{p%C$U6mW`ua3?p2M=irDEiE{BG zL!yk5Rm@8wq_`gl;nq>qgBum)5>yO@L7AhBJ~+ynH!aG=i@OnwCHb3973Jb3ASPHi z%Eha3ET|}-z9}eL@}R#+luzG+oE74%OJa!8Zwcb8%XP%r4&k!tdMWt zy$fzHmOKO(%jYLAN<7-_HqJxvX90AL#XEXuqvRoYwVHKMvWmHZHTUmZ(C8T7h#Sen zx(F(U!l2A~Kp&h3&6}17&6+Z-NaZ1TZ3enXsBj*FcZQ+1it@?_qM{`iye?5*`EZAZ z2sLots5Y-l^oAOJ66G~{a_7gpW=Xe1bmL{c;2(+?C62P)#!=pQdm*B*crSdfRHD4` z9=D8kl&oTI#PI-EG93-Laf}S$MxxxSgBFRWT5#Ld0x1n~!{W!|dWAcJm1#!cJ z8Dc}kO+k#1{dhnd9}k(u&+@!c)r;TGEZPdKfLYl&$!kI!Jd^~90v`lH%l)Q+_)Yh9Z0*Mul^47cC zp}NXct5@YM`NCHu%B>@tG{l4LC8SYpIUdl)QGRGTvSv*= ztw=@rsiXk9NT_g>pBkp(3QoLFm2wPWEZ6)|qWsiP3SpPZ!;TBF2Q=ERcu^2Le%=W- zdC!J-$JQulgJB;ZL9E-}vmqGtk^)%6yW@clsv~#oygRlvf-di(@J6!INYjtf$f#Z& zab7EFPWTH`5dQH#e>&QRqKw*E$oqKV^!#}N(1z-7zVfoojyRs)&;WBAputC32Gw%d z^y8sD?uFW~dhvWER*QKIc9X^`};1fh9JboV`7iLi4Z#PJ!eG0Chsir?zy0mG&(9J-mlS}TfBG9K9$ZsU#rGg z*xqvF-FqgOV)0d)-s;{(7$14tjd$+@5zw#&_PMVQ#*g4|+Gq88~78&-iKbvDL9z@fRkUogjQEEf) z`~Ij8Yl@@w&4h8-Up_0 zG`Nieo3K~**eIJIUg43#KBZlH2lj-(3-(Of_;V?F6%V56JwIq7Q+X$*_ux-^ zNwXoAcj$=P#(2bKB|7378sVJ-!G3RS32sg%FKL zANM^vIRg+@U!zk&jn#-w>n2V28Qp*^P8Ofhja{VKe3DJ`i3`fC8k<^4v-x}zBQ{U@ z{7aNHn@_T7KKFO%HQsF_jeT;@-b;#rEe&$WSyZ~d7hB-yslDuB2-po{MI*)r|ABmc zCm_WRvN1D&X7BrJyTCpcWn;xrJTpaC6~<*b?R-^XXm5~SET1Wj%R!Rsv4a+w7_YIYDos2797E}OWc8jmrRljF z`Wd#P5a}nklBOflPi@u__m;#XS_^f=N9@t&y_7mu#`?Sx0sw+G927ygf!f zIdTN~4ZrHWe@fHynEh-M_)v%(cZ4*(_c__cU{iU_@qwZpEBroRl}B!sZ7QNl(_7`Y z{>Bg|a?G`BHb)NGkeB$JhdEGhnao*@v5H-HJNWIp_TwPu+E!r-8%NHs{G{1fYz33$ z^J!#Z`5fhKro9{s9-(X-92=pdh6DhkVl!$iC|Yb-SFsTfYzV|7#3qO* z*rU#COiD4;a>HN4F{Xb8Y%u3sgLQj!6h_SeW74pyngPa~+(DYoQ`yAlnpQ&SEOLF= zJ2lpnW<%sf3Bf#b7xjQ-$Mou(ZNP)YKPLHq_Ua+H(@U)gJn#sh(GxxqmIJF!$$m91C}KfH%O zzR1V_F0?{)Rkb zHAK^g`_%Ulp(YHa>8&ao=f7YeZmnsmU}gr@*J~6U2PW_-H3HazR^tiY%e=Yo1y6Q^ zQAMZVnNHI5OQ3@1IAR=~f}WOmgxDD2AKgF*=0!KA94qr$`NouE`p15R;_P_#$SKwB~1g+#5-2?w2p3Nupb1 zwigP=m?W)#se_r2ln4u~LrjuWHkUG!`~Hn0$LnlQ2Ok(Lymv+0fX+Oj53b z)kMT3<*ITY$AlzeqQAV=Vv=%aO^}(8bW}`Iv&w_aBsHtMkeQ@r^|+Y{NyJ2d!KuY0 z^_ZD*E0v_9V{-otdGtK>fo!-Lh|W?UzdtJM-r4IG+dBt(#I`pY5!>GGX0h!X6c!sw zler zz~OFH_p45^9n5VL+d;pI!9kdrnDfB}tqON@nzG%ZI3L`mM#jM>O@;e=yTW}R5?geF zigR?bY9m@{2rdd=#4^9=x{$Kn(WY#Vo67bFx7glY?-Sd**Q6=i(~9%EoyB5%?=LoP?^9gfzp+KxZV4(}B%o|B zDlQ)+b%^bQYL&|m?ofS0iQD+#RmJ%OwGcSVEu1i{QF5TgBErra{@x3@IB(?612<#Q-I- zZBTvdzNt&u?onL2K@!|H#ibi0v3*-8Z5%RGTn-(t`g>@u;{3_Oor3%1v39BZ$xao6 zPm?2J`*d!p;85Z=K3&(PY#@oPsae@T65HcV$_5ghubl(0Zs9Y6{<2|f_Hzz8B(on$ zc({Z5*8*X(LC(bUe2pAne&J|n&Lz$(ZWpTO(+s3r_65Q zm^e>4u~C?y#7vf+7l<_!J4-s3!f`wn?IgtjKTu#M<(IbzlZvXSFsWE0%L1GzF%#_t zty)ah!8HamK`GI~OxBml7;|nYE)*sk&NL+^C@~Z56{Q-JyZ+EBOi)U+Fq5sTgA$Yb z2FfUQqQoN>C1#?%##3XmqoYxnppMjz-()84 z0YB|wCL~cz+}aDFG$z^YVUCF#r9=zG#65Pg$uV({D{K=c_&;1XfI9Dm=vB? zB1}+9v@nyoEsetD#9@uX5rO0+PO^DdEb;$A$ZRhTS3 zMnWXoWcoh?tw`PseYnSd}siJ54xSJ9Z(GM{*SpLH-3&(usg@93}9u$XxKr?qf)NIEJe zo>|{YOgx1Txj81D!aquONTQf{7S76uH55AodKUgZLztkHXrY*RmJICX?0A-ZC+A|% z1#knG=2()LNoY+V){wK^e$23}FH75B>o$W`- zWJYC3n9Qv06(%z;mJ#bkiJ54NJ2fW7pUTyv7o|iCWyiZ9M@Fo7L9|7fEa(nOOi*Gb z+VVz?N$|ZM$qq`17G@IKqnNDuxJj6-`CF+lL5Z1YO8_+{8^4s9&5Kf^g_+#6zeTdM z>B?4Nvgz6eVS*Af(U!PrOz!LFmzbcGXkjJ~e$g#V9_p3P#omXFkT5}snQZ?e5^E@S z-tj(lg?uh1DF*m~0)02=-SJ!@)RPCUy*qZAq-oy`#%xLG-~0UMc#No@M5Jq1u?>Z9 zXxZlr8Et@(?;E`@n2n^d&lHdiv7r~Kk%uhgJ7n(*Gth7BJ7m$-_qpOhF!Gp}_k|N9 zocUK2#I^xyIof_iR>ESrU9!~?= zI5K+%1VBrNeu_RAc@2So%wkV@3CKhB@6)||E{l*&5YI6uoyDHcHXZRsOPr5)7J>=< za;xtwZ3oS2^_`DGaW(d)>OS`lXe5O89lLk$;2_xKF)#1l1>L0Sy!Kw$q$A3)m5H{# z?XB_Yh`O|R#Lqj(whjIo-o4kf@N)_3sW0gf+Bs7krM=fRf<94yaMjDUp%4Wq-o1CZ zjY)OEwe_cz)t45XHa{Eku(xTlxE-l=j&I-(3W@7@`M* zHd}w1-@6aKQsr=P3;V8W6dg9+eK(Ylru$^uY+=0b7pCAjoUG5bg>zpE_D&rf`yLOF zhJ#A=d*3I>3=zU2ri0nL@AF>Tt4}S;CaoTh5<=&>zX(jQ28|=jS{_)q#{LCi+6!0g zP`K3t^V>m|M=rbvP7jl&57Pr@HR%Y^^b8(2Cj9QgO6e57~=0i(zq37a*%A;3TH&=viIu}sA2Iu z_`M1G3AR{7Pig|2>Pd7y_9R*Q&LeKcRbVoZKd-w=mSYsxU>WnGX!gF}8irb9QU1SJ zcU2SNQ#P%!qT6xCqcZ z=!0c0BCuoN8JJ&T;~028)avMW_T1@`*o+z6je$h(^oyE{Eo4}SW@k$@s5!0$A z8tEh2Vm8B(Ue-;T?jyYgd1Om&(!)W1TAB~rBR?&jes75}86SXDAoPdv;HRbQ@B!;Z z{CxH4tE=jj>ozw(ysT>RQEeFd!^`Q9_ZS(vYYHB?#)p?>oTTq)1p~fKnIpq`w(SYt z^w<4>k@c{S^tUrev-Nu~m|}=wlgv28uza_U@b|jgV&SUTN(acRP!-{F30SM5uO$uL6>NK5Oj&A`ZD6; z-Z&m3=t3!mxG5NqxVc1cWouVF;(>^cco`IkpPso9ySsHnXJ_3VpuQ`1tz~;vqIhWF)u5F;zA}xEkXT{Wyw(7{u|@Fq z_aQbxOl^)wOm85YAVjmZa%@0HoSYHw<5V!k#(IWmHXo5JF|LD$KB5Y2^pD|DUQ z2O&1`L08Fr5O?(GKJGt4_QfVX9y~(!#U==P+e4pL9uMfP>^MU9#U?&p0C=C{HbZQJ zc!|e?ZG61askic8QM?bai4Xb=(1)qm1VNt*`XK0&fSRQ;9gT6VWTpnm#y&DVCGiNc z31R@}k;?Yd1gNdJNq07yv|j{JbQaM9zm;KV~FQDzIwc} zUn-?q(#k7Eq;X%FS58V7*%U9ObB!EYuZpa(NR2amAmiFO?n%z#DCmks&axKLbQZkM zHHNs@j7MC_ETq*No8u9;6_ZU6|7N`23a?^St&AGZcpG98W-^AzZ;xwb)U+_z)V1=c zlZr^=%yVx?o!bGnn2(L|Oh;`B=!jqXNwe_~8~0_@9U1Y6UxUeN<(_WR^t_Eu!~WsS z!Mv2tK1ZL8EVJc`$PKdL7`>zsHr5DKy41KdLVIj=^Q3*vfzJP)x6k0T+rKqV_4qS;yzn;U@+^VV+I#O^aW z%vX;PpTCq4Mq2$6dul(snBO*Nh%rVW4l%}!y-`OluhF*q7?TD73sKb-?_+JVj<}TD z)cZE(N{n%=m8-c;8{$R)SP0SdBVtT5MkHNE>6l-1f@Y1nh>1QOA)3x>+?oI()GVcRY4u*N&u14t*2lG` zQ4KfzH5{y2ea}se?@8`pjE9PN?y&ftC>yt$n^Q!1JtxX0h%wAd&q?leVW=hVKXc^X zim_4eKVz=B&jiV@>Z{Vl=Ns{(DOYTQpq2FYEai$#5Yc98!N&Xp9)p7TtXMd}M$Qbm zViT4ga~vBz^Ap4-h!=a}eROo`K19=x z&k29)CWPvV(%I)kc;h_s(lgICEAt9tuc7mtI5bUTF>!b=X*R^jsE!!Lv9ck?w&{qu z@zI!gR;!LUr(t2T2AoB=oh{eL6W_{^VkPATLQSZy>0A01{%WWi0Z_($+o?9&{9gNuGf(F>A z_XYSC1wiZ5BH8>_ix>C_!*SyG7&xI07U6V_Pe2n)M>ch=Djkf_nMp%BU=w@q!EolRXJZoC5Wzj4G_nP1 zsBG|?7VP<-G{2b;u@+Cq_;bIY#rhCv(8dosa5g4gA0>^y z$6`*CPsA3dh|kIMu)Qg^`G;*dC-E4Yd|H4oYK*b2j?l@MVa)6^E57joZOmfw)zNsw zwHV77LNq;}lW%O(5u)ic>y+cLC)O32(z(?sKWUF^bxI(t`Ba+T>XeEm9T5!0`w*M7 zQjIxLXE!&KmTwB#RFJTXa~0dPmplkY9s7Ak2YKZ-^4u*k zO?@-QFLhAwg3LPx`)+&i$iX(8g?KzFjC#9K-s}L>QAb(crBTxK<2tW3LN=8VrGpWO z=DnB!n`0ync}N(%>BlwO5W&Y#-fNwNkzVa>BF)y~KceDAYKRU-Xfb~vj*uDBV*Zdq z(CjU;4R4Zh{rr(`!f=cE#oeUoE#}un$)@_4e+hPk#}Kr*p%JuWRf`*gf`yGlHJ@z9 zf-Ws?F+o;Q&A+{eG+T?$gNb-c4bjmGEq>Mun^~&GFPV)V)qJweip^d5y=_oKwK%mu zM}_AuH~B0W-#`e}$AU=#twuo+XT?^dhJD6r)V1g}t|%dmYj{9594iY0@JW!Qj&Asb zh*Hx#@?f;%<8|_Ir|kt7SzF!e1s4xD^AiA$Zjcf!#3U&+$;V8z7hGKVm^?n1gc3cA zV0*zuj7ie^N98e7l8%Z=a!ObhpJ*?*$eZBfry`Ooek+e7C+jb`h%rg7yiy*FCh6#y zbWiW#m?R%s)Wz9J{?}o7xRWG`iR}d!7L#vp3vqUmQA)H>c2YK6)yPazuG-qnOj7Q6 zU1CBKF|obiBE}@;&RZLp2}wuABsHtXWG1OuACxeY)af^7aCS%{Cbkz`#F(TWGe;g4 zC+X;z+`mFbZ0ZBG@;I_{;FJh6A&HpS7MsVIIMdQhjtNOe#l)F$mSo47dA`Xpab{kF zXBH?VF%x~Uxy5A8t3|>Dr9=yj6X(2OD`&@f${B^iKY`s#& zWas;ajFXo#+l0wWIVw9ZjcF7nZ`K834OvXye7IL)f>NS|ne1I17AE_CBO}%|``IYR zgd~cIZDDzgiR*+XI+zJbN5#Z7zpjXxxaNQ9!=Fp_FK$ zn7FFO$r;df(Qw7&qMTld$wgxnlgsv+v4$)rmtWzRn4pwsVJ273mJ#b(51$q3`oy*V zoMK^u631loIY(l0v(YU~P)f8gla^Jo490caDaFF%wln3t<3fp<=nKoOm^?blElf~K zv@nxxIer-@+uo3w&9!Zx96Ka26MbR1#boDv6%&*aEzIPVx7&otu6sHqCc7SKlI)@MdWnsxW^UCwLMA9L|<5L zF)93MM3|tIXkjLEE8B(1iJ3uRa^jdmi3v)~L|<5LF*)lU#RR293o|)yONlU9e38s- z?!{|lW+RE2=nKm&CM&;dk(i*AXkjL`;Z9*v_gqwBQulJ3!~`W~qAx7BnA|vC&c$w& z5-rSRi${)P_ZE0P29J|1_qc@#O3XxGSZ*=7=jZJb6O|XwuR*}CLaH+US>kl zQ8Dq%dQPq$J%xA5u|rGD>FSXriivGuxy58*Sgr~@C?#4bCY~kmCR@5!;92r{GiS%M zurNj_3biVR=WfFlm5$i8Nw84ci-p2};aFUs!H2xo$*&~Pl_)DWOiCozrOd>b>B_=2_6MbR1#bnPFjlu+_L<`5{ z&FUUu^498zFnR0ZW?_O7Gtn28TTBlBQs!9C;X96Yob)d936pPf)QJ5C?&tAQj1n=i zEi8{Q@p`Y3s{)daDkk2+zmcQZJLDEW$HY72R|Yd7iJ9mN%Pl5(|CXcJi&CP6vg4i6 zAfGb4GlvxllbM;OFhPl#=nKm&CdIomc$|1qO0+N&ZDIM7O~Pcs&LUxg5;M^kmRn4M z@F{3467ZswXkjLyXJxkct~n^@9q*b?L&5|lW}+`Fx0q~7lSNL5Z2@3(GAg_rZL_F+nNO!b~3gr(8XH|Mv^aEhbO>rBIlllxT5dMej2u z=mA#{(RTpeXG+m7_wc>X+*L{%-}M*7Jw-a=vj)=mdkR5(o1r0|Jr=L}ZQm$+pFO@s zN1PmtM~E#6_88u0e^eNc5St**HscWsxi7E-eN^Jr!g2h4hWFW30npSlE6kg1F~pi; z!n@$Fiq4L%R*(maj~)Ba<6!WDg?;Sk###yyNe+{y$4}Xio8gVD!3};Z!~J+JuMuRs z&*yIGB^%dx?rx0dNch%8^oN6>YaTxBj`#3=h-}=(^R6P&=!`17pReu&n_7zge0>-+ z%jfgkduXrT)8}7lCY$)&(?FW`{gU?uPa4_eyPKHKHD2hCy&9@NSLA(R7Pg~abMVTX zPSQAf+}l@*+QAn4F44>SaP=LO_m$!%+RtsgQqw{j_f$OG908m48iZFwm%X>P!d|QA zuY4IKwBGYwLlL85wJQsIj?dq*hh3uspj#exE#@fLJX9esT)7OzyK7Y=X?pB-HFFy( zcDsJjOc<#ln)YqFch`<4Ld0r_F05Yj!Cs3M|2`~60SjZ;X2o`QY8UK7mOQq14`>Bl z%?-Qrx=GVxyZiho*%Sw*GwazeqUo{Py)8@#;rOKq8ggWx{Clyu z<{JxR*oLojpzoW#duD`aUy4nStxWLp@5{To z*^dpd|G@}@f~T%T{DU9zulz{V_MMyo4r4!};oWz7H@BCDjX_DYy|X&GJ>^HWcMgs; z9L*fzedmQi_vufvd-taX!Im#I_765evyPelxtNoD+l;k;Q4?X<=l=Cr-}YRGcmK_9 z9dS!fJVI>ZAN#IGW{57G3afB)UcZ4Uh7@wWeg29RStd90Y~s~4Q?e-dM#2mho^ z((~=HAe%fp;@!VHOdj;{xWBWBY~n*S8{*?$9r0;2-pAiMbcAT!Gwun$qe0CO{Kf_Q z@ov3^fsc2Ek>{Pf2d*mA+BonVjEp@;2Oi}3a8C|Aj?w9Zpf@|HXdKwy9gldnQ*T8y zJx2%L@c{x?w@c4NcY_t)Pw`bFY}AvapnnqtT|PvMHdpe+`_zhl>GgLdR6q9H$E0iT zcS!4k{mR3^j8@Y4>V_Gx4fDtR__vVN_0U0IG3+_cHbxHq3S)VqusV2mfHa#=vS~ga z@ar`m#z>ziKAA<-iARVPC8dKAq7?OFFHVvcSyORf)<;5|WMj>UxpI_8hhQXP?;P;5 zKG$ADFg!k@!<(fBY$R67CWugw5c;)av=RHK&N9*KBc$jG12$IQSht_s6h<8_@BXxnJV+Z~qbF5^dA=()M!Yw^n-I)` zPa^bw4+C?{@BK)Dajj%yW*v&&_xA?jj5(I=zl+i~kw18vFpSGK`uVe+ars2KYh_%1 zOd5Z-GcG^2mp|M6r}uuW^9hp;ASGHbQij1E2B~X>m`>3$n*JFC%pkd5p?Jn@jJWp9 z5FxazItIMd2)2gD|&Bl%N3k3YwNL#==qp%C8`lctR>#{jWWD~^GAI8H{ul@u1@ z;TU)^*K(6-;LkCC_}jx$V?CNj=*NX)NI?*6@@Xfg={|?dD%275b`IO88^@64*iOs` zy`7^Eq9sZQ<~4MDBWU<`6VZ>uZ5I4voRsMmIKF7v5AjY z8{!dSV?_GsMndR)<#%NalUC9{Y6k>s>RHM3Pr@;q;TSf_Bu)1*jNW}QO!_u#PAed= zZ&Vz^PC;HdHf@x&H>@}S_F?+Satynm8*GD=w-sT~@XaaQhhe1K>8NQKReFPhB4c`}tTHaf%=IsS(5PnKxYS^wr9GQj4D~33uoisfXnPkJy zqujI11!2OdqdfEc5a=o&{OiucY`ilc4iJJPn@QJ>7)jy14H*p6uYw&TPv{1lT%*M_ zeO!;6k4$5TLmi}P=SRm#y53P^H7nI5gc_?^9%Q33z&*?A-$NMnRBskt)2N(fo$u3X za8{L#dy;hx`(&Od!!Iw_m%s+2$2F8Ld)Jw;*Lvof*N)qxm;IM0d4NCY??W5|<75nE z)A?Jg{}ql2`!SpSjY&0_WA=C0@;KY^!Zww`oPtjBp+`Gsb`#l{we<_j?2}il4}*SS z5zI2=Y4tm2c_ZmkLp1HW+%ak-jstZ}j=H{qG@S*n+KwUa>5fPIwq5t}NH`wxL`X+G zTNICYDNRSb+#8ShQ-_Xtvn?L6zfniL8;nOBD%25&F>3ZXYSfoKI^x?%9Ab1zGuf~% zthjb##Be?kJ*^mYyqm%?AD!+8S)IoObFc(#R+dJK4quO<$G`Uc?_ZucO*Qk62)Wb; zgPGY)Hgymv9gNV7nbQfI2~wXmHH7)VR0sfbjWL*JHDJy0VbW|Z7Gc_~j`5FD$7-As zrM>#_Gs&h7EVH;n>T~c|A7`6f6-E%xu}^&p8Z!cWrY0$+=|g%<7WPE_sw4j-we70?=0b$y!$2&JKN;X0GJK_jxdy;#8myWowH6F2|K}W0% z#3SnbI^vRyc*Ocn9dS*2JmRJ%vcVt7LGIRG*i4kz8sWbyKAH9?P`TS6Z7BZ6&e?2V@-$@Yu4@jt@$)k$~!c@ffh zd~++x#u?(p!sPN6v(sePomRx2Az+ zMQ6h9NPLa12C~5)i0_1b0oeFtmSfExO@#n3*N7Iwb{NW7pR`Gmoe3ZK!Kk(W8G@8Q zssFcbuuW1e{=JhlJsT6qrm``S7W~>r^2Dh@^2@zuZ4!(TjuZc!w*AtLZK~CY#}>vo zs1GgtgWEAg6##&x9&7%=?HFQR6Cw23+GnjY%_ms0}>>lkP|6(9yCeQ z$Ij#hI09qKMi*s}#yMi1Q%0c=ydlrLlrDS6ny@z?{xORw6VN`z_A!7LD5~?P(sZ7@ zAW@w^t%ZT?GjFvIeA>^Sd9`U|69g>|wB7!7s0D*^Th)M1Dy- zX?nESrsA1@ZWs{LZC4ZdKM8?NWi7v=h%`NG%Erv|A8Ck3h)ocm^%6pl*HohsY-$mn z(sZU%cZI1IXKCu|$SU?#l!J9O9(e>Sj2eGa-!3H&%%Wge7ioG=3Nj-)qO^!K=IH?$ z7TwK}$JZPyJG%MCl;h*$Y4vOOhmFl3bZ< zwG(5KT)8>GF(Ju9{4j}PlH5JFkz+BoPzaqPtj3QtrGi!c0gyDkiB}b4r;>YSw2a zGfB<*T9}YTOl*tpVoXwx$!upPBpn@-`!5IylL!2goz$IQ2gJ6wOU6zrN_2IRy3f@q zjJ02op4_W!APEj0fT0+t?gL3|SHEkIHN?_3JaBOeMs4^DOI+I6_iM6 z#{0i2RJglMg?nAK@jggg_k$8;`{14)Wjmz&eek*R_u*(2zYixy1oz>xQfcGE)oEh; zAAVK(?IOW_3}3wPcpHA)+8%kXF(<;UJ(^ZP| zr*|rTpN8=ox%jAL<=*~7WKki7iO|yMw`S0C60-{sMlh0S6CiOb)uALVJ6xyNRN^u z#d+V@3}J#2Gtn3IT1<94EMMk2QA)Hhlb!8u8L=Aa65POjPC$f6P3Lf;rW*9k8LnH@<-#m+Uq zuvM7Me_1l-n*XX|f)d5a{tMFT$aXEep+T7ZAN+!JL7OnC`bRg%$yN35cFq_{%tT-4 zYsKXMbfNEp24S-Ptbj1V-;$=W<3fpa(_c}tVT1f@g^jU87@lbp$1x0N>u zliOB=gb7N_L|^D@F?n>FEVy!^lxSfl+x+bklWqU%5+>WemotD1C1#>8^tG7moGzb< zTqq@4n8_=DldAyNu9s!DbM1PyLt?V)PcqxN^o70_lSADy@48S*v@nyy^THAnZK3ar zaxQWm28m)~Tj(2O;&x8)^Ee^tsF=9>_sd`=?g1CbZ1+F^g0wn{-Ps*Q!UUy63&q4e zHe4!9#$6cUapE3V-pbh_iDRNK^tEDASX(SiP)f8glew45)tLK4nB(ZI=ss~yvoJx4 zndl3BEhcB(nt4J#EKC+Jk#XWiiJ9mNeJv){89l-Tr9=xeseRff z+48{WXI?78Nd?>w@XYStupU=P+}(f z;$Mr&o=v7OK`GI~Ox|pet8C9(*U2Y&&s#ScGEPupCi>!Ei^<{p8-)oL{{N=#7V?4U$UY>R(mOuXKQBg}-PqhjJ6{6rJaC*C1HZDc0iA)jOL&)ndxs9CNpO=2osc;iN5&PVxlenP5gpVerfyc*VBZ_0$5N* z*DT%z+rq+R!ILs#z53!`i%IbH63Grqi58AY=qtI7^R9VX#RMf9CuHN8=!<_XCL3Qh zgb7NC7G`qOZ#yL>n_h2|n4rW=P+}(f;$Mr&)_*k%6O=h;`C0g8A(fd5yt>&eq^o_6g`QcI0WiM$%!9w2*#`bF8uzO!P zqXG8IH@@B%76eFh!e99g-uwUBI~O>os%!tB%rG;V437vR!($*KNI(XHfJ6m}1vLst zc!&Y224(_7L5KtB;4?y%0jx&QGPc^rT6KI!ui}*Yh*azp6k@A&>hK8f!AA|H;;4xK zwf9>4WS!Z3+A_Vj_w)aJ?%_kS*E-+5_HVDf&(6uo$>eu4i=_`^{BB`fTI|zBhw@>o zZ+A=pVSe)O*z6X5JO9+)v3W!-_~^4&$L7&OgZhjUd!l^U>gGzHPLPiXxOy#OaOGQW zssJDTxn0MW)fuqF7bdX=+Gp_3gdJNlQ5gk$vb94JEc3Hi2ii)f{4ADyf=At3yToJ! zYy-a-s%lWwr2!y>4zlkQ&*IJ)ib%E@vATgrB#Y;N>pe+EygRa5T09fm#yY{LMp;?x zQ)tJwxgvk`122wki-e}rDL1Hd+q?BL2HjoYP&W1ye=FPaDZOLc2Q{(=)&E{(#=O_g zvHezITj$00YCrhYyx1NqmKN{p_6NX~CEgL5RDN*;wv!KaZU3@X5#2s?f$`eEMh;ZQd1eMa=F6#ip`9k2Q&-4-52-eGg>>RAg<1K>Zlx$A7v zce=;Kp)9^$?D{2Ui|TKw20lBcyFO2VZJh|XAY zgc=XD)fi*06r;Y_y!-y7j6iK9{uW;gkeNaqUu*41LqoGAF{UOI=e_`KQkqY6&! zL*7Chbx8uVgI}|9LT<6uy+h)1FR!up61Vgbak*1km~p(nHfK`OFxFOs-zfUxv|8~j zx2`LE@Jut(=qkT7LoFHI{wpK*iKuiJnCSx-Y~A~M;W0;kg%m9K(u#QX%DH^vgjow` z%?($&7AZh`3HrN!GE(lH7?oFnj#LEguePgxz(KLcO)fn##X zti?-~UAH8>c*%9)s&Ls-@qO~^mdNjqQ{zL1BxM*}5O7F`oR5MqCCcLRhFlyH;Z=+; zou;LdHl$e`;)*zTsEBC!>mkOuBdQoNJm0Gk!vhgUoRsPBuF^OT=a(M9d+pr)Du7xnf@i%;Q;Dq`SM znZM}yw6rY51{@8Xi5HRe{{gYFM(+#xs4xFV{PTRg5tUh_jFDv-{r`62if;qj$c^h+ z#dM4tB#w+WFtf#mbA8PA6F&jzgo4&t!a=JpQq#dco;E$aFb4q7V}@l7(YhLeCuoO_;Ef? zOcY965Yw7DF(a)LvlE>7QB)@?d0)og=+%ka?L5Yv8J$>_n3iAVf8@pv&O zo&uv~Zxbm_yj-Uf$p|Oj4(i0am_(5*KqtO( zapGIMMoh?QV8n#{q)xPtaiU|DPIU8gqNhhE&IXq`3n%n%(upB;oFI$O^$F)!b7E9P zk8z2Q6PLSnBGAlEOF_?Eg4SS(V!D6lAKsss}uKC zabjIaCw}hX#4n3=;xTY#$K{D8op`>E6EDSeVq=68Zv=JX9XBV)vW)F}&762Yt;hIF zf)hJybm9Px1Riq}4hMANb1#o^#HAC>8BQE;(1PhHYS#20p*IM%?4 z6SW#KF~5ot6CEL)=;-0Z8O1tL(!_}~Q##Q<&WX}$ofsbE#Q8p*xY)^wvCTR$zMd0g z@o||rwT2VHs2(GPdB&VhEcfcf0y~efD5DdL8#r-OQYY?+abiW4POR~B;y#Z~tSjck zdN5kd(}}-GapG5XI`K4)1of6IOU7Ob@)#R@dW<)moOr8QCpM=!@dq3wODpf!aN@(L zv@FEV04Mf%b>e`F6Nhn>EHN?-ocMcES{CAXj1d8&N+SYxJ}!Z_9-WYvY}6TSfGplh zpnHn9(yLC7(T|Ty;GBp~4E6CCBiuT1p_3CAHS5Hs^_;jOp%as%oS0Uj6W4kpT+!@k|yZk)HDvwUw4=(fEA@D$xPCSewL9N8&I`M3f z$4K~eqRx`_-!|*Sn`!BzR(@Bn6I*LIu|2929|btk=+%jRc1|2TN!CAU;KW~(dW>T+ zPJC0P5tB-NjF>bstrLL?P6TzOlgdyV=3~-aRK<^%NsGCTNjIHD#|jT`Wo5ChV{M8P zKdsY=Uqv|aL{KMQa&qF8W}SE|!HLZ^I`N(*AMXcr;x8^9Bc0KSrX(jmtJR6WS8<{_ zq!E)14;?+*!rrW0h_@;@u^C6nLcHhV#QQi(7NVhn6FZX9vJmN7PVC1~ zvJjtzIFa$|F`A1xaU6`6dR@5VThs?v#uZ2v&%4v$Xk2Uk`pS(e^@ngT+-GYj?X zZ>LZ6ON;kqy8IAdjqUW=DJ{nIltBOy0PTbL~6DxU!XRJx+#JVVtvA#kle(B}JV=kR|($0yeGdl57k`o(h zbz)Npd@5rz`-vE6sbh5JP^=|SD2$mGR%tP2jw_ZvA|`^-;s~5MEyal$bviM-niF#( zIxwk?Ur^iOi4v{omE zS8;+Ye!To}l%Eq9i|kl?`@``~;8Vx>5BCJ6Wr^{*lM!VX=tS8M+?=?)S&LCNANwlo%P1!vmAk=zO7V}Gs_r2_~ z6!_G9Dm&%_zaC#KZs#LNm#kY&loTo({(T*_~cNsAxF<@b8Pr*54r ze@^rz7sgs_cz#p8WAq=Ga_8%(FyS#3bVK2Gn#awTMB&YC=L$_N=sfmri_KpbMqLZn)MhHYB(_| zsuR;OM|g~eukq?c7;{8KMMfv8v42F|Q>+u~MPJm|hJRkC6Tgge;>n0kJQL)^3qGBA z)yavC%{sBEo)hmRbYfc+d}?)=WAjUk&%!x*9$5=}JIC21Eep{j&WS#HU*@=ZU*-(- z=`n`!zRVe+_hrr)R8KlCtI=bOi%K666DxG$YA+{dx^!Z8h7)rdbYfvGCn{q)adU_h zw~L%wU$N#a_i*CwVx9O2=9&6(e@Z7Fit`wcRO`g!K~6m7(~0NYoOscx6Lo1$yjHIh zZ`W|5KB^O`04F~1>ckE^Cw6CaVqXI%4kdNsix?-4R_VmIe(8e;*yiRI!=r;^F>MS0>=G2<`&QS`Ju?aQ$AkN<=H7`pX_pNsGU(Dj$yFvUr`zt8-uF6Y-(F z-;31>-8PkFLjP$6amj0Q2rP#4{eEn=K2_pxX;5kbC@Gr0Gfkh&Xt`MXeT<%VOu ze21uBL@`$6I-%5##z|Q@a8@t2tUb`Q&wx@pZJe+tP@`uB>~F8)kwsr_GgkBt$i3=I zAHo*#+H3KKf>&%SM%BWj`1KvDMf%LWr0?RGjMqVnH;m@?3Lr%9ada>v=u@w7tCtFm z>gYjY^_$hwhqHh6R-aD%N#xOt@o`!wcGYv@V2w`vwSp6WJBf~OT%0%|vS3xZCa-}J zYueT7#AzY}O6i)eA)P4kbE0ptP7G|~geRpF-njI^18i%`L~lig#D*4qwaQpCzXE&( z@K0BBbfxgH~;D(naP#BUp6Kkm7~#cJIDa=jMw{zlQN z>goOaYIWj^5GTI!XvEqaF*+*7T1TBubgbq?H|z(`#o8d(v9>&>$EYgiG48-NEiu-_ zIkBNekFmwYiT5%8mKc9Ya^iEpv@FCC%)l$K$1v8N9yHE@U(vK-!VTl{h4Yroo3&ux z&EX4rPni&2Qn9G~x~#7^{y3(w&gGOpR@p{X6S3UzKZ~BUx~no=7M^!wxSW=k2d~uy zJ~$f%;xt)5)DB^-6KVaWm|oGSVXVKR3LfdlWXU>>UaU~w`YS`6m>~wDljRNB`f!R9 z41 zm&EW8C&=Pc;Ei8n|FAD_B(P0RZ2HE@Vr=@ZS!<>KYt)7@{$LZMWYzHpXDy5Ihdv&S zNG)$-MCw;=osb_Jsf?w_;!0C5*7F#@sgV{Rxzy`XM!YXS60s_Me-MwMEZ)k8n`&8% z59Q@&Ym5)KRB?hV9^>PoAx3;Wx>#DAXk43NMB@_}(L%h0S;VY2l4T(_U|b@|vJe}g z5pxzclEsPimko?a%ZozR-YOrqlKu{}V~IgNB=*>1G9oAT(Sj~F7hb&7g|D2E)tjt!(vc&l3#IPXOL6#+kmGJuXzR1gB zrVg?!F;126IrUb^M_E4^Auq+5I>@rlw~0z{CGLI zq*!a^;1k#~wsP=kTnTuLrV>sl%R-!qwJ=6g--Omm)7Xsk5#evph{M}?UzEjLIsB2I z#W>uEJ>$eDrCvrTixZ!oa56$!ocJs+&4|wm^?ZCbGR6rX>gF*%|8pH9lw~1yRdZr* zL|UBqEBp?)-!PGp987@;f+F%kfCrOS+qOUpw1D9s77IC11jo^@qeh-bKtBQF$d ztsFU=V67bayhbCAmZJ~nhq8DpM=PQ%#?b{8dW`#c#*UK3WBk1~#bPMSLL}mxco|2@ zLL3Tkf-FuPo6P%iY+6+E7Gegf$KD>h79&~+d4WZ(AIHez#8)439m=v0J6%laS8$=D zo`spC%zlVV|?eSkP#VSGosFHE2d>3R;D?z2J>ejw&6&~`C&82 z;)LxRHZC^X35>{zoE(gcF>>+~vP}!o+s<_4^v!5Q?v*Jf+wA#WWeROEE_ZMYa8EtlXVM+Wo zEV0RVyQUBGXO|b7ENAaF`>;A5gDkGYE-y!!t&sH(h>_JYA}1UrLX(Q2EDPak;sja$ zfasIbTXFNgILNZZ7#QcRkYyn}s2(%sAj?7wi|`mXC#7W}?yizPcz}U$tPa7G`lUL@ zy<$|=D9KA*Hpg0zB?!$RNEl8gr za9%jRN=gQMSrm3ji?>h|Y2d^g%{s9qA${-w8j6l2;i-!#o0j;&bYZm}7=$NlpWAwT z;Ohc&O(v+=T)ML2d(v&@4Mua_cE6V1ThX>s_Yr)d+;_J#5EnT<- zuSeP1{kYiZBU#LV$(GNnguml6KfJ634+B0x@={4Q_PmAV;i`EH=Ux{HFDw_&mR6uv zUs($;hnua0t0Idkmn^>S`dJZcg*8n^Z&?A;Y*r|rwPe=pS&PF~`o5IWQ_^^C*Q6IN zz5cq{OXn>pU#z;juFe=NNjpdv8>PmKJF86o#iARQhL@^FBxh>}RSlyneqce?X>u1l z*xId+!&5i3$?8rc+V1DjeHc-8;n{}1u0Y_3qAh-!oZH>N!Vzxwqz_`45nmAF-JM^n zv$gLd2=yc3?MKv0i_g*y@-iuXY;98(Ujda*Cdby{G0}=Bj&y_M`*(kZ{`Ll1H7`?r9Nl$*YW5L)lp4wBw?NxKzvly4k|kaamlCai@@O5_bi4VwH~(orZ9w z*!xanlR$Kb|JZwFNI zZB$KB`<#C%LiXY_iTG)~;T9qsA_i>w_3m<4q;k=Xu;^6Mk=N;G38NJ1xhY*8gt7&B|Zg4wgm=BtV?xs0|@F-KKY{tb2%Q6v<=_OFP5I$|Bl zRds|2QAQEC7L=E-~oU>@oU^TT<ez^EzExiBp) zei(Kx6$7mfWo5DZplqEz86LwIlNKJRI7vE7pO_@5qVw1)$*32_&H)eDW*ay8Op7kM z+d4C!VLRjNW=U|JT?%WY4_oZgE(%spXb%=ZCN0-u$M4fEaQZlRJsN49l&RJ0sxTP4fV^UYjWao8tga$V?COKI_wdMnC@I*JdvnGVco@h493iE}+1LuIQazxc~~ zS%)H!#dUVQ&Ibg2a%k&%dsJE$VtEB8?hfe0YA+}5b?L-fq1SBXHzGIU2Z_aoJ?Sca zBJ0=_v;~7>)b;HY>{A)<_D)<{TxYjG`=k%!b=xH}BW5@Dz56gILVZ30=<80iuKVaZ z<2p+@4;~z;oOk1_CE>w0&Z-yg!lhHy z6~lM(r4t9SM|lDW@%M#s5PK|$g5BLRh&@&|fKMGpJ?^WO7C%^(k7E8j1Vr}m?jdb; zeu0w@ePXiVUIn6PFWUwZX6$cH*h+yDU2r)SAH;p`1w*lZ=!($ZqLcG!9juLd98 zqHbC|M$b_}NnlTUE)Y7*zhGr&!1_S64-3Lq^(quiigCm?3rkdf(#Li90+z#`8{T@r<9v|^J-0^g8&jQ^zB z=yvjqUq10dm+I<+^|%zsVX{oY%O@)4p@d{|6(bisV8v3v7^#yp|3oJqqwYt)>y-TXct)j9D-b-V;p;FA?t;;4q~|2RIW(i5N+I+b-6z7N`PGufZND@FYDL0F3Mb zXZ}eK@Kt=kK+zNRdV#${pLhk5P1yzv7Oz?26^7gAm~TP{j7Y-%Qd+kLjHv=kyhWuJ z#`)#mw(yAOJ%;U^{vx7i0bg&FjqRUPDqat>5zZN2D`|{?H3r&6=G9y0f#)Qp#m_~Q z4^<2tEMj!Dy!RM5G{$3)Wr;BY`$93u;yoGopjXCFJyAB*cp2+kV!kHwVJc60bX{*3 zbD|!Mmddv_ae^$KpVAVMVY+4BrYwGbT^g(gLVSG_Gg?~i<25SW(&FdWrN2so?>rjU z(kE)AWr-<$EapogUSoq_S{Ty~Wy3b;ED=R45U65MKRzadUK5aY)CT=7C4HFTLBFrl ziLG%?Y_HY{@==UGMI^z;b4BMdx0{Hb8TN7|OG8B9oaM8;W&@^@oaKKcC9-4! zr&y3ma@*WSzay5L*S8*Xl6%^NA^hr4ZuvU;mABlmOXL$bQ%P?4F8W8y|Ih?}XT&BJ%tQHd<6{ipgYmE?7w@5P+t^(YFVlDr{XIKWQ)QPHdUVgWMe2trF#PUR`vuGi&@i_ga zW8Mxh(YK?QkLvCilvcj0GRiky#oJL6R6ZzC-9I-dAC%Cy)0QIN&b&J18&;!yUZr{G zO@{K_Ok}v61I_EmsY-Kl)m(+O2%wIf>iXN42}p zt=io;PHEmZQEA?HS3T7gCDgL-an)Z@BHtH2#T|8%Z+}qbUX+mAe}{^z1UQ*+> zf1}d8|G44~7>YYELgnSaWd_wfFgr-?9+=}J-@(4MDt>QTO_s=rNecNDhK1b0EnH8M|>$hS7Bd_PrMn&4h2;-Ey_ zaj)`034Mnvh(R1Fft z^1I$niu1d!Y9b|~B-i@*n+;`0=gnk-aw1Bt-B8Kqtua#a&iE?I$vZ(hJINO%%*ls~LuNx+B_F=$ zB_*QN+6|R7P7INf9TWVhq`>xHQS=pbE2LRmFz}BtoI3><{;>kp6^!awXEtuCD;V`8 z9Z#}k0;gDz>IyEox`~urvcHNKsbKa65i@>P$?RAN^Hd;8t=&+`ydG{+ zGVfRuDVcWyE{ln<1)_vXZvH4cB3UK3T$dpwqSV?AmD~x}1?3u3u>2}o?FyD(L+h?A zp_2P2xy**LO78#CLrO%cwHqp_iPO4U@X+h@N?Y*ITYk!kD4~+)KRVewd0~7LDG{aC zZm8syu|CSlD?d{?dF2y_V13))|^^WvULxwb_H7x z&>AC4sO0e4^huN)ZjMk+M5(nK=H$o}m6IbWI`=3z(%__=h>}!d&$}aFHe}|+p5Hx& zN@U3dPO%`B*o%%*PVDVGPCRz(?JlIFSe8&pkD)0uepX43l#`T*QfoI<(tDm#a#p}a zO3u1EgE_H_5-J(-n9pn|tHk@GDpDd!t=&+`MfcR>Jh6}N93>^AyH=2r(Is?6#XjM@ zgxOG5$%Hp6NQo%5c0(mssqYq&RJv$l{|VZ z+fFtoznbf(oQP6uH_XYCA2yMa+B!N@u-7JOjg=)-Qn%qGuRHeNERB;AQEKgmO5XT3 zK}wPjC24g2bfKSo`yWW4ukh?<8pXnXvuWKa>^H}aqgXfyzTGSp7Y=@`+7x8wuFx|( zgNkLz1WvIa6&H^9ERO05y`Rw8L!tL?K~f@0sARJI&I>k?RWcdg6NnZ&$bZdM3hj;5qTF0 zwv|k(2SN~ombwvgFER!PP0 zYeZD#Dkq|ZN>;**P+L~X%FleHM3h>)p^|&wYbGW4{VhXE z?mI^3F%D5eC6C`7G8@V&d7^;M9vq_7+6|RFvpYmep55aiCC{~`*J6h#p^}Y%&8`<& zCBL0d>xn~@TD!?lSRJq35Q6~p>Ad5$nz*#`Wl$m>uI2<;|A2^#xoi1zvX0ltC&M~k zdse(gdGV8D$7`>qb^aq4C-#b7dii&R9It&N#(?g5cD!ELBrW`G6m`Ge*9X2lYUOob zjkNIQ6FZa*$LrULxbSk1pEjFz4(^>>EB9hdtdV>*06z2cX-D$6UTI^E8^TljR&kwun+UQN!s0Mrch7e^Bti=jq;`!_?T_lf*LKVwpmpDS+v-q z@8qLaKNc!l5W9+{j|j4O&$c{`wUjPpV~s64nzfi)(rFfR%l>+uXi9M6vl^YqL^(kg z>cR|f?Jjz6r;Kjx6_OUu&(?lIxk;ScBrTlvnDedDmz`Z(&r3;0jpEh|>cCdBYik%) zTiUoj%845)q-7zN1~{?Is}r}mI6;=BufG;O=}fa}tF**7f^iJCJ_|cxuUH|}ar17# z3FYi;Qa09jcd@SG-J4vp1`)T23|Z&OyW}I{_KZ#}Z{RV=;Nm#u^JzLmzEZf*_fALL}Ou%PPB`1;uU^{lf)`6$MC2mw9C-s2J5xT6|;{b|-VrbRycTW0N!cSJr);lCaJ8;%`YQt%}H z@&T^?JN_64yA)oo5u6oxXzomw< zQPHkZO|Vyt97UK=Eop2M+t_tq27GE2+x3{pTQ2+)8xc>2pllLk@#ACHE+-K5^;*Yn zXM?m*C&t)4LMTx&c8`fm3uBezj|7oJ8_KXxy7fu(*v0!MuJ-6GCt zXoFf@CHiG*dazbnJa@Za7Mg?xs$tsTa_nwwh9{qDad#T57A;Dj4{B5WFQSscT&K^7 zNsDJ8eYOXDDhugBV1UJ63)4fCChQg3q6W5+KEF;z6*UbcD~k0HNHX!-jEjy>d~ z7!#d(jLFSB#&)zUN*fc5*c)+4i;p<^#JYm{Q;Zt1y-Vz{57!;Tv3F$*tg)2;z3V-4 zAJ6~ZpNrfG0%r``^ar0Edk=eM4X$zT@uc)&Kld56jDRAH`u_H!ol7X9vXI~3H!k<_ zH3faD&HeqWfhdrxwOT9pk8*;~0slqspap4*UUFNgy1NOgH13r~)W$~UKcsMR=p~?dSdNITD3V{240MC=wd+kjGYa~$|^SI6)3t>r zzZb796y5xC4PN_JrBQfoGg{Bu#j`EPC7;BDxhY0C z#JnwY6aGW3ENfdAGVpp*(W;@MU#;6@ABtA}DFM~# zmAGhiPE1-jDzaDP8v%Z-u{vMm=rWucMase&L^wh~j8FtwNc4t1M$zg$Uh&+jOft}=j2FX*;g}ul8V8p+-f+yaHub|9f_=CZxAUle{3Haf4r=Z-My2&X z*N@_M8SICVb1CR-vmDxke*De#{r6HkXt}}(F5CP85wQ!l+}Xc52H)QiTi0^=gle$} zk3K4idUAt;$OG^zeDG*H5l<)K88(RZcjJ6nERpYEaUaqpB`(<0lBRucdBnc?L&cNW zAktUV%8-sxaM+uNvS#L7R2Bh@y4b;8uS(MB;>z0xH2t&5oLZOp-a zwsr%2a^J(AY|LER*S<0&_x&2$lgDE2?2VKcTc`aP^EuXD9@RS??oSX}Hbl%mY|J+X zgU@j6gTJd`Q)PH{%28!lOLJ8jR;)HSn~PR`R3l@FKFj%CwCYor^oZ<{=R~dah%rJB zzHZ~lkmrnI$%vzmJVT%eD#Zwq$DfuSkqh#Sua_Q?Ir4-8(j$%+@>IB_M`VdS3+&P( z#*jRB#H2@Lggp1bP8u)r{0c`df-_5{`>z2qLn4} literal 0 HcmV?d00001 diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index c3b592ecb0..f5561670bc 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -26,7 +26,8 @@ module Development.IDE.WorkerThread Worker, tryReadTaskQueue, awaitRunInThreadAtHead, - withWorkerQueueSimpleRight + withWorkerQueueSimpleRight, + submitWorkAtHead ) where import Control.Concurrent.Async (Async, async, withAsync) @@ -157,10 +158,12 @@ eitherWorker w1 w2 = \case -- submitWork without waiting for the result submitWork :: TaskQueue arg -> arg -> IO () -submitWork (TaskQueue q) arg = do - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - atomically $ writeTQueue q arg +submitWork (TaskQueue q) arg = do atomically $ writeTQueue q arg + +-- submit work at the head of the queue, so it will be executed next +submitWorkAtHead :: TaskQueue arg -> arg -> IO () +submitWorkAtHead (TaskQueue q) arg = do + atomically $ unGetTQueue q arg awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result awaitRunInThread (TaskQueue q) act = do diff --git a/scripts/eventlog-dump.fish b/scripts/eventlog-dump.fish new file mode 100755 index 0000000000..9cd44fe67f --- /dev/null +++ b/scripts/eventlog-dump.fish @@ -0,0 +1,117 @@ +#!/usr/bin/env fish + +# Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI. +# Usage: +# scripts/eventlog-dump.fish [output.txt] [contains_substring] +# +# Notes: +# - Attempts to find ghc-events in PATH, ~/.cabal/bin, or ~/.local/bin. +# - If not found, will try: cabal install ghc-events +# - Output defaults to .events.txt in the current directory. + +function usage + echo "Usage: (basename (status filename)) [output.txt] [contains_substring]" + exit 2 +end + +if test (count $argv) -lt 1 + usage +end + +set evlog $argv[1] +if not test -f $evlog + echo "error: file not found: $evlog" >&2 + exit 1 +end + +if test (count $argv) -ge 2 + set out $argv[2] +else + set base (basename $evlog) + if string match -q '*\.eventlog' $base + set out (string replace -r '\\.eventlog$' '.events.txt' -- $base) + else + set out "$base.events.txt" + end +end + +# Optional contains filter: only keep lines that contain any of the substrings (pipe-separated) +set filter_contains "" +set filter_contains_list +if test (count $argv) -ge 3 + set filter_contains $argv[3] + set filter_contains_list (string split '|' -- $filter_contains) +end + +function find_ghc_events --description "echo absolute path to ghc-events or empty" + if command -sq ghc-events + command -s ghc-events + return 0 + end + if test -x ~/.cabal/bin/ghc-events + echo ~/.cabal/bin/ghc-events + return 0 + end + if test -x ~/.local/bin/ghc-events + echo ~/.local/bin/ghc-events + return 0 + end + return 1 +end + +set ghc_events_bin (find_ghc_events) + +if test -z "$ghc_events_bin" + echo "ghc-events not found; attempting to install via 'cabal install ghc-events'..." >&2 + if not command -sq cabal + echo "error: cabal not found; please install ghc-events manually (e.g., via cabal)." >&2 + exit 1 + end + cabal install ghc-events + set ghc_events_bin (find_ghc_events) + if test -z "$ghc_events_bin" + echo "error: ghc-events still not found after installation." >&2 + exit 1 + end +end + +echo "Dumping events from $evlog to $out..." +if test -n "$filter_contains" + $ghc_events_bin show $evlog | while read -l line + set keep 1 + if (count $filter_contains_list) -gt 0 + set found 0 + for substr in $filter_contains_list + if string match -q -- "*$substr*" -- $line + set found 1 + break + end + end + if test $found -eq 0 + set keep 0 + end + end + if test $keep -eq 1 + echo $line + end + end > $out +else + $ghc_events_bin show $evlog > $out +end +set exit_code $status + +if test $exit_code -ne 0 + echo "error: dump failed with exit code $exit_code" >&2 + exit $exit_code +end + +set -l size "" +if command -sq stat + # macOS stat prints size with -f%z; suppress errors if not supported + set size (stat -f%z $out 2>/dev/null) +end +if test -z "$size" + set size (wc -c < $out) +end + +echo "Wrote $out ($size bytes)." diff --git a/scripts/flaky-test-loop.sh b/scripts/flaky-test-loop.sh new file mode 100755 index 0000000000..c072783cd1 --- /dev/null +++ b/scripts/flaky-test-loop.sh @@ -0,0 +1,200 @@ +#!/usr/bin/env bash +# Loop running HLS tasty tests until a Broken pipe or test failure is observed. +# Originally ran only the "open close" test; now supports multiple patterns. +# Ensures successful build before running any tests. +# Logs each run to test-logs/-loop-.log, rotating every 100 files per pattern. +# +# Environment you can tweak: +# MAX_ITER : maximum iterations before giving up (default: 1000) +# SLEEP_SECS : seconds to sleep between iterations (default: 0) +# SHOW_EVERY : print progress/iteration header every N iterations (default: 100, 1 = every run, <=0 = disabled) +# LOG_STDERR : set to 1 to enable verbose stderr logging (HLS_TEST_LOG_STDERR & HLS_TEST_HARNESS_STDERR) (default: 1) +# NO_BUILD_ONCE : set to non-empty to skip the initial cabal build step +# +# Test selection: +# TEST_PATTERNS : comma-separated list of entries to run each iteration. +# Each entry can be either a plain tasty pattern, or 'BIN::PATTERN' to select a test binary. +# Examples: +# TEST_PATTERNS='open close' +# TEST_PATTERNS='ghcide-tests::open close,func-test::sends indefinite progress notifications' +# If set and non-empty, this takes precedence over PATTERN_FILE. +# If unset, defaults to 'ghcide-tests::open close' to match prior behavior. +# PATTERN_FILE : path to a file with one entry per line. +# Lines start with optional 'BIN::', then the tasty pattern. '#' comments and blank lines ignored. +# Examples: +# ghcide-tests::open close +# func-test::sends indefinite progress notifications +# Used only if TEST_PATTERNS is empty/unset; otherwise ignored. +# +# Exit codes: +# 1 on success (broken pipe or test failure reproduced) +# 0 on reaching MAX_ITER without reproduction +# 2 on other setup error + +set -euo pipefail + +MAX_ITER="${MAX_ITER:-}" +SLEEP_SECS="${SLEEP_SECS:-0}" +SHOW_EVERY="${SHOW_EVERY:-1}" +LOG_STDERR="${LOG_STDERR:-1}" + +# Allow providing a positional max iteration: ./open-close-loop.sh 50 +if [[ $# -ge 1 && -z "${MAX_ITER}" ]]; then + MAX_ITER="$1" +fi + +# fallback to default if not set +if [[ -z "${MAX_ITER}" ]]; then + MAX_ITER=1000 +fi + +mkdir -p test-logs + +iter=0 +start_ts=$(date -Iseconds) +echo "[loop] Starting at ${start_ts}" >&2 + +# Patterns to detect issues +# - Use case-insensitive extended regex for failures/timeouts in logs +# - Broken pipe: case-insensitive fixed-string search +BROKEN_PIPE_RE='Broken pipe' +TEST_FAILED_RE='tests failed|timeout' +DEBUG_DETECT="${DEBUG_DETECT:-0}" + +# Resolve what to run each iteration as pairs of BIN and PATTERN +items=() # each item is 'BIN::PATTERN' +if [[ -n "${TEST_PATTERNS:-}" ]]; then + IFS=',' read -r -a raw_items <<< "${TEST_PATTERNS}" + for it in "${raw_items[@]}"; do + # trim + it="${it#${it%%[![:space:]]*}}"; it="${it%${it##*[![:space:]]}}" + [[ -z "$it" ]] && continue + if [[ "$it" == *"::"* ]]; then + items+=("$it") + else + items+=("ghcide-tests::${it}") + fi + done +elif [[ -n "${PATTERN_FILE:-}" && -r "${PATTERN_FILE}" ]]; then + while IFS= read -r line; do + # trim whitespace, skip comments and blank lines + trimmed="${line#${line%%[![:space:]]*}}"; trimmed="${trimmed%${trimmed##*[![:space:]]}}" + [[ -z "${trimmed}" || "${trimmed}" =~ ^[[:space:]]*# ]] && continue + if [[ "${trimmed}" == *"::"* ]]; then + items+=("${trimmed}") + else + items+=("ghcide-tests::${trimmed}") + fi + done < "${PATTERN_FILE}" +else + # default to the original single test + items+=("ghcide-tests::open close") +fi + +if [[ ${#items[@]} -eq 0 ]]; then + echo "[loop][error] No test entries provided (via PATTERN_FILE or TEST_PATTERNS)." >&2 + exit 2 +fi + +# Build required test binaries once upfront (unless NO_BUILD_ONCE is set) +if [[ -z "${NO_BUILD_ONCE:-}" ]]; then + # collect unique BIN names + declare -a bins_to_build=() + for it in "${items[@]}"; do + bin="${it%%::*}"; seen=0 + if (( ${#bins_to_build[@]} > 0 )); then + for b in "${bins_to_build[@]}"; do [[ "$b" == "$bin" ]] && seen=1 && break; done + fi + [[ $seen -eq 0 ]] && bins_to_build+=("$bin") + done + if (( ${#bins_to_build[@]} > 0 )); then + echo "[loop] Building test targets once upfront: ${bins_to_build[*]}" >&2 + if ! cabal build "${bins_to_build[@]}" >&2; then + echo "[loop][error] Build failed. Cannot proceed with tests." >&2 + exit 2 + fi + echo "[loop] Build succeeded. Proceeding with tests." >&2 + fi +fi + +# Resolve binary path by name (cache results) +BIN_NAMES=() +BIN_PATHS=() +get_bin_path() { + local name="$1" + local i + for ((i=0; i<${#BIN_NAMES[@]}; i++)); do + if [[ "${BIN_NAMES[i]}" == "$name" ]]; then + echo "${BIN_PATHS[i]}"; return + fi + done + local path="" + path=$(find dist-newstyle -type f -name "$name" -perm -111 2>/dev/null | head -n1 || true) + BIN_NAMES+=("$name"); BIN_PATHS+=("$path") + echo "$path" +} + +while true; do + iter=$((iter+1)) + ts=$(date -Iseconds) + file_num=$((iter % 2)) + # if [[ ${file_num} -eq 0 ]]; then file_num=100; fi + + # Run each selected item (BIN::PATTERN) in this iteration + for item in "${items[@]}"; do + bin_name="${item%%::*}" + pattern="${item#*::}" + # sanitize pattern for a log slug + slug=$(printf '%s' "${bin_name}-${pattern}" | tr -cs 'A-Za-z0-9._-' '-' | sed -E 's/^-+|-+$//g') + [[ -z "${slug}" ]] && slug="pattern" + log="test-logs/${slug}-loop-${file_num}.log" + + # Show iteration start at first run and then every SHOW_EVERY runs (if > 0) + if [[ ${iter} -eq 1 || ( ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ) ]]; then + echo "[loop] Iteration ${iter} (${ts}) pattern='${pattern}' -> ${log}" | tee -a "${log}" >&2 + fi + + # We don't fail the loop on non-zero exit (capture output then decide). + set +e + # HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 \ + HLS_TEST_LOG_STDERR="${LOG_STDERR}" \ + HLS_TEST_HARNESS_STDERR="${LOG_STDERR}" \ + TASTY_NUM_THREADS=1 \ + TASTY_PATTERN="${pattern}" \ + "$(get_bin_path "${bin_name}")" +RTS -l -olhlint.eventlog -RTS >"${log}" 2>&1 + set -e + + if grep -aFiq -- "${BROKEN_PIPE_RE}" "${log}"; then + echo "[loop] Broken pipe reproduced in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + elif grep -aEq -- "${TEST_FAILED_RE}" "${log}"; then + echo "[loop] Test failure detected in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + else + if [[ ${DEBUG_DETECT} -eq 1 ]]; then + echo "[loop][debug] No match for '${BROKEN_PIPE_RE}' or '${TEST_FAILED_RE}' in iteration ${iter} (pattern='${pattern}')." | tee -a "${log}" >&2 + fi + fi + done + + if [[ -n "${MAX_ITER}" && ${iter} -ge ${MAX_ITER} ]]; then + echo "[loop] Reached MAX_ITER=${MAX_ITER} without reproducing issues." >&2 + exit 0 + fi + + # Show progress at the configured cadence + if [[ ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ]]; then + echo "[loop] Progress: Completed ${iter} iterations without detecting issues." >&2 + fi + + if [[ ${SLEEP_SECS} -gt 0 ]]; then + echo "[loop] Sleeping ${SLEEP_SECS}s" >&2 + sleep "${SLEEP_SECS}" + fi +done diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt new file mode 100644 index 0000000000..b08a8a6ede --- /dev/null +++ b/scripts/flaky-test-patterns.txt @@ -0,0 +1,28 @@ +# One tasty pattern per line. Lines starting with # are comments. +# Blank lines are ignored. + +# open close +# non local variable +# Notification Handlers +# bidirectional module dependency with hs-boot + +# InternalError over InvalidParams +# ghcide restarts shake session on config changes: +# addDependentFile +# Another interesting one you can try: +# func-test::sends indefinite progress notifications +# hls-pragmas-plugin-tests::/inline: RULES/ + +# hls-graph cancel leaks asynchronous exception to the next session +# hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics +# hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps +# hls-class-plugin-tests::Creates a placeholder for fmap +# hls-rename-plugin-tests::Rename +# th-linking-test-unboxed +update syntax error +# iface-error-test-1 + +# update syntax error +# retry failed +# th-linking-test +# are deleted from the state From b4d3c49e3272394e9e41a21eff871154b628b389 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 8 Sep 2025 08:03:36 +0800 Subject: [PATCH 081/107] wait for shake restart only if needed --- .../session-loader/Development/IDE/Session.hs | 3 +- ghcide/src/Development/IDE/Core/FileStore.hs | 14 ++++++--- ghcide/src/Development/IDE/Core/Shake.hs | 30 ++++++++++++------- hls-plugin-api/src/Ide/Types.hs | 5 +++- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +-- .../src/Ide/Plugin/Eval/Handlers.hs | 6 ++-- 6 files changed, 41 insertions(+), 21 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2d43724f3f..8255310f07 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -68,6 +68,7 @@ import Ide.Logger (Pretty (pretty), vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), + ShouldWait (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -625,7 +626,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , .. } sessionShake = SessionShake - { restartSession = restartShakeSession extras + { restartSession = restartShakeSession extras ShouldWait , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras } diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 0bdec3874e..c9fdec41c1 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -22,6 +22,7 @@ module Development.IDE.Core.FileStore( registerFileWatches, shareFilePath, Log(..), + setSomethingModifiedWait, ) where import Control.Concurrent.STM.Stats (STM, atomically) @@ -279,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do + restartShakeSession (shakeExtras state) ShouldNotWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) @@ -299,11 +300,16 @@ typecheckParentsAction recorder nfp = do -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified vfs state reason actionBetweenSession = do +setSomethingModified' :: ShouldWait -> VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified' shouldWait vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession + void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldNotWait vfs state reason actionBetweenSession + +setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1e559cedc0..b117579c40 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -190,6 +190,9 @@ import System.Time.Extra import UnliftIO (MonadUnliftIO (withRunInIO), newIORef, readIORef) +#if !MIN_VERSION_ghc(9,9,0) +import Data.Foldable (foldl') +#endif data Log @@ -341,7 +344,8 @@ data ShakeExtras = ShakeExtras ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession - :: VFSModified + :: ShouldWait + -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] @@ -886,15 +890,21 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: ShakeControlQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do - waitMVar <- newEmptyMVar - -- submit at the head of the queue, - -- prefer restart request over any pending actions - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] - -- Wait until the restart is done - takeMVar waitMVar +shakeRestart :: ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart rts b vfs reason acts ioActionBetweenShakeSession = case b of + ShouldWait -> + do + waitMVar <- newEmptyMVar + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] + -- Wait until the restart is done + takeMVar waitMVar + ShouldNotWait -> + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [] + dynShakeRestart :: Dynamic -> ShakeRestartArgs dynShakeRestart dy = case fromDynamic dy of diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 314049b826..ccb622bb2c 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -42,7 +42,7 @@ module Ide.Types , installSigUsr1Handler , lookupCommandProvider , ResolveFunction -, mkResolveHandler +, mkResolveHandler, ShouldWait(..) ) where @@ -1302,3 +1302,6 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing resolve handlers for the same method, than our assumptions that we never have two responses break, and behavior is undefined. -} + +data ShouldWait = ShouldWait | ShouldNotWait + deriving Eq diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7a2c53ee25..f189fa2893 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) 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 1f19b5b476..7ec8b96c4f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,7 +41,7 @@ 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, setSomethingModified) +import Development.IDE.Core.FileStore (getUriContents, setSomethingModifiedWait) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) @@ -214,11 +214,11 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModified VFSUnmodified st "Eval" $ do + (setSomethingModifiedWait VFSUnmodified st "Eval" $ do queueForEvaluation st nfp return [toKey IsEvaluating nfp] ) - (setSomethingModified VFSUnmodified st "Eval" $ do + (setSomethingModifiedWait VFSUnmodified st "Eval" $ do unqueueForEvaluation st nfp return [toKey IsEvaluating nfp] ) From 7bf6fde6f9c0535a1b77d8d2702014fd4a9ef809 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 8 Sep 2025 08:35:08 +0800 Subject: [PATCH 082/107] always wait for restart --- .../session-loader/Development/IDE/Session.hs | 3 +-- ghcide/src/Development/IDE/Core/FileStore.hs | 14 +++------- ghcide/src/Development/IDE/Core/Shake.hs | 27 +++++++------------ hls-plugin-api/src/Ide/Types.hs | 5 +--- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +-- .../src/Ide/Plugin/Eval/Handlers.hs | 6 ++--- scripts/flaky-test-patterns.txt | 4 +-- 7 files changed, 23 insertions(+), 40 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8255310f07..2d43724f3f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -68,7 +68,6 @@ import Ide.Logger (Pretty (pretty), vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), - ShouldWait (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -626,7 +625,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , .. } sessionShake = SessionShake - { restartSession = restartShakeSession extras ShouldWait + { restartSession = restartShakeSession extras , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras } diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index c9fdec41c1..0bdec3874e 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -22,7 +22,6 @@ module Development.IDE.Core.FileStore( registerFileWatches, shareFilePath, Log(..), - setSomethingModifiedWait, ) where import Control.Concurrent.STM.Stats (STM, atomically) @@ -280,7 +279,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) ShouldNotWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) @@ -300,16 +299,11 @@ typecheckParentsAction recorder nfp = do -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified' :: ShouldWait -> VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified' shouldWait vfs state reason actionBetweenSession = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession -setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldNotWait vfs state reason actionBetweenSession - -setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession + void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b117579c40..021ea2365b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -344,8 +344,7 @@ data ShakeExtras = ShakeExtras ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession - :: ShouldWait - -> VFSModified + :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] @@ -890,21 +889,15 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart rts b vfs reason acts ioActionBetweenShakeSession = case b of - ShouldWait -> - do - waitMVar <- newEmptyMVar - -- submit at the head of the queue, - -- prefer restart request over any pending actions - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] - -- Wait until the restart is done - takeMVar waitMVar - ShouldNotWait -> - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [] - +shakeRestart :: ShakeControlQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do + waitMVar <- newEmptyMVar + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] + -- Wait until the restart is done + takeMVar waitMVar dynShakeRestart :: Dynamic -> ShakeRestartArgs dynShakeRestart dy = case fromDynamic dy of diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ccb622bb2c..314049b826 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -42,7 +42,7 @@ module Ide.Types , installSigUsr1Handler , lookupCommandProvider , ResolveFunction -, mkResolveHandler, ShouldWait(..) +, mkResolveHandler ) where @@ -1302,6 +1302,3 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing resolve handlers for the same method, than our assumptions that we never have two responses break, and behavior is undefined. -} - -data ShouldWait = ShouldWait | ShouldNotWait - deriving Eq diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index f189fa2893..7a2c53ee25 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) 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 7ec8b96c4f..1f19b5b476 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,7 +41,7 @@ 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, setSomethingModifiedWait) +import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) @@ -214,11 +214,11 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModifiedWait VFSUnmodified st "Eval" $ do + (setSomethingModified VFSUnmodified st "Eval" $ do queueForEvaluation st nfp return [toKey IsEvaluating nfp] ) - (setSomethingModifiedWait VFSUnmodified st "Eval" $ do + (setSomethingModified VFSUnmodified st "Eval" $ do unqueueForEvaluation st nfp return [toKey IsEvaluating nfp] ) diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt index b08a8a6ede..f820cad42b 100644 --- a/scripts/flaky-test-patterns.txt +++ b/scripts/flaky-test-patterns.txt @@ -4,7 +4,7 @@ # open close # non local variable # Notification Handlers -# bidirectional module dependency with hs-boot +bidirectional module dependency with hs-boot # InternalError over InvalidParams # ghcide restarts shake session on config changes: @@ -19,7 +19,7 @@ # hls-class-plugin-tests::Creates a placeholder for fmap # hls-rename-plugin-tests::Rename # th-linking-test-unboxed -update syntax error +# update syntax error # iface-error-test-1 # update syntax error From e963e615d9ef39fb802a16781c36ba71d4b469b9 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 9 Sep 2025 10:45:47 +0800 Subject: [PATCH 083/107] cleanup --- ghcide/src/Development/IDE/Core/Shake.hs | 9 +++---- hls-graph/src/Development/IDE/WorkerThread.hs | 26 +------------------ 2 files changed, 5 insertions(+), 30 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 021ea2365b..c950ae3b8b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -899,16 +899,15 @@ shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do -- Wait until the restart is done takeMVar waitMVar + +runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () +runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) + dynShakeRestart :: Dynamic -> ShakeRestartArgs dynShakeRestart dy = case fromDynamic dy of Just shakeRestartArgs -> shakeRestartArgs Nothing -> error "Internal error, dynShakeRestart, got invalid dynamic type" --- runRestartTask :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () --- runRestartTask recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = -runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () -runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) - runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index f5561670bc..d2cec4b837 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -14,7 +14,6 @@ module Development.IDE.WorkerThread ( LogWorkerThread (..), DeliverStatus(..), withWorkerQueue, - awaitRunInThread, TaskQueue(..), writeTaskQueue, withWorkerQueueSimple, @@ -25,7 +24,6 @@ module Development.IDE.WorkerThread eitherWorker, Worker, tryReadTaskQueue, - awaitRunInThreadAtHead, withWorkerQueueSimpleRight, submitWorkAtHead ) where @@ -158,35 +156,13 @@ eitherWorker w1 w2 = \case -- submitWork without waiting for the result submitWork :: TaskQueue arg -> arg -> IO () -submitWork (TaskQueue q) arg = do atomically $ writeTQueue q arg +submitWork (TaskQueue q) arg = atomically $ writeTQueue q arg -- submit work at the head of the queue, so it will be executed next submitWorkAtHead :: TaskQueue arg -> arg -> IO () submitWorkAtHead (TaskQueue q) arg = do atomically $ unGetTQueue q arg -awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result -awaitRunInThread (TaskQueue q) act = do - barrier <- newEmptyTMVarIO - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - atomically $ writeTQueue q (try act >>= atomically . putTMVar barrier) - resultOrException <- atomically $ takeTMVar barrier - case resultOrException of - Left e -> throw (e :: SomeException) - Right r -> return r - -awaitRunInThreadAtHead :: TaskQueue (IO ()) -> IO result -> IO result -awaitRunInThreadAtHead (TaskQueue q) act = do - barrier <- newEmptyTMVarIO - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - atomically $ unGetTQueue q (try act >>= atomically . putTMVar barrier) - resultOrException <- atomically $ takeTMVar barrier - case resultOrException of - Left e -> throw (e :: SomeException) - Right r -> return r - writeTaskQueue :: TaskQueue a -> a -> STM () writeTaskQueue (TaskQueue q) = writeTQueue q From c778f9db036babc140db6f5f83c60355b69b1fdf Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 9 Sep 2025 13:17:15 +0800 Subject: [PATCH 084/107] refactor: streamline ShakeRestartArgs and enhance database queue access --- ghcide/src/Development/IDE/Core/Shake.hs | 31 ++++++++++--------- .../IDE/Graph/Internal/Database.hs | 5 ++- .../Development/IDE/Graph/Internal/Types.hs | 3 ++ 3 files changed, 21 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c950ae3b8b..f31074d7f5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -154,7 +154,8 @@ import Development.IDE.Graph.Database (ShakeDatabase, import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) import Development.IDE.Graph.Internal.Types (DBQue, Step (..), - getShakeStep) + getShakeStep, + shakeDataBaseQueue) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -858,14 +859,13 @@ delayedAction a = do data ShakeRestartArgs = ShakeRestartArgs - { sraVfs :: !VFSModified - , sraReason :: !String - , sraActions :: ![DelayedAction ()] - , sraBetweenSessions :: IO [Key] - , sraShakeControlQueue :: !ShakeControlQueue - , sraCount :: !Int - , sraWaitMVars :: ![MVar ()] + { sraVfs :: !VFSModified + , sraReason :: !String + , sraActions :: ![DelayedAction ()] + , sraBetweenSessions :: IO [Key] + , sraCount :: !Int -- ^ Just for debugging, how many restarts have been requested so far + , sraWaitMVars :: ![MVar ()] } instance Show ShakeRestartArgs where @@ -881,7 +881,6 @@ instance Semigroup ShakeRestartArgs where , sraReason = sraReason a ++ "; " ++ sraReason b , sraActions = sraActions a ++ sraActions b , sraBetweenSessions = (++) <$> sraBetweenSessions a <*> sraBetweenSessions b - , sraShakeControlQueue = sraShakeControlQueue a , sraCount = sraCount a + sraCount b , sraWaitMVars = sraWaitMVars a ++ sraWaitMVars b } @@ -895,7 +894,7 @@ shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do -- submit at the head of the queue, -- prefer restart request over any pending actions void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar] + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] -- Wait until the restart is done takeMVar waitMVar @@ -911,21 +910,23 @@ dynShakeRestart dy = case fromDynamic dy of runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar + let shakeControlQueue = shakeDataBaseQueue shakeDb let prepareRestart sra@ShakeRestartArgs {..} = do keys <- sraBetweenSessions -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + sleep 0.2 -- Check if there is another restart request pending, if so, we run that one too - readAndGo sra sraShakeControlQueue - readAndGo sra sraShakeControlQueue = do - nextRestartArg <- atomically $ tryReadTaskQueue sraShakeControlQueue + readAndGo sra + readAndGo sra = do + nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue case nextRestartArg of Nothing -> return sra Just (Left dy) -> do res <- prepareRestart $ dynShakeRestart dy return $ sra <> res - Just (Right _) -> readAndGo sra sraShakeControlQueue + Just (Right _) -> readAndGo sra withMVar' shakeSession ( \runner -> do @@ -1049,7 +1050,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do parentTid <- myThreadId workThread <- asyncWithUnmask $ \x -> do childThreadId <- myThreadId - logWith recorder Info $ LogShakeText ("Starting shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")") + -- logWith recorder Info $ LogShakeText ("shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")") workRun start x -- Cancelling is required to flush the Shake database when either diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 56b2380217..dba43b03c8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -127,7 +127,7 @@ builderOneCoroutine isSingletonTask db stack id = builderOneCoroutine' RunFirst isSingletonTask db stack id where builderOneCoroutine' :: RunFirst -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue - builderOneCoroutine' rf isSingletonTask db@Database {..} stack id = mask $ \restore -> do + builderOneCoroutine' rf isSingletonTask db@Database {..} stack id = do traceEvent ("builderOne: " ++ show id) return () liftIO $ atomicallyNamed "builder" $ do -- Spawn the id if needed @@ -140,7 +140,7 @@ builderOneCoroutine isSingletonTask db stack id = IsSingleton -> return $ BCContinue $ fmap (BCStop id) $ - restore (refresh db stack id s) `catch` \e@(SomeException _) -> do + refresh db stack id s `catch` \e@(SomeException _) -> do atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues throw e NotSingleton -> do @@ -149,7 +149,6 @@ builderOneCoroutine isSingletonTask db stack id = \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id Clean r -> return $ BCStop id r - -- force here might contains async exceptions from previous runs Running _step _s | memberStack id stack -> throw $ StackException stack | otherwise -> if rf == RunFirst diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 9f7b5bbf96..4a26c4b802 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -136,6 +136,9 @@ data Database = Database { } +shakeDataBaseQueue :: ShakeDatabase -> DBQue +shakeDataBaseQueue = databaseQueue . (\(ShakeDatabase _ _ db) -> db) + databaseGetActionQueueLength :: Database -> STM Int databaseGetActionQueueLength db = do counTaskQueue (databaseQueue db) From 70c56eaf40c5813122c05a7cc63c8e2cb320328c Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 9 Sep 2025 13:22:17 +0800 Subject: [PATCH 085/107] Revert "always wait for restart" This reverts commit 7bf6fde6f9c0535a1b77d8d2702014fd4a9ef809. --- .../session-loader/Development/IDE/Session.hs | 3 ++- ghcide/src/Development/IDE/Core/FileStore.hs | 14 ++++++++--- ghcide/src/Development/IDE/Core/Shake.hs | 25 +++++++++++-------- hls-plugin-api/src/Ide/Types.hs | 5 +++- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +-- .../src/Ide/Plugin/Eval/Handlers.hs | 6 ++--- scripts/flaky-test-patterns.txt | 4 +-- 7 files changed, 37 insertions(+), 24 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2d43724f3f..8255310f07 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -68,6 +68,7 @@ import Ide.Logger (Pretty (pretty), vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), + ShouldWait (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -625,7 +626,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , .. } sessionShake = SessionShake - { restartSession = restartShakeSession extras + { restartSession = restartShakeSession extras ShouldWait , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras } diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 0bdec3874e..c9fdec41c1 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -22,6 +22,7 @@ module Development.IDE.Core.FileStore( registerFileWatches, shareFilePath, Log(..), + setSomethingModifiedWait, ) where import Control.Concurrent.STM.Stats (STM, atomically) @@ -279,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do + restartShakeSession (shakeExtras state) ShouldNotWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) @@ -299,11 +300,16 @@ typecheckParentsAction recorder nfp = do -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified vfs state reason actionBetweenSession = do +setSomethingModified' :: ShouldWait -> VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified' shouldWait vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession + void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldNotWait vfs state reason actionBetweenSession + +setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f31074d7f5..29057e659d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -345,7 +345,8 @@ data ShakeExtras = ShakeExtras ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession - :: VFSModified + :: ShouldWait + -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] @@ -888,16 +889,18 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: ShakeControlQueue -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do - waitMVar <- newEmptyMVar - -- submit at the head of the queue, - -- prefer restart request over any pending actions - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] - -- Wait until the restart is done - takeMVar waitMVar - +shakeRestart :: ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart rts shouldWait vfs reason acts ioActionBetweenShakeSession = case shouldWait of + ShouldWait -> do + waitMVar <- newEmptyMVar + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] + -- Wait until the restart is done + takeMVar waitMVar + ShouldNotWait -> + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [] runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 314049b826..ccb622bb2c 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -42,7 +42,7 @@ module Ide.Types , installSigUsr1Handler , lookupCommandProvider , ResolveFunction -, mkResolveHandler +, mkResolveHandler, ShouldWait(..) ) where @@ -1302,3 +1302,6 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing resolve handlers for the same method, than our assumptions that we never have two responses break, and behavior is undefined. -} + +data ShouldWait = ShouldWait | ShouldNotWait + deriving Eq diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7a2c53ee25..f189fa2893 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) 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 1f19b5b476..7ec8b96c4f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,7 +41,7 @@ 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, setSomethingModified) +import Development.IDE.Core.FileStore (getUriContents, setSomethingModifiedWait) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) @@ -214,11 +214,11 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModified VFSUnmodified st "Eval" $ do + (setSomethingModifiedWait VFSUnmodified st "Eval" $ do queueForEvaluation st nfp return [toKey IsEvaluating nfp] ) - (setSomethingModified VFSUnmodified st "Eval" $ do + (setSomethingModifiedWait VFSUnmodified st "Eval" $ do unqueueForEvaluation st nfp return [toKey IsEvaluating nfp] ) diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt index f820cad42b..b08a8a6ede 100644 --- a/scripts/flaky-test-patterns.txt +++ b/scripts/flaky-test-patterns.txt @@ -4,7 +4,7 @@ # open close # non local variable # Notification Handlers -bidirectional module dependency with hs-boot +# bidirectional module dependency with hs-boot # InternalError over InvalidParams # ghcide restarts shake session on config changes: @@ -19,7 +19,7 @@ bidirectional module dependency with hs-boot # hls-class-plugin-tests::Creates a placeholder for fmap # hls-rename-plugin-tests::Rename # th-linking-test-unboxed -# update syntax error +update syntax error # iface-error-test-1 # update syntax error From 296c385ee050db9fd9649fd0089f5d6f8c1bd425 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 9 Sep 2025 14:25:21 +0800 Subject: [PATCH 086/107] refactor: enhance shakeRestart to use versioning for session management --- ghcide/src/Development/IDE/Core/Shake.hs | 60 +++++++++++++++--------- 1 file changed, 38 insertions(+), 22 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 29057e659d..7fe9996c24 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -725,7 +725,8 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets - let restartShakeSession = shakeRestart shakeControlQueue + restartVersion <- newTVarIO 0 + let restartShakeSession = shakeRestart restartVersion shakeControlQueue persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -867,6 +868,7 @@ data ShakeRestartArgs = ShakeRestartArgs , sraCount :: !Int -- ^ Just for debugging, how many restarts have been requested so far , sraWaitMVars :: ![MVar ()] + , sraVersion :: !Int } instance Show ShakeRestartArgs where @@ -877,30 +879,39 @@ instance Show ShakeRestartArgs where ++ " }" instance Semigroup ShakeRestartArgs where - a <> b = ShakeRestartArgs - { sraVfs = sraVfs a <> sraVfs b - , sraReason = sraReason a ++ "; " ++ sraReason b - , sraActions = sraActions a ++ sraActions b - , sraBetweenSessions = (++) <$> sraBetweenSessions a <*> sraBetweenSessions b - , sraCount = sraCount a + sraCount b - , sraWaitMVars = sraWaitMVars a ++ sraWaitMVars b + a <> b = + -- the larger the version, the later it was requested + -- prefer the later one + let (new, old) = if sraVersion a >= sraVersion b then (a, b) else (b, a) + in ShakeRestartArgs + { sraVfs = sraVfs old <> sraVfs new + , sraReason = sraReason old ++ "; " ++ sraReason new + , sraActions = sraActions old ++ sraActions new + , sraBetweenSessions = (++) <$> sraBetweenSessions old <*> sraBetweenSessions new + , sraCount = sraCount old + sraCount new + , sraWaitMVars = sraWaitMVars old ++ sraWaitMVars new + , sraVersion = sraVersion new } -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart rts shouldWait vfs reason acts ioActionBetweenShakeSession = case shouldWait of - ShouldWait -> do - waitMVar <- newEmptyMVar - -- submit at the head of the queue, - -- prefer restart request over any pending actions - void $ submitWorkAtHead rts $ Left $ toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] - -- Wait until the restart is done - takeMVar waitMVar - ShouldNotWait -> - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [] +shakeRestart :: TVar Int -> ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart version rts shouldWait vfs reason acts ioActionBetweenShakeSession = do + v <- atomically $ do + modifyTVar' version (+1) + readTVar version + case shouldWait of + ShouldWait -> do + waitMVar <- newEmptyMVar + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] v + -- Wait until the restart is done + takeMVar waitMVar + ShouldNotWait -> + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [] v runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) @@ -919,7 +930,6 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - sleep 0.2 -- Check if there is another restart request pending, if so, we run that one too readAndGo sra readAndGo sra = do @@ -928,7 +938,13 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do Nothing -> return sra Just (Left dy) -> do res <- prepareRestart $ dynShakeRestart dy - return $ sra <> res + -- final check + -- if still something pending, we go again + sleep 0.2 + b <- atomically $ isEmptyTaskQueue shakeControlQueue + if b + then return $ sra <> res + else readAndGo $ sra <> res Just (Right _) -> readAndGo sra withMVar' shakeSession From c207e5d0051cd856cb80c6cd5aebec6d43c085f6 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Tue, 9 Sep 2025 14:31:15 +0800 Subject: [PATCH 087/107] refactor: improve restart task handling with final check for pending requests --- ghcide/src/Development/IDE/Core/Shake.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7fe9996c24..f6e49938f1 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -931,21 +931,23 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys -- Check if there is another restart request pending, if so, we run that one too - readAndGo sra + readAndGo sra >>= finalCheck readAndGo sra = do nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue case nextRestartArg of Nothing -> return sra Just (Left dy) -> do res <- prepareRestart $ dynShakeRestart dy - -- final check - -- if still something pending, we go again - sleep 0.2 - b <- atomically $ isEmptyTaskQueue shakeControlQueue - if b - then return $ sra <> res - else readAndGo $ sra <> res + return $ sra <> res Just (Right _) -> readAndGo sra + finalCheck sra = do + -- final check + sleep 0.2 + b <- atomically $ isEmptyTaskQueue shakeControlQueue + if b + then return sra + -- there is something new, read and go again + else readAndGo sra withMVar' shakeSession ( \runner -> do @@ -974,7 +976,6 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) - -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. -- Assumes a 'ShakeSession' is available. From e26c066d3f5cee70ea678699756d93cdf72d3d5d Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 10 Sep 2025 08:20:12 +0800 Subject: [PATCH 088/107] before finer cleanup --- ghcide/src/Development/IDE/Core/FileStore.hs | 4 +- ghcide/src/Development/IDE/Core/Shake.hs | 34 +++-- .../src/Development/IDE/Graph/Database.hs | 8 +- .../Development/IDE/Graph/Internal/Action.hs | 12 +- .../IDE/Graph/Internal/Database.hs | 92 +++++++++--- .../src/Development/IDE/Graph/Internal/Key.hs | 5 + .../Development/IDE/Graph/Internal/Types.hs | 131 +++++++++++++++--- hls-graph/src/Development/IDE/WorkerThread.hs | 15 +- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +- scripts/flaky-test-patterns.txt | 33 +++-- 10 files changed, 259 insertions(+), 79 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index c9fdec41c1..3009f48e1f 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -280,7 +280,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) ShouldNotWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do + restartShakeSession (shakeExtras state) ShouldWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) @@ -306,7 +306,7 @@ setSomethingModified' shouldWait vfs state reason actionBetweenSession = do atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldNotWait vfs state reason actionBetweenSession +setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO () setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f6e49938f1..8b28100de4 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -134,6 +134,7 @@ import qualified Language.LSP.Server as LSP import Data.Either (isRight, lefts) import Data.Int (Int64) import Data.IORef.Extra (atomicModifyIORef'_) +import Data.Set (Set) import Development.IDE.Core.Tracing import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, @@ -154,8 +155,11 @@ import Development.IDE.Graph.Database (ShakeDatabase, import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) import Development.IDE.Graph.Internal.Types (DBQue, Step (..), + getShakeQueue, getShakeStep, - shakeDataBaseQueue) + lockShakeDatabaseValues, + shakeDataBaseQueue, + unlockShakeDatabaseValues) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -573,7 +577,7 @@ type IdeRule k v = -- | A live Shake session with the ability to enqueue Actions for running. -- Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database. newtype ShakeSession = ShakeSession - { cancelShakeSession :: IO () + { cancelShakeSession :: Set (Async ()) -> IO () -- ^ Closes the Shake session } @@ -726,7 +730,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets restartVersion <- newTVarIO 0 - let restartShakeSession = shakeRestart restartVersion shakeControlQueue + let restartShakeSession = shakeRestart restartVersion shakeDb persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -830,7 +834,7 @@ shakeShut IdeState{..} = do runner <- tryReadMVar shakeSession -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - for_ runner cancelShakeSession + for_ runner (flip cancelShakeSession mempty) void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras progressStop $ indexProgressReporting $ hiedbWriter shakeExtras @@ -896,8 +900,10 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: TVar Int -> ShakeControlQueue -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart version rts shouldWait vfs reason acts ioActionBetweenShakeSession = do +shakeRestart :: TVar Int -> ShakeDatabase -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart version db shouldWait vfs reason acts ioActionBetweenShakeSession = do + lockShakeDatabaseValues db + let rts = getShakeQueue db v <- atomically $ do modifyTVar' version (+1) readTVar version @@ -921,6 +927,9 @@ dynShakeRestart dy = case fromDynamic dy of Just shakeRestartArgs -> shakeRestartArgs Nothing -> error "Internal error, dynShakeRestart, got invalid dynamic type" +computePreserveAsyncs :: ShakeDatabase -> Set (Async ()) +computePreserveAsyncs shakeDb = mempty + runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar @@ -942,7 +951,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do Just (Right _) -> readAndGo sra finalCheck sra = do -- final check - sleep 0.2 + -- sleep 0.2 b <- atomically $ isEmptyTaskQueue shakeControlQueue if b then return sra @@ -952,7 +961,8 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do shakeSession ( \runner -> do -- takeShakeLock shakeDb - (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + let preserveAsyncs = computePreserveAsyncs shakeDb + (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner preserveAsyncs restartArgs <- prepareRestart shakeRestartArgs queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras res <- shakeDatabaseProfile shakeDb @@ -968,7 +978,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do ( \(ShakeRestartArgs {..}) -> do (,()) <$> newSession recorder shakeExtras sraVfs shakeDb sraActions sraReason - `finally` for_ sraWaitMVars (`putMVar` ()) + `finally` (for_ sraWaitMVars (`putMVar` ()) >> unlockShakeDatabaseValues shakeDb) ) where logErrorAfter :: Seconds -> IO () -> IO () @@ -1076,12 +1086,12 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do -- Cancelling is required to flush the Shake database when either -- the filesystem or the Ghc configuration have changed - let cancelShakeSession :: IO () - cancelShakeSession = do + let cancelShakeSession :: Set (Async ()) -> IO () + cancelShakeSession preserve = do logWith recorder Info $ LogShakeText ("Starting shake cancellation: " <> " (" <> T.pack (show reason) <> ")") tid <- myThreadId cancelWith workThread $ AsyncParentKill tid step - shakeShutDatabase shakeDb + shakeShutDatabase preserve shakeDb -- should wait until the step has increased pure (ShakeSession{..}) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 18b2ff026a..87612bf672 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -13,12 +13,14 @@ module Development.IDE.Graph.Database( ,shakeGetBuildEdges, shakeShutDatabase, shakeGetActionQueueLength) where +import Control.Concurrent.Async (Async) import Control.Concurrent.STM.Stats (atomically, readTVarIO) import Control.Exception (SomeException) import Control.Monad (join) import Data.Dynamic import Data.Maybe +import Data.Set (Set) import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database @@ -32,8 +34,8 @@ import Development.IDE.Graph.Internal.Types -- Placeholder to be the 'extra' if the user doesn't set it data NonExportedType = NonExportedType -shakeShutDatabase :: ShakeDatabase -> IO () -shakeShutDatabase (ShakeDatabase _ _ db) = shutDatabase db +shakeShutDatabase :: Set (Async ()) -> ShakeDatabase -> IO () +shakeShutDatabase preserve (ShakeDatabase _ _ db) = shutDatabase preserve db shakeNewDatabase :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase shakeNewDatabase que opts rules = do @@ -71,7 +73,7 @@ shakeRunDatabaseForKeysSep -> IO (IO [Either SomeException a]) shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged - return $ drop lenAs1 <$> runActions db (map unvoid as1 ++ as2) + return $ drop lenAs1 <$> runActions (newKey "root") db (map unvoid as1 ++ as2) shakeRunDatabaseForKeys :: Maybe [Key] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 8624c490e8..cd8cd67f41 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -120,7 +120,8 @@ apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) apply ks = do db <- Action $ asks actionDatabase stack <- Action $ asks actionStack - (is, vs) <- liftIO $ build db stack ks + pk <- getActionKey + (is, vs) <- liftIO $ build pk db stack ks ref <- Action $ asks actionDeps let !ks = force $ fromListKeySet $ toList is liftIO $ modifyIORef' ref (ResultDeps [ks] <>) @@ -131,13 +132,14 @@ applyWithoutDependency :: (Traversable f, RuleResult key ~ value, ShakeValue key applyWithoutDependency ks = do db <- Action $ asks actionDatabase stack <- Action $ asks actionStack - (_, vs) <- liftIO $ build db stack ks + pk <- getActionKey + (_, vs) <- liftIO $ build pk db stack ks pure vs -runActions :: Database -> [Action a] -> IO [Either SomeException a] -runActions db xs = do +runActions :: Key -> Database -> [Action a] -> IO [Either SomeException a] +runActions pk db xs = do deps <- newIORef mempty - runReaderT (fromAction $ parallel xs) $ SAction db deps emptyStack + runReaderT (fromAction $ parallel xs) $ SAction pk db deps emptyStack -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Action [(Key, Int)] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index dba43b03c8..2fb5bf9a0b 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -12,11 +12,12 @@ module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabas import Prelude hiding (unzip) -import Control.Concurrent.STM.Stats (STM, atomically, - atomicallyNamed, - modifyTVar', newTVarIO, - readTVar, readTVarIO, - retry) +import Control.Concurrent.STM.Stats (STM, atomicallyNamed, + check, modifyTVar', + newEmptyTMVarIO, + newTVarIO, putTMVar, + readTMVar, readTVar, + readTVarIO, retry) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -38,6 +39,7 @@ import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap import System.Time.Extra (duration) +import UnliftIO (async, atomically) #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) @@ -50,7 +52,9 @@ newDatabase :: DBQue -> Dynamic -> TheRules -> IO Database newDatabase databaseQueue databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 databaseThreads <- newTVarIO [] + databaseValuesLock <- newTVarIO False databaseValues <- atomically SMap.new + databaseReverseDep <- atomically SMap.new pure Database{..} -- | Increment the step and mark dirty. @@ -76,16 +80,16 @@ incDatabase db Nothing = do updateDirty :: Monad m => Focus.Focus KeyDetails m () updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> let status' - | Running _ x <- status = Dirty x + | Running _ x _ <- status = Dirty x | Clean x <- status = Dirty (Just x) | otherwise = status in KeyDetails status' rdeps -- | Unwrap and build a list of keys in parallel build :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) - => Database -> Stack -> f key -> IO (f Key, f value) + => Key -> Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined -build db stack keys = do +build pk db stack keys = do step <- readTVarIO $ databaseStep db go `catch` \e@(AsyncParentKill i s) -> do if s == step @@ -95,7 +99,7 @@ build db stack keys = do go = do -- step <- readTVarIO $ databaseStep db -- built <- mapConcurrently (builderOne db stack) (fmap newKey keys) - built <- builder db stack (fmap newKey keys) + built <- builder pk db stack (fmap newKey keys) let (ids, vs) = unzip built pure (ids, fmap (asV . resultValue) vs) where @@ -106,10 +110,10 @@ build db stack keys = do -- | Build a list of keys and return their results. -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. -builder :: (Traversable f) => Database -> Stack -> f Key -> IO (f (Key, Result)) +builder :: (Traversable f) => Key -> Database -> Stack -> f Key -> IO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined -builder db stack keys = do - waits <- for keys (\k -> builderOneCoroutine skipThread db stack k) +builder pk db stack keys = do + waits <- for keys (\k -> builderOneCoroutine pk skipThread db stack k) for waits interpreBuildContinue where skipThread = if length keys == 1 then IsSingleton else NotSingleton @@ -122,8 +126,41 @@ interpreBuildContinue :: BuildContinue -> IO (Key, Result) interpreBuildContinue (BCStop k v) = return (k, v) interpreBuildContinue (BCContinue ioR) = ioR >>= interpreBuildContinue -builderOneCoroutine :: IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue -builderOneCoroutine isSingletonTask db stack id = +-- possible improvements: +-- suppose it is in the direct dirty set. We have already recorded the parent key as its reverse dep. +-- fource possible situation +-- running stage1, we have line up the run but it is scheduled after the restart. Clean. +-- running stage2, all of it have gone before the restart. Dirty +-- clean or exception, we picked old value. Dirty +-- dirty, impossible situation, should throw errors. + +-- stage 1 to stage 2 transition, run in serial + +-- first we marked we have reached stage2, annotate the current step +-- then spawn the thread to do the actual work +-- finally, catch any (async) exception and mark the key as exception + +-- submmittBuildInDb :: Database -> IO a -> IO a +submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO () +submmittBuildInDb db stack id s = do + uninterruptibleMask_ $ do + do + curStep <- readTVarIO $ databaseStep db + startBarrier <- newEmptyTMVarIO + newAsync <- + async + (do + uninterruptibleMask_ $ atomically $ readTMVar startBarrier + void (refresh db stack id s) `catch` \e@(SomeException _) -> + atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db) + ) + -- todo should only update if still at stage 1 + atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) + atomically $ putTMVar startBarrier () + atomically $ modifyTVar' (databaseThreads db) (newAsync :) + +builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue +builderOneCoroutine parentKey isSingletonTask db stack id = builderOneCoroutine' RunFirst isSingletonTask db stack id where builderOneCoroutine' :: RunFirst -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue @@ -131,11 +168,18 @@ builderOneCoroutine isSingletonTask db stack id = traceEvent ("builderOne: " ++ show id) return () liftIO $ atomicallyNamed "builder" $ do -- Spawn the id if needed + void $ check <$> readTVar databaseValuesLock + + insertDatabaseReverseDepOne id parentKey db + + -- if a build is running, wait + -- it will either be killed or continue + -- depending on wether it is marked as dirty status <- SMap.lookup id databaseValues current <- readTVar databaseStep case viewDirty current $ maybe (Dirty Nothing) keyStatus status of Dirty s -> do - SMap.focus (updateStatus $ Running current s) id databaseValues + SMap.focus (updateStatus $ Running current s RunningStage1) id databaseValues case isSingletonTask of IsSingleton -> return $ @@ -145,11 +189,15 @@ builderOneCoroutine isSingletonTask db stack id = throw e NotSingleton -> do traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) $ - runOneInDataBase (show id) db (refresh db stack id s) $ + -- we need to run serially to avoid summiting run but killed in the middle + runOneInDataBase (show id) db (do + refresh db stack id s + ) $ + -- we might want it to be able to be killed since we might want to preserve the database \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id Clean r -> return $ BCStop id r - Running _step _s + Running _step _s _ | memberStack id stack -> throw $ StackException stack | otherwise -> if rf == RunFirst then return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id @@ -174,7 +222,7 @@ refreshDeps visited db stack key result = \case [] -> compute db stack key RunDependenciesSame (Just result) (dep:deps) -> do let newVisited = dep <> visited - res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) + res <- builder key db stack (toListKeySet (dep `differenceKeySet` visited)) if isDirty result res -- restart the computation if any of the deps are dirty then compute db stack key RunDependenciesChanged (Just result) @@ -196,7 +244,7 @@ compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode deps <- liftIO $ newIORef UnknownDeps (execution, RunResult{..}) <- - liftIO $ duration $ runReaderT (fromAction act) $ SAction db deps stack + liftIO $ duration $ runReaderT (fromAction act) $ SAction key db deps stack curStep <- liftIO $ readTVarIO databaseStep deps <- liftIO $ readIORef deps let lastChanged = maybe curStep resultChanged result @@ -227,6 +275,7 @@ compute db@Database{..} stack key mode result = do deps _ -> pure () liftIO $ atomicallyNamed "compute and run hook" $ do + void $ check <$> readTVar databaseValuesLock runHook SMap.focus (updateStatus $ Clean res) key databaseValues pure res @@ -236,6 +285,11 @@ updateStatus res = Focus.alter (Just . maybe (KeyDetails res mempty) (\it -> it{keyStatus = res})) +-- alterStatus :: Monad m => (Status -> Status) -> Focus.Focus KeyDetails m () +-- alterStatus f = Focus.alter +-- (Just . maybe (KeyDetails res mempty) +-- (\it -> it{keyStatus = res})) + -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index 85cebeb110..0b162060d7 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -31,6 +31,7 @@ module Development.IDE.Graph.Internal.Key , fromListKeySet , deleteKeySet , differenceKeySet + , unionKyeSet ) where --import Control.Monad.IO.Class () @@ -131,6 +132,10 @@ nullKeySet = coerce IS.null differenceKeySet :: KeySet -> KeySet -> KeySet differenceKeySet = coerce IS.difference + +unionKyeSet :: KeySet -> KeySet -> KeySet +unionKyeSet = coerce IS.union + deleteKeySet :: Key -> KeySet -> KeySet deleteKeySet = coerce IS.delete diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 4a26c4b802..b264247de0 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -7,7 +7,8 @@ module Development.IDE.Graph.Internal.Types where import Control.Concurrent.STM (STM, modifyTVar') -import Control.Monad (forever, unless) +import Control.Monad (forM, forM_, forever, + unless) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -20,13 +21,18 @@ import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List (intercalate) import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S import Data.Typeable import Debug.Trace (traceEventIO, traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.WorkerThread (DeliverStatus (..), - TaskQueue, counTaskQueue, + TaskQueue, + awaitRunInThread, + counTaskQueue, runInThreadStmInNewThreads) +import qualified Focus import GHC.Conc (TVar, atomically) import GHC.Generics (Generic) import qualified ListT @@ -83,6 +89,7 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a} deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO) data SAction = SAction { + actionKey :: !Key, actionDatabase :: !Database, actionDeps :: !(IORef ResultDeps), actionStack :: !Stack @@ -91,6 +98,10 @@ data SAction = SAction { getDatabase :: Action Database getDatabase = Action $ asks actionDatabase +getActionKey :: Action Key +getActionKey = Action $ asks actionKey + + -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. -- waitForDatabaseRunningKeysAction :: Action () -- waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys @@ -109,6 +120,16 @@ getShakeStep (ShakeDatabase _ _ db) = do s <- readTVarIO $ databaseStep db return s +lockShakeDatabaseValues :: MonadIO m => ShakeDatabase -> m () +lockShakeDatabaseValues (ShakeDatabase _ _ db) = do + liftIO $ atomically $ modifyTVar' (databaseValuesLock db) (const False) + +unlockShakeDatabaseValues :: MonadIO m => ShakeDatabase -> m () +unlockShakeDatabaseValues (ShakeDatabase _ _ db) = do + liftIO $ atomically $ modifyTVar' (databaseValuesLock db) (const True) + +getShakeQueue :: ShakeDatabase -> DBQue +getShakeQueue (ShakeDatabase _ _ db) = databaseQueue db --------------------------------------------------------------------- -- Keys newtype Value = Value Dynamic @@ -125,17 +146,87 @@ onKeyReverseDeps f it@KeyDetails{..} = type DBQue = TaskQueue (Either Dynamic (IO ())) data Database = Database { - databaseExtra :: Dynamic, + databaseExtra :: Dynamic, - databaseThreads :: TVar [Async ()], - databaseQueue :: DBQue, + databaseThreads :: TVar [Async ()], + + databaseReverseDep :: SMap.Map Key KeySet, + -- For each key, the set of keys that depend on it directly. + + -- it is used to compute the transitive reverse deps, so + -- if not in any of the transitive reverse deps of a dirty node, it is clean + -- we can skip clean the threads. + -- this is update right before we query the database for the key result. - databaseRules :: TheRules, - databaseStep :: !(TVar Step), - databaseValues :: !(Map Key KeyDetails) - } + databaseQueue :: DBQue, + + databaseRules :: TheRules, + databaseStep :: !(TVar Step), + + databaseValuesLock :: !(TVar Bool), + -- when we restart a build, we set this to False to block any other + -- threads from reading databaseValues + databaseValues :: !(Map Key KeyDetails) + + } +--------------------------------------------------------------------- +-- compute clean running asyncs +-- clean running asyncs are those runnings keys at stage 2 that are not +-- at reverse dependency of any dirty keys + +-- we also need to update not dirty running keys to a new step +-- for stage 1 non-dirty keys, since its computing thread is not started, +-- we can just update its step to the new step +-- for stage 2 non-dirty keys, we need to cancel its computing thread +computeCleanRunningAsyncs :: Database -> KeySet -> STM [Async ()] +computeCleanRunningAsyncs db dirtySet = do + -- All keys that depend (directly or transitively) on any dirty key + affected <- computeTransitiveReverseDeps db dirtySet + -- Running stage-2 keys are eligible to be considered for cleanup + running <- getRunningStage2Keys db + -- Keep only those whose key is NOT affected by the dirty set + pure [async | (k, async) <- running, not (memberKeySet k affected)] + +getRunningStage2Keys :: Database -> STM [(Key, Async ())] +getRunningStage2Keys db = do + pairs <- ListT.toList $ SMap.listT (databaseValues db) + return [(k, async) | (k, v) <- pairs, Running _ _ (RunningStage2 async) <- [keyStatus v]] + +-- compute the transitive reverse dependencies of a set of keys +-- using databaseReverseDep in the Database +computeTransitiveReverseDeps :: Database -> KeySet -> STM KeySet +computeTransitiveReverseDeps db seeds = do + let rev = databaseReverseDep db + + -- BFS worklist starting from all seed keys. + -- visited contains everything we've already enqueued (including seeds). + go :: KeySet -> [Key] -> STM KeySet + go visited [] = pure visited + go visited (k:todo) = do + mDeps <- SMap.lookup k rev + case mDeps of + Nothing -> go visited todo + Just direct -> + -- new keys = direct dependents not seen before + let newKs = filter (\x -> not (memberKeySet x visited)) (toListKeySet direct) + visited' = foldr insertKeySet visited newKs + in go visited' (newKs ++ todo) + + -- Start with seeds already marked visited to prevent self-revisit. + go seeds (toListKeySet seeds) + + + +insertDatabaseReverseDepOne :: Key -> Key -> Database -> STM () +insertDatabaseReverseDepOne k a db = do + SMap.focus (Focus.alter (Just . maybe mempty (insertKeySet a))) k (databaseReverseDep db) + + +awaitRunInDb :: Database -> IO result -> IO result +awaitRunInDb db act = awaitRunInThread (databaseQueue db) act + shakeDataBaseQueue :: ShakeDatabase -> DBQue shakeDataBaseQueue = databaseQueue . (\(ShakeDatabase _ _ db) -> db) @@ -176,15 +267,17 @@ instance Exception AsyncParentKill where toException = asyncExceptionToException fromException = asyncExceptionFromException -shutDatabase :: Database -> IO () -shutDatabase Database{..} = uninterruptibleMask $ \unmask -> do +shutDatabase ::Set (Async ()) -> Database -> IO () +shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do -- wait for all threads to finish asyncs <- readTVarIO databaseThreads step <- readTVarIO databaseStep tid <- myThreadId traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step) - mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) asyncs - atomically $ modifyTVar' databaseThreads (const []) + let remains = filter (`S.member` preserve) asyncs + let toCancel = filter (`S.notMember` preserve) asyncs + mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) toCancel + atomically $ modifyTVar' databaseThreads (const remains) -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr unless (null asyncs) $ do @@ -204,26 +297,28 @@ getDatabaseValues = atomically . SMap.listT . databaseValues +data RunningStage = RunningStage1 | RunningStage2 (Async ()) + deriving (Eq, Ord) data Status = Clean !Result | Dirty (Maybe Result) | Exception !Step !SomeException !(Maybe Result) | Running { - runningStep :: !Step, - -- runningWait :: !(IO ()), + runningStep :: !Step, -- runningResult :: Result, -- LAZY - runningPrev :: !(Maybe Result) + runningPrev :: !(Maybe Result), + runningStage :: !RunningStage } viewDirty :: Step -> Status -> Status -viewDirty currentStep (Running s re) | currentStep /= s = Dirty re +viewDirty currentStep (Running s re _) | currentStep /= s = Dirty re viewDirty currentStep (Exception s _ re) | currentStep /= s = Dirty re viewDirty _ other = other getResult :: Status -> Maybe Result getResult (Clean re) = Just re getResult (Dirty m_re) = m_re -getResult (Running _ m_re) = m_re -- watch out: this returns the previous result +getResult (Running _ m_re _) = m_re -- watch out: this returns the previous result getResult (Exception _ _ m_re) = m_re -- waitRunning :: Status -> IO () diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index d2cec4b837..b4832e0d77 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -25,7 +25,8 @@ module Development.IDE.WorkerThread Worker, tryReadTaskQueue, withWorkerQueueSimpleRight, - submitWorkAtHead + submitWorkAtHead, + awaitRunInThread ) where import Control.Concurrent.Async (Async, async, withAsync) @@ -154,6 +155,18 @@ eitherWorker w1 w2 = \case Left a -> w1 a Right b -> w2 b +awaitRunInThread :: TaskQueue (Either Dynamic (IO ())) -> IO result -> IO result +awaitRunInThread (TaskQueue q) act = do + barrier <- newEmptyTMVarIO + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + atomically $ writeTQueue q (Right $ try act >>= atomically . putTMVar barrier) + resultOrException <- atomically $ takeTMVar barrier + case resultOrException of + Left e -> throw (e :: SomeException) + Right r -> return r + + -- submitWork without waiting for the result submitWork :: TaskQueue arg -> arg -> IO () submitWork (TaskQueue q) arg = atomically $ writeTQueue q arg diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index f189fa2893..353fba819c 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldNotWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras ShouldWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt index b08a8a6ede..337b454ffc 100644 --- a/scripts/flaky-test-patterns.txt +++ b/scripts/flaky-test-patterns.txt @@ -1,28 +1,27 @@ # One tasty pattern per line. Lines starting with # are comments. # Blank lines are ignored. -# open close -# non local variable -# Notification Handlers -# bidirectional module dependency with hs-boot +iface-error-test-1 +open close +non local variable +Notification Handlers +bidirectional module dependency with hs-boot -# InternalError over InvalidParams +InternalError over InvalidParams # ghcide restarts shake session on config changes: -# addDependentFile +addDependentFile # Another interesting one you can try: # func-test::sends indefinite progress notifications -# hls-pragmas-plugin-tests::/inline: RULES/ +hls-pragmas-plugin-tests::/inline: RULES/ # hls-graph cancel leaks asynchronous exception to the next session -# hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics -# hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps -# hls-class-plugin-tests::Creates a placeholder for fmap -# hls-rename-plugin-tests::Rename -# th-linking-test-unboxed +hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics +hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps +hls-class-plugin-tests::Creates a placeholder for fmap +hls-rename-plugin-tests::Rename +th-linking-test-unboxed update syntax error -# iface-error-test-1 -# update syntax error -# retry failed -# th-linking-test -# are deleted from the state +retry failed +th-linking-test +are deleted from the state From 09890e789e65eda3180aa2a443f1f20d2e4e8a28 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 10 Sep 2025 13:40:04 +0800 Subject: [PATCH 089/107] Reapply "always wait for restart" This reverts commit 70c56eaf40c5813122c05a7cc63c8e2cb320328c. --- .../session-loader/Development/IDE/Session.hs | 3 +-- ghcide/src/Development/IDE/Core/FileStore.hs | 14 +++------- ghcide/src/Development/IDE/Core/Shake.hs | 27 +++++++++---------- hls-plugin-api/src/Ide/Types.hs | 5 +--- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 4 +-- .../src/Ide/Plugin/Eval/Handlers.hs | 6 ++--- scripts/flaky-test-patterns.txt | 4 +++ 7 files changed, 27 insertions(+), 36 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8255310f07..2d43724f3f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -68,7 +68,6 @@ import Ide.Logger (Pretty (pretty), vcat, viaShow, (<+>)) import Ide.Types (Config, SessionLoadingPreferenceConfig (..), - ShouldWait (..), sessionLoading) import Language.LSP.Protocol.Message import Language.LSP.Server @@ -626,7 +625,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , .. } sessionShake = SessionShake - { restartSession = restartShakeSession extras ShouldWait + { restartSession = restartShakeSession extras , invalidateCache = invalidateShakeCache , enqueueActions = shakeEnqueue extras } diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 3009f48e1f..0bdec3874e 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -22,7 +22,6 @@ module Development.IDE.Core.FileStore( registerFileWatches, shareFilePath, Log(..), - setSomethingModifiedWait, ) where import Control.Concurrent.STM.Stats (STM, atomically) @@ -280,7 +279,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) ShouldWait vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") ([mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) | checkParents]) $ do keys<-actionBefore return (toKey GetModificationTime nfp:keys) @@ -300,16 +299,11 @@ typecheckParentsAction recorder nfp = do -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified' :: ShouldWait -> VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified' shouldWait vfs state reason actionBetweenSession = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - void $ restartShakeSession (shakeExtras state) shouldWait vfs reason [] actionBetweenSession -setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModified vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession - -setSomethingModifiedWait :: VFSModified -> IdeState -> String -> IO [Key] -> IO () -setSomethingModifiedWait vfs state reason actionBetweenSession = setSomethingModified' ShouldWait vfs state reason actionBetweenSession + void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 8b28100de4..e1108e7ea6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -349,8 +349,7 @@ data ShakeExtras = ShakeExtras ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession - :: ShouldWait - -> VFSModified + :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] @@ -900,24 +899,22 @@ instance Semigroup ShakeRestartArgs where -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: TVar Int -> ShakeDatabase -> ShouldWait -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart version db shouldWait vfs reason acts ioActionBetweenShakeSession = do +shakeRestart :: TVar Int -> ShakeDatabase -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart version db vfs reason acts ioActionBetweenShakeSession = do lockShakeDatabaseValues db let rts = getShakeQueue db v <- atomically $ do modifyTVar' version (+1) readTVar version - case shouldWait of - ShouldWait -> do - waitMVar <- newEmptyMVar - -- submit at the head of the queue, - -- prefer restart request over any pending actions - void $ submitWorkAtHead rts $ Left $ toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] v - -- Wait until the restart is done - takeMVar waitMVar - ShouldNotWait -> - void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [] v + let rts = shakeDataBaseQueue db + waitMVar <- newEmptyMVar + -- submit at the head of the queue, + -- prefer restart request over any pending actions + void $ submitWorkAtHead rts $ Left $ + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] + -- Wait until the restart is done + takeMVar waitMVar + runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO () runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ccb622bb2c..314049b826 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -42,7 +42,7 @@ module Ide.Types , installSigUsr1Handler , lookupCommandProvider , ResolveFunction -, mkResolveHandler, ShouldWait(..) +, mkResolveHandler ) where @@ -1302,6 +1302,3 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing resolve handlers for the same method, than our assumptions that we never have two responses break, and behavior is undefined. -} - -data ShouldWait = ShouldWait | ShouldNotWait - deriving Eq diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 353fba819c..7a2c53ee25 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -179,7 +179,7 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:keys) @@ -188,7 +188,7 @@ restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = d -- rule to get re-run if the file changes on disk. restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras ShouldWait (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) 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 7ec8b96c4f..1f19b5b476 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,7 +41,7 @@ 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, setSomethingModifiedWait) +import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) @@ -214,11 +214,11 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModifiedWait VFSUnmodified st "Eval" $ do + (setSomethingModified VFSUnmodified st "Eval" $ do queueForEvaluation st nfp return [toKey IsEvaluating nfp] ) - (setSomethingModifiedWait VFSUnmodified st "Eval" $ do + (setSomethingModified VFSUnmodified st "Eval" $ do unqueueForEvaluation st nfp return [toKey IsEvaluating nfp] ) diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt index 337b454ffc..065394835c 100644 --- a/scripts/flaky-test-patterns.txt +++ b/scripts/flaky-test-patterns.txt @@ -1,6 +1,10 @@ # One tasty pattern per line. Lines starting with # are comments. # Blank lines are ignored. +# open close +# non local variable +# Notification Handlers +bidirectional module dependency with hs-boot iface-error-test-1 open close non local variable From eebf706b2e350d8f70008d56dd8d5e938bfddbfa Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 11 Sep 2025 13:38:15 +0800 Subject: [PATCH 090/107] fix stuck --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e1108e7ea6..ad180ad70a 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -911,7 +911,7 @@ shakeRestart version db vfs reason acts ioActionBetweenShakeSession = do -- submit at the head of the queue, -- prefer restart request over any pending actions void $ submitWorkAtHead rts $ Left $ - toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] + toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession 1 [waitMVar] v -- Wait until the restart is done takeMVar waitMVar From 2c771e111dc4a026414fd7b6e6c1cf1e5c3b1b77 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 11 Sep 2025 15:44:28 +0800 Subject: [PATCH 091/107] fix session loader: mask_ to prevent swallow async exception --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- ghcide/session-loader/Development/IDE/Session/Ghc.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2d43724f3f..5de220dd39 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -852,7 +852,7 @@ packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do rootDir <- asks sessionRootDir -- Parse DynFlags for the newly discovered component hscEnv <- newEmptyHscEnv - newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir + newTargetDfs <- liftIO $ mask_ $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps) -- Now lookup to see whether we are combining with an existing HscEnv diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index 7a84263ec9..76db75fabe 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -43,7 +43,7 @@ import System.Info import Control.DeepSeq -import Control.Exception (evaluate) +import Control.Exception (evaluate, mask_) import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Data.Set as OS import qualified Development.IDE.GHC.Compat.Util as Compat @@ -433,7 +433,7 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do -- We call setSessionDynFlags so that the loader is initialised -- We need to do this before we call initUnits. - env <- liftIO $ runGhc (Just libDir) $ + env <- mask_ $ liftIO $ runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) From 09905ba4062b07f46b1d5f13328c08eb3aa113fb Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 10:09:28 +0800 Subject: [PATCH 092/107] attempt to kill less thread --- ghcide/src/Development/IDE/Core/Shake.hs | 71 +++++++++------ .../src/Development/IDE/LSP/LanguageServer.hs | 5 +- .../src/Development/IDE/Graph/Database.hs | 26 +++++- .../IDE/Graph/Internal/Database.hs | 69 +++++++------- .../src/Development/IDE/Graph/Internal/Key.hs | 8 ++ .../Development/IDE/Graph/Internal/Types.hs | 91 +++++++++++++------ hls-graph/src/Development/IDE/WorkerThread.hs | 9 +- scripts/flaky-test-patterns.txt | 18 ++-- 8 files changed, 190 insertions(+), 107 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index ad180ad70a..928a3ee03e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -135,6 +135,7 @@ import Data.Either (isRight, lefts) import Data.Int (Int64) import Data.IORef.Extra (atomicModifyIORef'_) import Data.Set (Set) +import qualified Data.Set as S import Development.IDE.Core.Tracing import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater, @@ -145,6 +146,8 @@ import Development.IDE.Graph hiding (ShakeValue, action) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, + shakeComputeToPreserve, + shakeDatabaseReverseDep, shakeGetActionQueueLength, shakeGetBuildStep, shakeGetDatabaseKeys, @@ -159,7 +162,8 @@ import Development.IDE.Graph.Internal.Types (DBQue, Step (..), getShakeStep, lockShakeDatabaseValues, shakeDataBaseQueue, - unlockShakeDatabaseValues) + unlockShakeDatabaseValues, + withShakeDatabaseValuesLock) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -219,10 +223,19 @@ data Log | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] | LogShakeText !T.Text | LogMonitering !T.Text !Int64 + | LogPreserveKeys ![Key] ![Key] ![Key] ![(Key, KeySet)] deriving Show instance Pretty Log where pretty = \case + LogPreserveKeys kvs ks allRunnings reverseKs -> + vcat [ + "LogPreserveKeys" + , "dirty keys:" <+> pretty (map show ks) + , "Preserving keys: " <+> pretty (map show kvs) + , "All running: " <+> pretty (map show allRunnings) + , "Reverse deps: " <+> pretty reverseKs + ] LogMonitering name value -> "Monitoring:" <+> pretty name <+> "value:" <+> pretty value LogDiagsPublishLog key lastDiags diags -> @@ -760,6 +773,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase + (\logText -> logWith recorder Info (LogShakeText $ T.pack logText)) shakeControlQueue opts { shakeExtra = newShakeExtra shakeExtras } rules @@ -901,8 +915,7 @@ instance Semigroup ShakeRestartArgs where -- but actions added via 'shakeEnqueue' will be requeued. shakeRestart :: TVar Int -> ShakeDatabase -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart version db vfs reason acts ioActionBetweenShakeSession = do - lockShakeDatabaseValues db - let rts = getShakeQueue db + -- lockShakeDatabaseValues db v <- atomically $ do modifyTVar' version (+1) readTVar version @@ -929,43 +942,49 @@ computePreserveAsyncs shakeDb = mempty runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do - IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar - let shakeControlQueue = shakeDataBaseQueue shakeDb + IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar + withShakeDatabaseValuesLock shakeDb $ do let prepareRestart sra@ShakeRestartArgs {..} = do keys <- sraBetweenSessions -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys -- Check if there is another restart request pending, if so, we run that one too - readAndGo sra >>= finalCheck - readAndGo sra = do - nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue - case nextRestartArg of - Nothing -> return sra - Just (Left dy) -> do - res <- prepareRestart $ dynShakeRestart dy - return $ sra <> res - Just (Right _) -> readAndGo sra - finalCheck sra = do - -- final check - -- sleep 0.2 - b <- atomically $ isEmptyTaskQueue shakeControlQueue - if b - then return sra - -- there is something new, read and go again - else readAndGo sra + -- readAndGo sra >>= finalCheck + return (sra, keys) + -- readAndGo sra = do + -- nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue + -- case nextRestartArg of + -- Nothing -> return sra + -- Just (Left dy) -> do + -- res <- prepareRestart $ dynShakeRestart dy + -- return $ sra <> res + -- Just (Right _) -> readAndGo sra + -- finalCheck sra = do + -- -- final check + -- -- sleep 0.2 + -- b <- atomically $ isEmptyTaskQueue shakeControlQueue + -- if b + -- then return sra + -- -- there is something new, read and go again + -- else readAndGo sra withMVar' shakeSession ( \runner -> do -- takeShakeLock shakeDb - let preserveAsyncs = computePreserveAsyncs shakeDb - (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner preserveAsyncs - restartArgs <- prepareRestart shakeRestartArgs + (restartArgs, newDirtyKeys) <- prepareRestart shakeRestartArgs + reverseMap <- shakeDatabaseReverseDep shakeDb + (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys + let preservekvs = [] + logWith recorder Info $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap + (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras -- this log is required by tests step <- shakeGetBuildStep shakeDb + logWith recorder Info $ LogBuildSessionRestart restartArgs queue backlog stopTime res step return restartArgs ) @@ -975,7 +994,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do ( \(ShakeRestartArgs {..}) -> do (,()) <$> newSession recorder shakeExtras sraVfs shakeDb sraActions sraReason - `finally` (for_ sraWaitMVars (`putMVar` ()) >> unlockShakeDatabaseValues shakeDb) + `finally` for_ sraWaitMVars (`putMVar` ()) ) where logErrorAfter :: Seconds -> IO () -> IO () diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index f38fd1be8b..e6c9845042 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -72,10 +72,12 @@ data Log | LogServerExitWith (Either () Int) | LogReactorShutdownConfirmed !T.Text | LogInitializeIdeStateTookTooLong Seconds + | LogText !T.Text deriving Show instance Pretty Log where pretty = \case + LogText msg -> pretty msg LogShake msg -> pretty msg LogInitializeIdeStateTookTooLong seconds -> "Building the initial session took more than" <+> pretty seconds <+> "seconds" @@ -220,7 +222,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar requestReactorShutdown = do k <- tryPutMVar reactorStopSignal () logWith recorder Info $ LogReactorShutdownRequested k - let timeOutSeconds = 3 + let timeOutSeconds = 10 timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case Just () -> pure () -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. @@ -390,6 +392,7 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do -- stop the reactor to free up the hiedb connection and shut down shake + logWith _recorder Info $ LogText "Shutdown requested" liftIO requestReactorShutdown resp $ Right Null diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 87612bf672..4fda4abe3c 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -12,7 +12,9 @@ module Development.IDE.Graph.Database( shakeGetCleanKeys ,shakeGetBuildEdges, shakeShutDatabase, - shakeGetActionQueueLength) where + shakeGetActionQueueLength, + shakeComputeToPreserve, + shakeDatabaseReverseDep) where import Control.Concurrent.Async (Async) import Control.Concurrent.STM.Stats (atomically, readTVarIO) @@ -21,6 +23,7 @@ import Control.Monad (join) import Data.Dynamic import Data.Maybe import Data.Set (Set) +import qualified Data.Set as Set import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database @@ -29,6 +32,9 @@ import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import qualified ListT +import qualified StmContainers.Map +import qualified StmContainers.Map as SMap -- Placeholder to be the 'extra' if the user doesn't set it @@ -37,11 +43,11 @@ data NonExportedType = NonExportedType shakeShutDatabase :: Set (Async ()) -> ShakeDatabase -> IO () shakeShutDatabase preserve (ShakeDatabase _ _ db) = shutDatabase preserve db -shakeNewDatabase :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase -shakeNewDatabase que opts rules = do +shakeNewDatabase :: (String -> IO ()) -> DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabase l que opts rules = do let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts (theRules, actions) <- runRules extra rules - db <- newDatabase que extra theRules + db <- newDatabase l que extra theRules pure $ ShakeDatabase (length actions) actions db shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [Either SomeException a] @@ -75,6 +81,18 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged return $ drop lenAs1 <$> runActions (newKey "root") db (map unvoid as1 ++ as2) +-- shakeDatabaseReverseDep :: ShakeDatabase -> +-- shakeDatabaseReverseDep :: ShakeDatabase -> StmContainers.Map.Map Key KeySet +shakeDatabaseReverseDep :: ShakeDatabase -> IO [(Key, KeySet)] +shakeDatabaseReverseDep (ShakeDatabase _ _ db) = + atomically $ ListT.toList $ SMap.listT (databaseReverseDep db) +-- StmContainers.Map.toList $ databaseReverseDep db + + +-- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO (Set (Async ())) +-- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO [(Key, Async ())] +shakeComputeToPreserve (ShakeDatabase _ _ db) ks = atomically (computeToPreserve db ks) + shakeRunDatabaseForKeys :: Maybe [Key] -- ^ Set of keys changed since last run. 'Nothing' means everything has changed diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 2fb5bf9a0b..f4e8d951c9 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -39,7 +39,9 @@ import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap import System.Time.Extra (duration) -import UnliftIO (async, atomically) +import UnliftIO (async, atomically, + newEmptyMVar, putMVar, + readMVar) #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) @@ -48,8 +50,8 @@ import Data.List.NonEmpty (unzip) #endif -newDatabase :: DBQue -> Dynamic -> TheRules -> IO Database -newDatabase databaseQueue databaseExtra databaseRules = do +newDatabase :: (String -> IO ()) -> DBQue -> Dynamic -> TheRules -> IO Database +newDatabase dataBaseLogger databaseQueue databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 databaseThreads <- newTVarIO [] databaseValuesLock <- newTVarIO False @@ -80,7 +82,7 @@ incDatabase db Nothing = do updateDirty :: Monad m => Focus.Focus KeyDetails m () updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> let status' - | Running _ x _ <- status = Dirty x + | Running _ x _ _ <- status = Dirty x | Clean x <- status = Dirty (Just x) | otherwise = status in KeyDetails status' rdeps @@ -120,11 +122,11 @@ builder pk db stack keys = do data IsSingletonTask = IsSingleton | NotSingleton -- the first run should not block data RunFirst = RunFirst | RunLater deriving stock (Eq, Show) -data BuildContinue = BCContinue (IO BuildContinue) | BCStop Key Result +data BuildContinue = BCContinue (IO (Key, Result)) | BCStop Key Result interpreBuildContinue :: BuildContinue -> IO (Key, Result) interpreBuildContinue (BCStop k v) = return (k, v) -interpreBuildContinue (BCContinue ioR) = ioR >>= interpreBuildContinue +interpreBuildContinue (BCContinue ioR) = ioR -- possible improvements: -- suppose it is in the direct dirty set. We have already recorded the parent key as its reverse dep. @@ -155,23 +157,22 @@ submmittBuildInDb db stack id s = do atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db) ) -- todo should only update if still at stage 1 - atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) + -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) atomically $ putTMVar startBarrier () atomically $ modifyTVar' (databaseThreads db) (newAsync :) builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue builderOneCoroutine parentKey isSingletonTask db stack id = - builderOneCoroutine' RunFirst isSingletonTask db stack id + builderOneCoroutine' db stack id where - builderOneCoroutine' :: RunFirst -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue - builderOneCoroutine' rf isSingletonTask db@Database {..} stack id = do + builderOneCoroutine' :: Database -> Stack -> Key -> IO BuildContinue + builderOneCoroutine' db@Database {..} stack id = do traceEvent ("builderOne: " ++ show id) return () + barrier <- newEmptyMVar liftIO $ atomicallyNamed "builder" $ do -- Spawn the id if needed - void $ check <$> readTVar databaseValuesLock - + dbNotLocked db insertDatabaseReverseDepOne id parentKey db - -- if a build is running, wait -- it will either be killed or continue -- depending on wether it is marked as dirty @@ -179,29 +180,24 @@ builderOneCoroutine parentKey isSingletonTask db stack id = current <- readTVar databaseStep case viewDirty current $ maybe (Dirty Nothing) keyStatus status of Dirty s -> do - SMap.focus (updateStatus $ Running current s RunningStage1) id databaseValues - case isSingletonTask of - IsSingleton -> - return $ - BCContinue $ fmap (BCStop id) $ - refresh db stack id s `catch` \e@(SomeException _) -> do - atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues - throw e - NotSingleton -> do - traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) $ - -- we need to run serially to avoid summiting run but killed in the middle - runOneInDataBase (show id) db (do - refresh db stack id s - ) $ - -- we might want it to be able to be killed since we might want to preserve the database - \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues - return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id + -- we need to run serially to avoid summiting run but killed in the middle + -- we might want it to be able to be killed since we might want to preserve the database + -- traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) + -- + let wait = readMVar barrier + runOneInDataBase (show (parentKey, id)) db + (\adyncH -> + -- it is safe from worker thread + atomically $ SMap.focus (updateStatus $ Running current s wait (RunningStage2 adyncH) ) id databaseValues) + (refresh db stack id s >>= putMVar barrier . (id,)) $ \e -> do + atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + putMVar barrier (throw e) + SMap.focus (updateStatus $ Running current s wait RunningStage1) id databaseValues + return $ BCContinue $ readMVar barrier Clean r -> return $ BCStop id r - Running _step _s _ + Running _step _s wait _ | memberStack id stack -> throw $ StackException stack - | otherwise -> if rf == RunFirst - then return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id - else retry + | otherwise -> return $ BCContinue wait Exception _ e _s -> throw e -- | isDirty @@ -243,9 +239,10 @@ compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode deps <- liftIO $ newIORef UnknownDeps + curStep <- liftIO $ readTVarIO databaseStep + dataBaseLogger $ "Computing key: " ++ show key ++ " at step " ++ show curStep (execution, RunResult{..}) <- liftIO $ duration $ runReaderT (fromAction act) $ SAction key db deps stack - curStep <- liftIO $ readTVarIO databaseStep deps <- liftIO $ readIORef deps let lastChanged = maybe curStep resultChanged result let lastBuild = maybe curStep resultBuilt result @@ -275,7 +272,7 @@ compute db@Database{..} stack key mode result = do deps _ -> pure () liftIO $ atomicallyNamed "compute and run hook" $ do - void $ check <$> readTVar databaseValuesLock + dbNotLocked db runHook SMap.focus (updateStatus $ Clean res) key databaseValues pure res diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs index 0b162060d7..71760586cc 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Key.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Key.hs @@ -48,15 +48,20 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Typeable import Development.IDE.Graph.Classes +import Prettyprinter import System.IO.Unsafe newtype Key = UnsafeMkKey Int + pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key pattern Key a <- (lookupKeyValue -> KeyValue a _) {-# COMPLETE Key #-} +instance Pretty Key where + pretty = pretty . renderKey + data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text instance Eq KeyValue where @@ -112,6 +117,9 @@ renderKey (lookupKeyValue -> KeyValue _ t) = t newtype KeySet = KeySet IntSet deriving newtype (Eq, Ord, Semigroup, Monoid, NFData) +instance Pretty KeySet where + pretty (KeySet is) = pretty (coerce (IS.toList is) :: [Key]) + instance Show KeySet where showsPrec p (KeySet is)= showParen (p > 10) $ showString "fromList " . shows ks diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index b264247de0..40f9b18823 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -6,9 +6,9 @@ module Development.IDE.Graph.Internal.Types where -import Control.Concurrent.STM (STM, modifyTVar') +import Control.Concurrent.STM (STM, check, modifyTVar') import Control.Monad (forM, forM_, forever, - unless) + unless, when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -47,6 +47,7 @@ import UnliftIO (Async (asyncThreadId), throwTo, waitCatch, withAsync) import UnliftIO.Concurrent (ThreadId, myThreadId) +import qualified UnliftIO.Exception as UE #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -101,6 +102,9 @@ getDatabase = Action $ asks actionDatabase getActionKey :: Action Key getActionKey = Action $ asks actionKey +setActionKey :: Key -> Action a -> Action a +setActionKey k (Action act) = Action $ do + local (\s' -> s'{actionKey = k}) act -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. -- waitForDatabaseRunningKeysAction :: Action () @@ -112,7 +116,7 @@ getActionKey = Action $ asks actionKey data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int - deriving newtype (Eq,Ord,Hashable,Show) + deriving newtype (Eq,Ord,Hashable,Show,Num,Enum,Real,Integral) getShakeStep :: MonadIO m => ShakeDatabase -> m Step @@ -128,6 +132,16 @@ unlockShakeDatabaseValues :: MonadIO m => ShakeDatabase -> m () unlockShakeDatabaseValues (ShakeDatabase _ _ db) = do liftIO $ atomically $ modifyTVar' (databaseValuesLock db) (const True) +withShakeDatabaseValuesLock :: ShakeDatabase -> IO c -> IO c +withShakeDatabaseValuesLock sdb act = do + UE.bracket_ (lockShakeDatabaseValues sdb) (unlockShakeDatabaseValues sdb) act + +dbNotLocked :: Database -> STM () +dbNotLocked db = do + check =<< readTVar (databaseValuesLock db) + + + getShakeQueue :: ShakeDatabase -> DBQue getShakeQueue (ShakeDatabase _ _ db) = databaseQueue db --------------------------------------------------------------------- @@ -157,8 +171,7 @@ data Database = Database { -- if not in any of the transitive reverse deps of a dirty node, it is clean -- we can skip clean the threads. -- this is update right before we query the database for the key result. - - + dataBaseLogger :: String -> IO (), databaseQueue :: DBQue, @@ -172,27 +185,43 @@ data Database = Database { } --------------------------------------------------------------------- --- compute clean running asyncs --- clean running asyncs are those runnings keys at stage 2 that are not --- at reverse dependency of any dirty keys - --- we also need to update not dirty running keys to a new step --- for stage 1 non-dirty keys, since its computing thread is not started, --- we can just update its step to the new step --- for stage 2 non-dirty keys, we need to cancel its computing thread -computeCleanRunningAsyncs :: Database -> KeySet -> STM [Async ()] -computeCleanRunningAsyncs db dirtySet = do +-- compute to preserve asyncs +-- only the running stage 2 keys are actually running +-- so we only need to preserve them if they are not affected by the dirty set + +-- to acompany with this, +-- all non-dirty running need to have an updated step, +-- so it won't be view as dirty when we restart the build +-- computeToPreserve :: Database -> KeySet -> STM [(Key, Async ())] +computeToPreserve db dirtySet = do -- All keys that depend (directly or transitively) on any dirty key affected <- computeTransitiveReverseDeps db dirtySet -- Running stage-2 keys are eligible to be considered for cleanup - running <- getRunningStage2Keys db + running2 <- getRunningStage2Keys db + allRunings <- getRunningKeys db + forM_ allRunings $ \k -> do + -- if not dirty, bump its step + unless (memberKeySet k dirtySet) $ do + SMap.focus (Focus.alter $ \case + Just kd@KeyDetails {keyStatus=Running {runningStep, runningPrev, runningWait, runningStage}} -> Just (kd{keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage}) + _ -> Nothing + ) k (databaseValues db) + + -- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty -- Keep only those whose key is NOT affected by the dirty set - pure [async | (k, async) <- running, not (memberKeySet k affected)] + pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings) getRunningStage2Keys :: Database -> STM [(Key, Async ())] +-- getRunningStage2Keys db = return [] getRunningStage2Keys db = do pairs <- ListT.toList $ SMap.listT (databaseValues db) - return [(k, async) | (k, v) <- pairs, Running _ _ (RunningStage2 async) <- [keyStatus v]] + return [(k, async) | (k, v) <- pairs, Running _ _ _ (RunningStage2 async) <- [keyStatus v]] + +getRunningKeys :: Database -> STM [Key] +getRunningKeys db = do + pairs <- ListT.toList $ SMap.listT (databaseValues db) + return [k | (k, v) <- pairs, Running {} <- [keyStatus v]] + -- compute the transitive reverse dependencies of a set of keys -- using databaseReverseDep in the Database @@ -220,8 +249,8 @@ computeTransitiveReverseDeps db seeds = do insertDatabaseReverseDepOne :: Key -> Key -> Database -> STM () -insertDatabaseReverseDepOne k a db = do - SMap.focus (Focus.alter (Just . maybe mempty (insertKeySet a))) k (databaseReverseDep db) +insertDatabaseReverseDepOne k pk db = do + SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k (databaseReverseDep db) awaitRunInDb :: Database -> IO result -> IO result @@ -237,22 +266,29 @@ databaseGetActionQueueLength db = do runInDataBase :: String -> Database -> [(IO result, Either SomeException result -> IO ())] -> STM () runInDataBase title db acts = do s <- getDataBaseStepInt db - runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) acts + let actWithEmptyHook = map (\(x, y) -> (const $ return (), x, y)) acts + runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) actWithEmptyHook -runOneInDataBase :: String -> Database -> IO result -> (SomeException -> IO ()) -> STM () -runOneInDataBase title db act handler = do +runOneInDataBase :: String -> Database -> (Async () -> IO ()) -> IO result -> (SomeException -> IO ()) -> STM () +runOneInDataBase title db registerAsync act handler = do s <- getDataBaseStepInt db runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) - [ ( act, + [ ( registerAsync, warpLog act, \case Left e -> handler e Right _ -> return () ) ] + where + warpLog a = + UE.bracket_ + (dataBaseLogger db $ "Starting async action: " ++ title) + (dataBaseLogger db $ "Finished async action: " ++ title) + a getDataBaseStepInt :: Database -> STM Int @@ -283,7 +319,7 @@ shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do unless (null asyncs) $ do let warnIfTakingTooLong = unmask $ forever $ do sleep 10 - traceM "cleanupAsync: waiting for asyncs to finish" + traceEventIO "cleanupAsync: waiting for asyncs to finish" withAsync warnIfTakingTooLong $ \_ -> mapM_ waitCatch asyncs @@ -307,18 +343,19 @@ data Status runningStep :: !Step, -- runningResult :: Result, -- LAZY runningPrev :: !(Maybe Result), + runningWait :: !(IO (Key, Result)), runningStage :: !RunningStage } viewDirty :: Step -> Status -> Status -viewDirty currentStep (Running s re _) | currentStep /= s = Dirty re +viewDirty currentStep (Running s re _ _) | currentStep /= s = Dirty re viewDirty currentStep (Exception s _ re) | currentStep /= s = Dirty re viewDirty _ other = other getResult :: Status -> Maybe Result getResult (Clean re) = Just re getResult (Dirty m_re) = m_re -getResult (Running _ m_re _) = m_re -- watch out: this returns the previous result +getResult (Running _ m_re _ _) = m_re -- watch out: this returns the previous result getResult (Exception _ _ m_re) = m_re -- waitRunning :: Status -> IO () diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index b4832e0d77..27c5426bab 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -134,7 +134,7 @@ data DeliverStatus = DeliverStatus , deliverName :: String } deriving (Show) -runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(IO result, Either SomeException result -> IO ())] -> STM () +runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do -- Take an action from TQueue, run it and -- use barrier to wait for the result @@ -144,8 +144,11 @@ runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do curStep <- atomically getStep -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) when (curStep == deliverStep deliver) $ do - syncs <- mapM (\(act, handler) -> - async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))) acts + syncs <- mapM (\(preHook, act, handler) -> do + a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e)) + preHook a + return a + ) acts atomically $ modifyTVar' tthreads (syncs++) type Worker arg = arg -> IO () diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt index 065394835c..d3e958b7a7 100644 --- a/scripts/flaky-test-patterns.txt +++ b/scripts/flaky-test-patterns.txt @@ -1,31 +1,29 @@ # One tasty pattern per line. Lines starting with # are comments. # Blank lines are ignored. -# open close -# non local variable -# Notification Handlers -bidirectional module dependency with hs-boot -iface-error-test-1 open close non local variable Notification Handlers bidirectional module dependency with hs-boot InternalError over InvalidParams -# ghcide restarts shake session on config changes: addDependentFile -# Another interesting one you can try: -# func-test::sends indefinite progress notifications hls-pragmas-plugin-tests::/inline: RULES/ # hls-graph cancel leaks asynchronous exception to the next session hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps hls-class-plugin-tests::Creates a placeholder for fmap -hls-rename-plugin-tests::Rename th-linking-test-unboxed update syntax error +ghcide restarts shake session on config changes: retry failed th-linking-test -are deleted from the state + +# iface-error-test-1 +# func-test::sends indefinite progress notifications +# hls-rename-plugin-tests::Rename + +# this is a garbage collecter test +# ghcide-tests::are deleted from the state From 4ec36f11f057f54c6cd7083c53d275a58906a183 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 10:18:20 +0800 Subject: [PATCH 093/107] fix build --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 928a3ee03e..2723a458b5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -974,8 +974,8 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- takeShakeLock shakeDb (restartArgs, newDirtyKeys) <- prepareRestart shakeRestartArgs reverseMap <- shakeDatabaseReverseDep shakeDb - (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys - let preservekvs = [] + -- (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys + let (preservekvs, allRunning2) = ([], []) logWith recorder Info $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs From 3b0f4c8a7ecfb7125665d3ebd93a35a09933f745 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 10:33:55 +0800 Subject: [PATCH 094/107] refactor: update DeliverStatus handling in database operations --- .../Development/IDE/Graph/Internal/Database.hs | 8 +++++++- .../src/Development/IDE/Graph/Internal/Types.hs | 17 ++++++++--------- hls-graph/src/Development/IDE/WorkerThread.hs | 5 +++-- 3 files changed, 18 insertions(+), 12 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index f4e8d951c9..e219bf0898 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -45,6 +45,7 @@ import UnliftIO (async, atomically, #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) +import Development.IDE.WorkerThread (DeliverStatus (DeliverStatus)) #else import Data.List.NonEmpty (unzip) #endif @@ -185,7 +186,12 @@ builderOneCoroutine parentKey isSingletonTask db stack id = -- traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) -- let wait = readMVar barrier - runOneInDataBase (show (parentKey, id)) db + runOneInDataBase (do { + status <- atomically (SMap.lookup id databaseValues) + ; let cur = fromIntegral $ case keyStatus <$> status of + Just (Running current _s _wait RunningStage1) -> current + _ -> error "only RunningStage1 can continue" + ; return $ DeliverStatus cur (show (parentKey, id))}) db (\adyncH -> -- it is safe from worker thread atomically $ SMap.focus (updateStatus $ Running current s wait (RunningStage2 adyncH) ) id databaseValues) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 40f9b18823..d6b3715588 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -267,14 +267,13 @@ runInDataBase :: String -> Database -> [(IO result, Either SomeException result runInDataBase title db acts = do s <- getDataBaseStepInt db let actWithEmptyHook = map (\(x, y) -> (const $ return (), x, y)) acts - runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) actWithEmptyHook + runInThreadStmInNewThreads (getDataBaseStepInt db) (return $ DeliverStatus s title) (databaseQueue db) (databaseThreads db) actWithEmptyHook -runOneInDataBase :: String -> Database -> (Async () -> IO ()) -> IO result -> (SomeException -> IO ()) -> STM () -runOneInDataBase title db registerAsync act handler = do - s <- getDataBaseStepInt db +runOneInDataBase :: IO DeliverStatus -> Database -> (Async () -> IO ()) -> IO result -> (SomeException -> IO ()) -> STM () +runOneInDataBase mkDelivery db registerAsync act handler = do runInThreadStmInNewThreads (getDataBaseStepInt db) - (DeliverStatus s title) + mkDelivery (databaseQueue db) (databaseThreads db) [ ( registerAsync, warpLog act, @@ -285,10 +284,10 @@ runOneInDataBase title db registerAsync act handler = do ] where warpLog a = - UE.bracket_ - (dataBaseLogger db $ "Starting async action: " ++ title) - (dataBaseLogger db $ "Finished async action: " ++ title) - a + UE.bracket + (do (DeliverStatus _ title) <- mkDelivery; dataBaseLogger db ("Starting async action: " ++ title); return title) + (\title -> dataBaseLogger db $ "Finished async action: " ++ title) + (const a) getDataBaseStepInt :: Database -> STM Int diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 27c5426bab..8ffe5a7fa3 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -134,14 +134,15 @@ data DeliverStatus = DeliverStatus , deliverName :: String } deriving (Show) -runInThreadStmInNewThreads :: STM Int -> DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () -runInThreadStmInNewThreads getStep deliver (TaskQueue q) tthreads acts = do +runInThreadStmInNewThreads :: STM Int -> IO DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () +runInThreadStmInNewThreads getStep mkDeliver (TaskQueue q) tthreads acts = do -- Take an action from TQueue, run it and -- use barrier to wait for the result writeTQueue q $ Right $ do uninterruptibleMask $ \restore -> do do curStep <- atomically getStep + deliver <- mkDeliver -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) when (curStep == deliverStep deliver) $ do syncs <- mapM (\(preHook, act, handler) -> do From eaff72eadba852cb5c99e0e927db4256762000d3 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 11:31:35 +0800 Subject: [PATCH 095/107] fix job previous step job skipping --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index e219bf0898..b9baf61f4c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -189,8 +189,8 @@ builderOneCoroutine parentKey isSingletonTask db stack id = runOneInDataBase (do { status <- atomically (SMap.lookup id databaseValues) ; let cur = fromIntegral $ case keyStatus <$> status of - Just (Running current _s _wait RunningStage1) -> current - _ -> error "only RunningStage1 can continue" + Just (Running entryStep _s _wait RunningStage1) -> entryStep + _ -> current ; return $ DeliverStatus cur (show (parentKey, id))}) db (\adyncH -> -- it is safe from worker thread From 2cc8c974e9f33b7d81419266b37a595c2aea85f4 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 14:14:46 +0800 Subject: [PATCH 096/107] kill thread that actually needed to be killed --- ghcide/src/Development/IDE/Core/Rules.hs | 11 +- ghcide/src/Development/IDE/Core/Shake.hs | 27 +--- .../IDE/Graph/Internal/Database.hs | 37 +++-- .../Development/IDE/Graph/Internal/Types.hs | 105 ++++++++++----- hls-graph/src/Development/IDE/WorkerThread.hs | 26 +--- .../src/Ide/Plugin/SemanticTokens.hs | 1 + scripts/eventlog-dump.fish | 117 ---------------- scripts/eventlog_dump.py | 127 ++++++++++++++++++ 8 files changed, 229 insertions(+), 222 deletions(-) delete mode 100755 scripts/eventlog-dump.fish create mode 100644 scripts/eventlog_dump.py diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d07cfda0d8..a2ced4d33e 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -175,6 +175,7 @@ import System.Info.Extra (isWindows) import qualified Data.IntMap as IM import GHC.Fingerprint +import Debug.Trace (traceEventIO) data Log = LogShake Shake.Log @@ -910,16 +911,20 @@ getModSummaryRule displayTHWarning recorder = do return (Just fp, Just res{msrModSummary = ms}) Nothing -> return (Nothing, Nothing) -generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) -generateCore runSimplifier file = do +generateCore :: Recorder (WithPriority Log) -> RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) +generateCore recorder runSimplifier file = do + liftIO $ traceEventIO "Generating Core1" packageState <- hscEnv <$> use_ GhcSessionDeps file + liftIO $ traceEventIO "Generating Core2" hsc' <- setFileCacheHook packageState + liftIO $ traceEventIO "Generating Core3" tm <- use_ TypeCheck file + liftIO $ traceEventIO "Generating Core4" liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder = - define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) + define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore recorder (RunSimplifier True) getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2723a458b5..47e7dd2645 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -773,7 +773,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase - (\logText -> logWith recorder Info (LogShakeText $ T.pack logText)) + (\logText -> logWith recorder Debug (LogShakeText $ T.pack logText)) shakeControlQueue opts { shakeExtra = newShakeExtra shakeExtras } rules @@ -848,6 +848,7 @@ shakeShut IdeState{..} = do -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. for_ runner (flip cancelShakeSession mempty) + shakeShutDatabase mempty shakeDb void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras progressStop $ indexProgressReporting $ hiedbWriter shakeExtras @@ -950,33 +951,15 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys -- Check if there is another restart request pending, if so, we run that one too - -- readAndGo sra >>= finalCheck return (sra, keys) - -- readAndGo sra = do - -- nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue - -- case nextRestartArg of - -- Nothing -> return sra - -- Just (Left dy) -> do - -- res <- prepareRestart $ dynShakeRestart dy - -- return $ sra <> res - -- Just (Right _) -> readAndGo sra - -- finalCheck sra = do - -- -- final check - -- -- sleep 0.2 - -- b <- atomically $ isEmptyTaskQueue shakeControlQueue - -- if b - -- then return sra - -- -- there is something new, read and go again - -- else readAndGo sra withMVar' shakeSession ( \runner -> do - -- takeShakeLock shakeDb (restartArgs, newDirtyKeys) <- prepareRestart shakeRestartArgs reverseMap <- shakeDatabaseReverseDep shakeDb - -- (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys - let (preservekvs, allRunning2) = ([], []) - logWith recorder Info $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap + (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys + -- let (preservekvs, allRunning2) = ([], []) + logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index b9baf61f4c..ee910b1569 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -144,23 +144,23 @@ interpreBuildContinue (BCContinue ioR) = ioR -- finally, catch any (async) exception and mark the key as exception -- submmittBuildInDb :: Database -> IO a -> IO a -submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO () -submmittBuildInDb db stack id s = do - uninterruptibleMask_ $ do - do - curStep <- readTVarIO $ databaseStep db - startBarrier <- newEmptyTMVarIO - newAsync <- - async - (do - uninterruptibleMask_ $ atomically $ readTMVar startBarrier - void (refresh db stack id s) `catch` \e@(SomeException _) -> - atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db) - ) - -- todo should only update if still at stage 1 - -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) - atomically $ putTMVar startBarrier () - atomically $ modifyTVar' (databaseThreads db) (newAsync :) +-- submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO () +-- submmittBuildInDb db stack id s = do +-- uninterruptibleMask_ $ do +-- do +-- curStep <- readTVarIO $ databaseStep db +-- startBarrier <- newEmptyTMVarIO +-- newAsync <- +-- async +-- (do +-- uninterruptibleMask_ $ atomically $ readTMVar startBarrier +-- void (refresh db stack id s) `catch` \e@(SomeException _) -> +-- atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db) +-- ) +-- -- todo should only update if still at stage 1 +-- -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) +-- atomically $ putTMVar startBarrier () +-- atomically $ modifyTVar' (databaseThreads db) ((newAsync) :) builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue builderOneCoroutine parentKey isSingletonTask db stack id = @@ -182,9 +182,6 @@ builderOneCoroutine parentKey isSingletonTask db stack id = case viewDirty current $ maybe (Dirty Nothing) keyStatus status of Dirty s -> do -- we need to run serially to avoid summiting run but killed in the middle - -- we might want it to be able to be killed since we might want to preserve the database - -- traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) - -- let wait = readMVar barrier runOneInDataBase (do { status <- atomically (SMap.lookup id databaseValues) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index d6b3715588..f2f0232c51 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -20,7 +20,7 @@ import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List (intercalate) -import Data.Maybe +import Data.Maybe (fromMaybe, isNothing) import Data.Set (Set) import qualified Data.Set as S import Data.Typeable @@ -28,10 +28,9 @@ import Debug.Trace (traceEventIO, traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.WorkerThread (DeliverStatus (..), - TaskQueue, + TaskQueue (..), awaitRunInThread, - counTaskQueue, - runInThreadStmInNewThreads) + counTaskQueue) import qualified Focus import GHC.Conc (TVar, atomically) import GHC.Generics (Generic) @@ -40,12 +39,12 @@ import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds, sleep) import UnliftIO (Async (asyncThreadId), - MonadUnliftIO, + MonadUnliftIO, async, asyncExceptionFromException, asyncExceptionToException, - readTVar, readTVarIO, + poll, readTVar, readTVarIO, throwTo, waitCatch, - withAsync) + withAsync, writeTQueue) import UnliftIO.Concurrent (ThreadId, myThreadId) import qualified UnliftIO.Exception as UE @@ -162,7 +161,7 @@ type DBQue = TaskQueue (Either Dynamic (IO ())) data Database = Database { databaseExtra :: Dynamic, - databaseThreads :: TVar [Async ()], + databaseThreads :: TVar [(DeliverStatus, Async ())], databaseReverseDep :: SMap.Map Key KeySet, -- For each key, the set of keys that depend on it directly. @@ -193,23 +192,27 @@ data Database = Database { -- all non-dirty running need to have an updated step, -- so it won't be view as dirty when we restart the build -- computeToPreserve :: Database -> KeySet -> STM [(Key, Async ())] +computeToPreserve :: Database -> KeySet -> STM ([(Key, Async ())], [Key]) computeToPreserve db dirtySet = do - -- All keys that depend (directly or transitively) on any dirty key - affected <- computeTransitiveReverseDeps db dirtySet - -- Running stage-2 keys are eligible to be considered for cleanup - running2 <- getRunningStage2Keys db - allRunings <- getRunningKeys db - forM_ allRunings $ \k -> do - -- if not dirty, bump its step - unless (memberKeySet k dirtySet) $ do - SMap.focus (Focus.alter $ \case - Just kd@KeyDetails {keyStatus=Running {runningStep, runningPrev, runningWait, runningStage}} -> Just (kd{keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage}) - _ -> Nothing - ) k (databaseValues db) - - -- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty - -- Keep only those whose key is NOT affected by the dirty set - pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings) + -- All keys that depend (directly or transitively) on any dirty key + affected <- computeTransitiveReverseDeps db dirtySet + running2 <- getRunningStage2Keys db + allRunings <- getRunningKeys db + forM_ allRunings $ \k -> do + -- if not dirty, bump its step + unless (memberKeySet k affected) $ do + SMap.focus + ( Focus.alter $ \case + Just kd@KeyDetails {keyStatus = Running {runningStep, runningPrev, runningWait, runningStage}} -> + Just (kd {keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage}) + _ -> Nothing + ) + k + (databaseValues db) + + -- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty + -- Keep only those whose key is NOT affected by the dirty set + pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings) getRunningStage2Keys :: Database -> STM [(Key, Async ())] -- getRunningStage2Keys db = return [] @@ -267,15 +270,35 @@ runInDataBase :: String -> Database -> [(IO result, Either SomeException result runInDataBase title db acts = do s <- getDataBaseStepInt db let actWithEmptyHook = map (\(x, y) -> (const $ return (), x, y)) acts - runInThreadStmInNewThreads (getDataBaseStepInt db) (return $ DeliverStatus s title) (databaseQueue db) (databaseThreads db) actWithEmptyHook + runInThreadStmInNewThreads db (return $ DeliverStatus s title) actWithEmptyHook + +runInThreadStmInNewThreads :: Database -> IO DeliverStatus -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () +runInThreadStmInNewThreads db mkDeliver acts = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + let TaskQueue q = databaseQueue db + let log prefix title = dataBaseLogger db (prefix ++ title) + writeTQueue q $ Right $ do + uninterruptibleMask $ \restore -> do + do + deliver <- mkDeliver + log "runInThreadStmInNewThreads submit begin " (deliverName deliver) + curStep <- atomically $ getDataBaseStepInt db + -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) + when (curStep == deliverStep deliver) $ do + syncs <- mapM (\(preHook, act, handler) -> do + a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e)) + preHook a + return (deliver, a) + ) acts + atomically $ modifyTVar' (databaseThreads db) (syncs++) + log "runInThreadStmInNewThreads submit end " (deliverName deliver) runOneInDataBase :: IO DeliverStatus -> Database -> (Async () -> IO ()) -> IO result -> (SomeException -> IO ()) -> STM () runOneInDataBase mkDelivery db registerAsync act handler = do runInThreadStmInNewThreads - (getDataBaseStepInt db) + db mkDelivery - (databaseQueue db) - (databaseThreads db) [ ( registerAsync, warpLog act, \case Left e -> handler e @@ -284,7 +307,7 @@ runOneInDataBase mkDelivery db registerAsync act handler = do ] where warpLog a = - UE.bracket + bracket (do (DeliverStatus _ title) <- mkDelivery; dataBaseLogger db ("Starting async action: " ++ title); return title) (\title -> dataBaseLogger db $ "Finished async action: " ++ title) (const a) @@ -308,19 +331,29 @@ shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do asyncs <- readTVarIO databaseThreads step <- readTVarIO databaseStep tid <- myThreadId - traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step) - let remains = filter (`S.member` preserve) asyncs - let toCancel = filter (`S.notMember` preserve) asyncs - mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) toCancel + -- traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step) + -- traceEventIO ("shutDatabase: async entries: " ++ show (map (deliverName . fst) asyncs)) + let remains = filter (\(_, s) -> s `S.member` preserve) asyncs + let toCancel = filter (\(_, s) -> s `S.notMember` preserve) asyncs + -- traceEventIO ("shutDatabase: remains count: " ++ show (length remains) ++ ", names: " ++ show (map (deliverName . fst) remains)) + -- traceEventIO ("shutDatabase: toCancel count: " ++ show (length toCancel) ++ ", names: " ++ show (map (deliverName . fst) toCancel)) + mapM_ (\(_, a) -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) toCancel atomically $ modifyTVar' databaseThreads (const remains) -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr unless (null asyncs) $ do let warnIfTakingTooLong = unmask $ forever $ do - sleep 10 - traceEventIO "cleanupAsync: waiting for asyncs to finish" + sleep 5 + as <- readTVarIO databaseThreads + -- poll each async: Nothing => still running + statuses <- forM as $ \(d,a) -> do + p <- poll a + return (d, a, p) + let still = [ (deliverName d, show (asyncThreadId a)) | (d,a,p) <- statuses, isNothing p ] + traceEventIO $ "cleanupAsync: waiting for asyncs to finish; total=" ++ show (length as) ++ ", stillRunning=" ++ show (length still) + traceEventIO $ "cleanupAsync: still running (deliverName, threadId) = " ++ show still withAsync warnIfTakingTooLong $ \_ -> - mapM_ waitCatch asyncs + mapM_ waitCatch $ map snd toCancel -- waitForDatabaseRunningKeys :: Database -> IO () -- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 8ffe5a7fa3..3897120bf5 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -17,7 +17,6 @@ module Development.IDE.WorkerThread TaskQueue(..), writeTaskQueue, withWorkerQueueSimple, - runInThreadStmInNewThreads, isEmptyTaskQueue, counTaskQueue, submitWork, @@ -29,17 +28,13 @@ module Development.IDE.WorkerThread awaitRunInThread ) where -import Control.Concurrent.Async (Async, async, withAsync) +import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM -import Control.Exception.Safe (MonadMask (..), - SomeException (SomeException), - finally, throw, try) +import Control.Exception.Safe (SomeException, finally, throw, try) import Control.Monad.Cont (ContT (ContT)) import qualified Data.Text as T import Control.Concurrent -import Control.Exception (catch) -import Control.Monad (when) import Data.Dynamic (Dynamic) import Prettyprinter @@ -134,23 +129,6 @@ data DeliverStatus = DeliverStatus , deliverName :: String } deriving (Show) -runInThreadStmInNewThreads :: STM Int -> IO DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () -runInThreadStmInNewThreads getStep mkDeliver (TaskQueue q) tthreads acts = do - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - writeTQueue q $ Right $ do - uninterruptibleMask $ \restore -> do - do - curStep <- atomically getStep - deliver <- mkDeliver - -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) - when (curStep == deliverStep deliver) $ do - syncs <- mapM (\(preHook, act, handler) -> do - a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e)) - preHook a - return a - ) acts - atomically $ modifyTVar' tthreads (syncs++) type Worker arg = arg -> IO () diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 28e05f5e8c..8b2d8b3d8a 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -9,6 +9,7 @@ import Ide.Plugin.SemanticTokens.Types import Ide.Types import Language.LSP.Protocol.Message +-- I hope that does mean much more sense now, only fire at the point would give a bit more than it should descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides semantic tokens") diff --git a/scripts/eventlog-dump.fish b/scripts/eventlog-dump.fish deleted file mode 100755 index 9cd44fe67f..0000000000 --- a/scripts/eventlog-dump.fish +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/env fish - -# Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI. -# Usage: -# scripts/eventlog-dump.fish [output.txt] [contains_substring] -# -# Notes: -# - Attempts to find ghc-events in PATH, ~/.cabal/bin, or ~/.local/bin. -# - If not found, will try: cabal install ghc-events -# - Output defaults to .events.txt in the current directory. - -function usage - echo "Usage: (basename (status filename)) [output.txt] [contains_substring]" - exit 2 -end - -if test (count $argv) -lt 1 - usage -end - -set evlog $argv[1] -if not test -f $evlog - echo "error: file not found: $evlog" >&2 - exit 1 -end - -if test (count $argv) -ge 2 - set out $argv[2] -else - set base (basename $evlog) - if string match -q '*\.eventlog' $base - set out (string replace -r '\\.eventlog$' '.events.txt' -- $base) - else - set out "$base.events.txt" - end -end - -# Optional contains filter: only keep lines that contain any of the substrings (pipe-separated) -set filter_contains "" -set filter_contains_list -if test (count $argv) -ge 3 - set filter_contains $argv[3] - set filter_contains_list (string split '|' -- $filter_contains) -end - -function find_ghc_events --description "echo absolute path to ghc-events or empty" - if command -sq ghc-events - command -s ghc-events - return 0 - end - if test -x ~/.cabal/bin/ghc-events - echo ~/.cabal/bin/ghc-events - return 0 - end - if test -x ~/.local/bin/ghc-events - echo ~/.local/bin/ghc-events - return 0 - end - return 1 -end - -set ghc_events_bin (find_ghc_events) - -if test -z "$ghc_events_bin" - echo "ghc-events not found; attempting to install via 'cabal install ghc-events'..." >&2 - if not command -sq cabal - echo "error: cabal not found; please install ghc-events manually (e.g., via cabal)." >&2 - exit 1 - end - cabal install ghc-events - set ghc_events_bin (find_ghc_events) - if test -z "$ghc_events_bin" - echo "error: ghc-events still not found after installation." >&2 - exit 1 - end -end - -echo "Dumping events from $evlog to $out..." -if test -n "$filter_contains" - $ghc_events_bin show $evlog | while read -l line - set keep 1 - if (count $filter_contains_list) -gt 0 - set found 0 - for substr in $filter_contains_list - if string match -q -- "*$substr*" -- $line - set found 1 - break - end - end - if test $found -eq 0 - set keep 0 - end - end - if test $keep -eq 1 - echo $line - end - end > $out -else - $ghc_events_bin show $evlog > $out -end -set exit_code $status - -if test $exit_code -ne 0 - echo "error: dump failed with exit code $exit_code" >&2 - exit $exit_code -end - -set -l size "" -if command -sq stat - # macOS stat prints size with -f%z; suppress errors if not supported - set size (stat -f%z $out 2>/dev/null) -end -if test -z "$size" - set size (wc -c < $out) -end - -echo "Wrote $out ($size bytes)." diff --git a/scripts/eventlog_dump.py b/scripts/eventlog_dump.py new file mode 100644 index 0000000000..9fb6602269 --- /dev/null +++ b/scripts/eventlog_dump.py @@ -0,0 +1,127 @@ +#!/usr/bin/env python3 +""" +Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI. +Usage: + scripts/eventlog_dump.py [--out output.txt] [--contains SUBSTR1|SUBSTR2] + +Behavior mirrors scripts/eventlog-dump.fish: tries to find ghc-events in PATH, +~/.cabal/bin, or ~/.local/bin. If not found and `cabal` exists in PATH, it will run +`cabal install ghc-events` and retry. + +Filtering: if --contains is provided it should be a pipe-separated list of +substrings; a line is kept if it contains any of the substrings. + +Exit codes: + 0 : success + >0 : failures from ghc-events or setup errors +""" +from __future__ import annotations + +import argparse +import os +import shutil +import subprocess +import sys +from typing import Iterable, List, Optional + + +def find_ghc_events() -> Optional[str]: + # 1) PATH + path = shutil.which("ghc-events") + if path: + return path + # 2) common user bins + cand = os.path.expanduser("~/.cabal/bin/ghc-events") + if os.path.isfile(cand) and os.access(cand, os.X_OK): + return cand + cand = os.path.expanduser("~/.local/bin/ghc-events") + if os.path.isfile(cand) and os.access(cand, os.X_OK): + return cand + return None + + +def try_install_ghc_events() -> bool: + if shutil.which("cabal") is None: + return False + print("ghc-events not found; attempting to install via 'cabal install ghc-events'...", file=sys.stderr) + rc = subprocess.run(["cabal", "install", "ghc-events"]) # let cabal print its own output + return rc.returncode == 0 + + +def stream_and_filter(cmd: List[str], out_path: str, contains: Optional[Iterable[str]]) -> int: + proc = subprocess.Popen(cmd, stdout=subprocess.PIPE, stderr=subprocess.PIPE, text=True) + assert proc.stdout is not None + with open(out_path, "w", encoding="utf-8", newline="\n") as fout: + for line in proc.stdout: + if contains: + if any(sub in line for sub in contains): + fout.write(line) + else: + fout.write(line) + # wait for process to finish and capture stderr + _, err = proc.communicate() + if proc.returncode != 0: + # write stderr for debugging + sys.stderr.write(err) + return proc.returncode + + +def parse_args(argv: Optional[List[str]] = None) -> argparse.Namespace: + ap = argparse.ArgumentParser(description="Dump GHC eventlog to text with optional substring filtering") + ap.add_argument("eventlog", help=".eventlog file to dump") + ap.add_argument("--out", "-o", default=None, help="Output text file (default: .events.txt)") + ap.add_argument("--contains", "-c", default=None, + help="Pipe-separated substrings to keep (e.g. 'foo|bar'). If omitted, keep all lines.") + return ap.parse_args(argv) + + +def main(argv: Optional[List[str]] = None) -> int: + args = parse_args(argv) + evlog = args.eventlog + if not os.path.isfile(evlog): + print(f"error: file not found: {evlog}", file=sys.stderr) + return 1 + + out = args.out + if out is None: + base = os.path.basename(evlog) + if base.endswith(".eventlog"): + out = base[:-len(".eventlog")] + ".events.txt" + else: + out = base + ".events.txt" + + contains_list: Optional[List[str]] = None + if args.contains: + contains_list = [s for s in args.contains.split("|") if s != ""] + + ghc_events = find_ghc_events() + if ghc_events is None: + if try_install_ghc_events(): + ghc_events = find_ghc_events() + else: + print("error: ghc-events not found; please install it (e.g., 'cabal install ghc-events')", file=sys.stderr) + return 1 + if ghc_events is None: + print("error: ghc-events still not found after installation.", file=sys.stderr) + return 1 + + cmd = [ghc_events, "show", evlog] + print(f"Dumping events from {evlog} to {out} using {ghc_events}...", file=sys.stderr) + rc = stream_and_filter(cmd, out, contains_list) + if rc != 0: + print(f"error: dump failed with exit code {rc}", file=sys.stderr) + return rc + + try: + size = os.path.getsize(out) + except Exception: + size = None + if size is None: + print(f"Wrote {out}.") + else: + print(f"Wrote {out} ({size} bytes).") + return 0 + + +if __name__ == "__main__": + raise SystemExit(main()) From f5a540abcb8d92f094db0a0db8ec7e7c518cb35b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 12 Sep 2025 14:15:48 +0800 Subject: [PATCH 097/107] fix hls-graph test --- ghcide/src/Development/IDE/Core/Rules.hs | 10 +- ghcide/src/Development/IDE/Core/Shake.hs | 38 ++--- .../src/Development/IDE/Graph/Database.hs | 12 +- .../IDE/Graph/Internal/Database.hs | 136 +++++++----------- .../Development/IDE/Graph/Internal/Types.hs | 70 ++++----- hls-graph/test/ActionSpec.hs | 38 +++-- hls-graph/test/DatabaseSpec.hs | 9 +- .../src/Ide/Plugin/SemanticTokens.hs | 2 +- scripts/flaky-test-loop.sh | 1 - 9 files changed, 132 insertions(+), 184 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index a2ced4d33e..b3293ce468 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -911,20 +911,16 @@ getModSummaryRule displayTHWarning recorder = do return (Just fp, Just res{msrModSummary = ms}) Nothing -> return (Nothing, Nothing) -generateCore :: Recorder (WithPriority Log) -> RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) -generateCore recorder runSimplifier file = do - liftIO $ traceEventIO "Generating Core1" +generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) +generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file - liftIO $ traceEventIO "Generating Core2" hsc' <- setFileCacheHook packageState - liftIO $ traceEventIO "Generating Core3" tm <- use_ TypeCheck file - liftIO $ traceEventIO "Generating Core4" liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder = - define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore recorder (RunSimplifier True) + define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 47e7dd2645..f47b6bab8e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -147,14 +147,14 @@ import Development.IDE.Graph hiding (ShakeValue, import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeComputeToPreserve, - shakeDatabaseReverseDep, shakeGetActionQueueLength, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeysSep, - shakeShutDatabase) + shakeShutDatabase, + shakedatabaseRuntimeRevDep) import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) import Development.IDE.Graph.Internal.Types (DBQue, Step (..), @@ -254,7 +254,8 @@ instance Pretty Log where [ "Restarting build session due to" <+> pretty (sraReason restartArgs) , "Restarts num:" <+> pretty (sraCount $ restartArgs) , "Action Queue:" <+> pretty (map actionName actionQueue) - , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) + -- , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) + , "Keys:" <+> pretty (length $ toListKeySet keyBackLog) , "Current step:" <+> pretty (show step) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> @@ -938,29 +939,21 @@ dynShakeRestart dy = case fromDynamic dy of Just shakeRestartArgs -> shakeRestartArgs Nothing -> error "Internal error, dynShakeRestart, got invalid dynamic type" -computePreserveAsyncs :: ShakeDatabase -> Set (Async ()) -computePreserveAsyncs shakeDb = mempty - runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO () runRestartTask recorder ideStateVar shakeRestartArgs = do IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar withShakeDatabaseValuesLock shakeDb $ do - let prepareRestart sra@ShakeRestartArgs {..} = do - keys <- sraBetweenSessions - -- it is every important to update the dirty keys after we enter the critical section - -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - -- Check if there is another restart request pending, if so, we run that one too - return (sra, keys) withMVar' shakeSession ( \runner -> do - (restartArgs, newDirtyKeys) <- prepareRestart shakeRestartArgs - reverseMap <- shakeDatabaseReverseDep shakeDb + newDirtyKeys <- sraBetweenSessions shakeRestartArgs + reverseMap <- shakedatabaseRuntimeRevDep shakeDb (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys - -- let (preservekvs, allRunning2) = ([], []) logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs + -- it is every important to update the dirty keys after we enter the critical section + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x newDirtyKeys queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras res <- shakeDatabaseProfile shakeDb @@ -968,8 +961,8 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- this log is required by tests step <- shakeGetBuildStep shakeDb - logWith recorder Info $ LogBuildSessionRestart restartArgs queue backlog stopTime res step - return restartArgs + logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime res step + return shakeRestartArgs ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. @@ -1069,18 +1062,15 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) res <- try @SomeException $ restore start - logWith recorder Debug $ LogBuildSessionFinish step res + logWith recorder Info $ LogBuildSessionFinish step res let keysActs = pumpActionThread : map run (reenqueued ++ acts) -- first we increase the step, so any actions started from here on - start <- shakeRunDatabaseForKeysSep (toListKeySet <$> allPendingKeys) shakeDb keysActs + startDatabase <- shakeRunDatabaseForKeysSep (toListKeySet <$> allPendingKeys) shakeDb keysActs -- Do the work in a background thread - parentTid <- myThreadId workThread <- asyncWithUnmask $ \x -> do - childThreadId <- myThreadId - -- logWith recorder Info $ LogShakeText ("shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")") - workRun start x + workRun startDatabase x -- Cancelling is required to flush the Shake database when either -- the filesystem or the Ghc configuration have changed diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 4fda4abe3c..2736d616b0 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -14,7 +14,7 @@ module Development.IDE.Graph.Database( shakeShutDatabase, shakeGetActionQueueLength, shakeComputeToPreserve, - shakeDatabaseReverseDep) where + shakedatabaseRuntimeRevDep) where import Control.Concurrent.Async (Async) import Control.Concurrent.STM.Stats (atomically, readTVarIO) @@ -81,16 +81,14 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged return $ drop lenAs1 <$> runActions (newKey "root") db (map unvoid as1 ++ as2) --- shakeDatabaseReverseDep :: ShakeDatabase -> --- shakeDatabaseReverseDep :: ShakeDatabase -> StmContainers.Map.Map Key KeySet -shakeDatabaseReverseDep :: ShakeDatabase -> IO [(Key, KeySet)] -shakeDatabaseReverseDep (ShakeDatabase _ _ db) = - atomically $ ListT.toList $ SMap.listT (databaseReverseDep db) --- StmContainers.Map.toList $ databaseReverseDep db +shakedatabaseRuntimeRevDep :: ShakeDatabase -> IO [(Key, KeySet)] +shakedatabaseRuntimeRevDep (ShakeDatabase _ _ db) = + atomically $ ListT.toList $ SMap.listT (databaseRuntimeRevDep db) -- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO (Set (Async ())) -- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO [(Key, Async ())] +shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) shakeComputeToPreserve (ShakeDatabase _ _ db) ks = atomically (computeToPreserve db ks) shakeRunDatabaseForKeys diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index ee910b1569..dc2698fe37 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -55,9 +55,9 @@ newDatabase :: (String -> IO ()) -> DBQue -> Dynamic -> TheRules -> IO Database newDatabase dataBaseLogger databaseQueue databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0 databaseThreads <- newTVarIO [] - databaseValuesLock <- newTVarIO False + databaseValuesLock <- newTVarIO True databaseValues <- atomically SMap.new - databaseReverseDep <- atomically SMap.new + databaseRuntimeRevDep <- atomically SMap.new pure Database{..} -- | Increment the step and mark dirty. @@ -116,92 +116,65 @@ build pk db stack keys = do builder :: (Traversable f) => Key -> Database -> Stack -> f Key -> IO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined builder pk db stack keys = do - waits <- for keys (\k -> builderOneCoroutine pk skipThread db stack k) + waits <- for keys (\k -> builderOne pk db stack k) for waits interpreBuildContinue - where skipThread = if length keys == 1 then IsSingleton else NotSingleton -data IsSingletonTask = IsSingleton | NotSingleton -- the first run should not block -data RunFirst = RunFirst | RunLater deriving stock (Eq, Show) data BuildContinue = BCContinue (IO (Key, Result)) | BCStop Key Result interpreBuildContinue :: BuildContinue -> IO (Key, Result) interpreBuildContinue (BCStop k v) = return (k, v) interpreBuildContinue (BCContinue ioR) = ioR --- possible improvements: --- suppose it is in the direct dirty set. We have already recorded the parent key as its reverse dep. --- fource possible situation --- running stage1, we have line up the run but it is scheduled after the restart. Clean. --- running stage2, all of it have gone before the restart. Dirty --- clean or exception, we picked old value. Dirty --- dirty, impossible situation, should throw errors. - --- stage 1 to stage 2 transition, run in serial - --- first we marked we have reached stage2, annotate the current step --- then spawn the thread to do the actual work --- finally, catch any (async) exception and mark the key as exception - --- submmittBuildInDb :: Database -> IO a -> IO a --- submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO () --- submmittBuildInDb db stack id s = do --- uninterruptibleMask_ $ do --- do --- curStep <- readTVarIO $ databaseStep db --- startBarrier <- newEmptyTMVarIO --- newAsync <- --- async --- (do --- uninterruptibleMask_ $ atomically $ readTMVar startBarrier --- void (refresh db stack id s) `catch` \e@(SomeException _) -> --- atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db) --- ) --- -- todo should only update if still at stage 1 --- -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db) --- atomically $ putTMVar startBarrier () --- atomically $ modifyTVar' (databaseThreads db) ((newAsync) :) - -builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue -builderOneCoroutine parentKey isSingletonTask db stack id = - builderOneCoroutine' db stack id - where - builderOneCoroutine' :: Database -> Stack -> Key -> IO BuildContinue - builderOneCoroutine' db@Database {..} stack id = do - traceEvent ("builderOne: " ++ show id) return () - barrier <- newEmptyMVar - liftIO $ atomicallyNamed "builder" $ do - -- Spawn the id if needed - dbNotLocked db - insertDatabaseReverseDepOne id parentKey db - -- if a build is running, wait - -- it will either be killed or continue - -- depending on wether it is marked as dirty - status <- SMap.lookup id databaseValues - current <- readTVar databaseStep - case viewDirty current $ maybe (Dirty Nothing) keyStatus status of - Dirty s -> do - -- we need to run serially to avoid summiting run but killed in the middle - let wait = readMVar barrier - runOneInDataBase (do { - status <- atomically (SMap.lookup id databaseValues) - ; let cur = fromIntegral $ case keyStatus <$> status of - Just (Running entryStep _s _wait RunningStage1) -> entryStep - _ -> current - ; return $ DeliverStatus cur (show (parentKey, id))}) db - (\adyncH -> - -- it is safe from worker thread - atomically $ SMap.focus (updateStatus $ Running current s wait (RunningStage2 adyncH) ) id databaseValues) - (refresh db stack id s >>= putMVar barrier . (id,)) $ \e -> do - atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues - putMVar barrier (throw e) - SMap.focus (updateStatus $ Running current s wait RunningStage1) id databaseValues - return $ BCContinue $ readMVar barrier - Clean r -> return $ BCStop id r - Running _step _s wait _ - | memberStack id stack -> throw $ StackException stack - | otherwise -> return $ BCContinue wait - Exception _ e _s -> throw e +builderOne :: Key -> Database -> Stack -> Key -> IO BuildContinue +builderOne parentKey db@Database {..} stack id = do + traceEvent ("builderOne: " ++ show id) return () + barrier <- newEmptyMVar + liftIO $ atomicallyNamed "builder" $ do + -- Spawn the id if needed + dbNotLocked db + insertdatabaseRuntimeRevDep id parentKey db + -- if a build is running, wait + -- it will either be killed or continue + -- depending on wether it is marked as dirty + status <- SMap.lookup id databaseValues + current <- readTVar databaseStep + case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Dirty s -> do + -- we need to run serially to avoid summiting run but killed in the middle + let wait = readMVar barrier + runOneInDataBase + ( do + status <- atomically (SMap.lookup id databaseValues) + let cur = fromIntegral $ case keyStatus <$> status of + -- this is ensure that we get an bumped up step when not dirty + -- after an restart to skipped an rerun + Just (Running entryStep _s _wait RunningStage1) -> entryStep + _ -> current + return $ DeliverStatus cur (show (parentKey, id)) + ) + db + ( \adyncH -> + -- it is safe from worker thread + atomically $ SMap.focus (updateStatus $ Running current s wait (RunningStage2 adyncH)) id databaseValues + ) + (refresh db stack id s >>= putMVar barrier . (id,)) + $ \e -> do + atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues + putMVar barrier (throw e) + SMap.focus (updateStatus $ Running current s wait RunningStage1) id databaseValues + return $ BCContinue $ readMVar barrier + Clean r -> return $ BCStop id r + Running _step _s wait _ + | memberStack id stack -> throw $ StackException stack + | otherwise -> return $ BCContinue wait + Exception _ e _s -> throw e + where + warpLog title a = + bracket_ + (dataBaseLogger ("Starting async action: " ++ title)) + (dataBaseLogger $ "Finished async action: " ++ title) + a -- | isDirty -- only dirty when it's build time is older than the changed time of one of its dependencies @@ -285,11 +258,6 @@ updateStatus res = Focus.alter (Just . maybe (KeyDetails res mempty) (\it -> it{keyStatus = res})) --- alterStatus :: Monad m => (Status -> Status) -> Focus.Focus KeyDetails m () --- alterStatus f = Focus.alter --- (Just . maybe (KeyDetails res mempty) --- (\it -> it{keyStatus = res})) - -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index f2f0232c51..4d7cc7982f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -24,13 +24,13 @@ import Data.Maybe (fromMaybe, isNothing) import Data.Set (Set) import qualified Data.Set as S import Data.Typeable -import Debug.Trace (traceEventIO, traceM) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.WorkerThread (DeliverStatus (..), TaskQueue (..), awaitRunInThread, - counTaskQueue) + counTaskQueue, + writeTaskQueue) import qualified Focus import GHC.Conc (TVar, atomically) import GHC.Generics (Generic) @@ -159,28 +159,28 @@ onKeyReverseDeps f it@KeyDetails{..} = type DBQue = TaskQueue (Either Dynamic (IO ())) data Database = Database { - databaseExtra :: Dynamic, + databaseExtra :: Dynamic, - databaseThreads :: TVar [(DeliverStatus, Async ())], + databaseThreads :: TVar [(DeliverStatus, Async ())], - databaseReverseDep :: SMap.Map Key KeySet, + databaseRuntimeRevDep :: SMap.Map Key KeySet, -- For each key, the set of keys that depend on it directly. -- it is used to compute the transitive reverse deps, so -- if not in any of the transitive reverse deps of a dirty node, it is clean -- we can skip clean the threads. -- this is update right before we query the database for the key result. - dataBaseLogger :: String -> IO (), + dataBaseLogger :: String -> IO (), - databaseQueue :: DBQue, + databaseQueue :: DBQue, - databaseRules :: TheRules, - databaseStep :: !(TVar Step), + databaseRules :: TheRules, + databaseStep :: !(TVar Step), - databaseValuesLock :: !(TVar Bool), + databaseValuesLock :: !(TVar Bool), -- when we restart a build, we set this to False to block any other -- threads from reading databaseValues - databaseValues :: !(Map Key KeyDetails) + databaseValues :: !(Map Key KeyDetails) } --------------------------------------------------------------------- @@ -196,9 +196,10 @@ computeToPreserve :: Database -> KeySet -> STM ([(Key, Async ())], [Key]) computeToPreserve db dirtySet = do -- All keys that depend (directly or transitively) on any dirty key affected <- computeTransitiveReverseDeps db dirtySet - running2 <- getRunningStage2Keys db allRunings <- getRunningKeys db - forM_ allRunings $ \k -> do + let allRuningkeys = map fst allRunings + let running2UnAffected = [ (k ,async) | (k, v) <- allRunings, not (k `memberKeySet` affected), Running _ _ _ (RunningStage2 async) <- [keyStatus v] ] + forM_ allRuningkeys $ \k -> do -- if not dirty, bump its step unless (memberKeySet k affected) $ do SMap.focus @@ -209,28 +210,18 @@ computeToPreserve db dirtySet = do ) k (databaseValues db) - - -- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty -- Keep only those whose key is NOT affected by the dirty set - pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings) - -getRunningStage2Keys :: Database -> STM [(Key, Async ())] --- getRunningStage2Keys db = return [] -getRunningStage2Keys db = do - pairs <- ListT.toList $ SMap.listT (databaseValues db) - return [(k, async) | (k, v) <- pairs, Running _ _ _ (RunningStage2 async) <- [keyStatus v]] + pure ([kv | kv@(k, _async) <- running2UnAffected, not (memberKeySet k affected)], allRuningkeys) -getRunningKeys :: Database -> STM [Key] +getRunningKeys :: Database -> STM [(Key, KeyDetails)] getRunningKeys db = do - pairs <- ListT.toList $ SMap.listT (databaseValues db) - return [k | (k, v) <- pairs, Running {} <- [keyStatus v]] - + ListT.toList $ SMap.listT (databaseValues db) -- compute the transitive reverse dependencies of a set of keys --- using databaseReverseDep in the Database +-- using databaseRuntimeRevDep in the Database computeTransitiveReverseDeps :: Database -> KeySet -> STM KeySet computeTransitiveReverseDeps db seeds = do - let rev = databaseReverseDep db + let rev = databaseRuntimeRevDep db -- BFS worklist starting from all seed keys. -- visited contains everything we've already enqueued (including seeds). @@ -250,17 +241,18 @@ computeTransitiveReverseDeps db seeds = do go seeds (toListKeySet seeds) +insertdatabaseRuntimeRevDep :: Key -> Key -> Database -> STM () +insertdatabaseRuntimeRevDep k pk db = do + SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k (databaseRuntimeRevDep db) -insertDatabaseReverseDepOne :: Key -> Key -> Database -> STM () -insertDatabaseReverseDepOne k pk db = do - SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k (databaseReverseDep db) +--------------------------------------------------------------------- +shakeDataBaseQueue :: ShakeDatabase -> DBQue +shakeDataBaseQueue = databaseQueue . (\(ShakeDatabase _ _ db) -> db) awaitRunInDb :: Database -> IO result -> IO result awaitRunInDb db act = awaitRunInThread (databaseQueue db) act -shakeDataBaseQueue :: ShakeDatabase -> DBQue -shakeDataBaseQueue = databaseQueue . (\(ShakeDatabase _ _ db) -> db) databaseGetActionQueueLength :: Database -> STM Int databaseGetActionQueueLength db = do @@ -276,15 +268,13 @@ runInThreadStmInNewThreads :: Database -> IO DeliverStatus -> [(Async () -> IO runInThreadStmInNewThreads db mkDeliver acts = do -- Take an action from TQueue, run it and -- use barrier to wait for the result - let TaskQueue q = databaseQueue db let log prefix title = dataBaseLogger db (prefix ++ title) - writeTQueue q $ Right $ do + writeTaskQueue (databaseQueue db) $ Right $ do uninterruptibleMask $ \restore -> do do deliver <- mkDeliver log "runInThreadStmInNewThreads submit begin " (deliverName deliver) curStep <- atomically $ getDataBaseStepInt db - -- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver) when (curStep == deliverStep deliver) $ do syncs <- mapM (\(preHook, act, handler) -> do a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e)) @@ -299,18 +289,12 @@ runOneInDataBase mkDelivery db registerAsync act handler = do runInThreadStmInNewThreads db mkDelivery - [ ( registerAsync, warpLog act, + [ ( registerAsync, act, \case Left e -> handler e Right _ -> return () ) ] - where - warpLog a = - bracket - (do (DeliverStatus _ title) <- mkDelivery; dataBaseLogger db ("Starting async action: " ++ title); return title) - (\title -> dataBaseLogger db $ "Finished async action: " ++ title) - (const a) getDataBaseStepInt :: Database -> STM Int diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 3e9aa7018b..865dcfb36f 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module ActionSpec where @@ -8,7 +9,11 @@ import qualified Control.Concurrent as C import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Cont (evalContT) -import Development.IDE.Graph (shakeOptions) +import Data.Typeable (Typeable) +import Development.IDE.Graph (RuleResult, + ShakeOptions, + shakeOptions) +import Development.IDE.Graph.Classes (Hashable) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys) @@ -23,9 +28,14 @@ import Test.Hspec +buildWithRoot :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Typeable value) => Database -> Stack -> f key -> IO (f Key, f value) +buildWithRoot = build (newKey ("root" :: [Char])) +shakeNewDatabaseWithLogger :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabaseWithLogger = shakeNewDatabase (const $ return ()) itInThread :: String -> (DBQue -> IO ()) -> SpecWith () itInThread name ex = it name $ evalContT $ do + -- thread <- withWorkerQueueSimpleRight (appendFile "hlg-graph-test.txt" . (++"\n") . show) "hls-graph test" thread <- withWorkerQueueSimpleRight (const $ return ()) "hls-graph test" liftIO $ ex thread @@ -53,7 +63,7 @@ spec = do return $ RunResult ChangedNothing "" r (return ()) count <- C.newMVar 0 count1 <- C.newMVar 0 - db <- shakeNewDatabase q shakeOptions $ do + db <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleSubBranch count ruleStep1 count1 -- bootstrapping the database @@ -74,18 +84,18 @@ spec = do c1 `shouldBe` 2 describe "apply1" $ do itInThread "computes a rule with no dependencies" $ \q -> do - db <- shakeNewDatabase q shakeOptions ruleUnit + db <- shakeNewDatabaseWithLogger q shakeOptions ruleUnit res <- shakeRunDatabaseFromRight db $ pure $ apply1 (Rule @()) res `shouldBe` [()] itInThread "computes a rule with one dependency" $ \q -> do - db <- shakeNewDatabase q shakeOptions $ do + db <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleUnit ruleBool res <- shakeRunDatabaseFromRight db $ pure $ apply1 Rule res `shouldBe` [True] itInThread "tracks direct dependencies" $ \q -> do - db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleUnit ruleBool let theKey = Rule @Bool @@ -95,7 +105,7 @@ spec = do Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())] itInThread "tracks reverse dependencies" $ \q -> do - db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase q shakeOptions $ do + db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleUnit ruleBool let theKey = Rule @Bool @@ -105,13 +115,13 @@ spec = do Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues keyReverseDeps `shouldBe` singletonKeySet (newKey theKey) itInThread "rethrows exceptions" $ \q -> do - db <- shakeNewDatabase q shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" + db <- shakeNewDatabaseWithLogger q shakeOptions $ addRule $ \(Rule :: Rule ()) _old _mode -> error "boom" let res = shakeRunDatabaseFromRight db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall itInThread "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ \q -> do cond <- C.newMVar True count <- C.newMVar 0 - (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleUnit ruleCond cond ruleSubBranch count @@ -119,19 +129,19 @@ spec = do -- build the one with the condition True -- This should call the SubBranchRule once -- cond rule would return different results each time - res0 <- build theDb emptyStack [BranchedRule] + res0 <- buildWithRoot theDb emptyStack [BranchedRule] snd res0 `shouldBe` [1 :: Int] incDatabase theDb Nothing -- build the one with the condition False -- This should not call the SubBranchRule - res1 <- build theDb emptyStack [BranchedRule] + res1 <- buildWithRoot theDb emptyStack [BranchedRule] snd res1 `shouldBe` [2 :: Int] -- SubBranchRule should be recomputed once before this (when the condition was True) - countRes <- build theDb emptyStack [SubBranchRule] + countRes <- buildWithRoot theDb emptyStack [SubBranchRule] snd countRes `shouldBe` [1 :: Int] describe "applyWithoutDependency" $ itInThread "does not track dependencies" $ \q -> do - db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 8036e4d5a8..0d81310dfc 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -4,7 +4,8 @@ module DatabaseSpec where import ActionSpec (itInThread) import Control.Exception (SomeException, throw) -import Development.IDE.Graph (newKey, shakeOptions) +import Development.IDE.Graph (ShakeOptions, newKey, + shakeOptions) import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) import Development.IDE.Graph.Internal.Action (apply1) @@ -21,12 +22,14 @@ exractException [] = Nothing exractException (Left e : _) | Just ne@StackException{} <- fromGraphException e = return ne exractException (_: xs) = exractException xs +shakeNewDatabaseWithLogger :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase +shakeNewDatabaseWithLogger = shakeNewDatabase (const $ return ()) spec :: Spec spec = do describe "Evaluation" $ do itInThread "detects cycles" $ \q -> do - db <- shakeNewDatabase q shakeOptions $ do + db <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) @@ -40,7 +43,7 @@ spec = do describe "compute" $ do itInThread "build step and changed step updated correctly" $ \q -> do - (ShakeDatabase _ _ theDb) <- shakeNewDatabase q shakeOptions $ do + (ShakeDatabase _ _ theDb) <- shakeNewDatabaseWithLogger q shakeOptions $ do ruleStep let k = newKey $ Rule @() -- ChangedRecomputeSame diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 8b2d8b3d8a..0c71684fc2 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -9,7 +9,7 @@ import Ide.Plugin.SemanticTokens.Types import Ide.Types import Language.LSP.Protocol.Message --- I hope that does mean much more sense now, only fire at the point would give a bit more than it should +-- This should make more sense now, only firing at the specific point to avoid giving more than needed descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides semantic tokens") diff --git a/scripts/flaky-test-loop.sh b/scripts/flaky-test-loop.sh index c072783cd1..2e3dfa9906 100755 --- a/scripts/flaky-test-loop.sh +++ b/scripts/flaky-test-loop.sh @@ -138,7 +138,6 @@ while true; do iter=$((iter+1)) ts=$(date -Iseconds) file_num=$((iter % 2)) - # if [[ ${file_num} -eq 0 ]]; then file_num=100; fi # Run each selected item (BIN::PATTERN) in this iteration for item in "${items[@]}"; do From 28a52a0211f0556b56b0c59586ea840f3849092d Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 10:42:55 +0800 Subject: [PATCH 098/107] add Debug.Trace import for traceEventIO usage --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 4d7cc7982f..5dcdf5ccc8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -24,6 +24,7 @@ import Data.Maybe (fromMaybe, isNothing) import Data.Set (Set) import qualified Data.Set as S import Data.Typeable +import Debug.Trace (traceEventIO) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.WorkerThread (DeliverStatus (..), From fafcc6875bd7349ae3079b61f601113f1ba4c414 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 10:54:06 +0800 Subject: [PATCH 099/107] fix wrong removal of databasevalues --- hls-graph/src/Development/IDE/Graph/Database.hs | 2 -- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 8 ++++---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 2736d616b0..7db3e3bc84 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -86,8 +86,6 @@ shakedatabaseRuntimeRevDep (ShakeDatabase _ _ db) = atomically $ ListT.toList $ SMap.listT (databaseRuntimeRevDep db) --- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO (Set (Async ())) --- shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO [(Key, Async ())] shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) shakeComputeToPreserve (ShakeDatabase _ _ db) ks = atomically (computeToPreserve db ks) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 5dcdf5ccc8..808326783d 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -204,10 +204,10 @@ computeToPreserve db dirtySet = do -- if not dirty, bump its step unless (memberKeySet k affected) $ do SMap.focus - ( Focus.alter $ \case - Just kd@KeyDetails {keyStatus = Running {runningStep, runningPrev, runningWait, runningStage}} -> - Just (kd {keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage}) - _ -> Nothing + ( Focus.adjust $ \case + kd@KeyDetails {keyStatus = Running {runningStep, runningPrev, runningWait, runningStage}} -> + (kd {keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage}) + kd -> kd ) k (databaseValues db) From 0059f6941f67091cf876145eddc732e7b7edc758 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 11:08:43 +0800 Subject: [PATCH 100/107] prune finished threads --- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- .../src/Development/IDE/Graph/Database.hs | 8 +- .../IDE/Graph/Internal/Database.hs | 6 +- .../Development/IDE/Graph/Internal/Types.hs | 76 ++++++++++++------- hls-graph/src/Development/IDE/WorkerThread.hs | 13 ++-- 5 files changed, 67 insertions(+), 40 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f47b6bab8e..4de57bf1f8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -154,7 +154,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeProfileDatabase, shakeRunDatabaseForKeysSep, shakeShutDatabase, - shakedatabaseRuntimeRevDep) + shakedatabaseRuntimeDep) import Development.IDE.Graph.Internal.Action (runActionInDbCb) import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill)) import Development.IDE.Graph.Internal.Types (DBQue, Step (..), @@ -947,7 +947,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do shakeSession ( \runner -> do newDirtyKeys <- sraBetweenSessions shakeRestartArgs - reverseMap <- shakedatabaseRuntimeRevDep shakeDb + reverseMap <- shakedatabaseRuntimeDep shakeDb (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 7db3e3bc84..80d7b1e004 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -14,7 +14,7 @@ module Development.IDE.Graph.Database( shakeShutDatabase, shakeGetActionQueueLength, shakeComputeToPreserve, - shakedatabaseRuntimeRevDep) where + shakedatabaseRuntimeDep) where import Control.Concurrent.Async (Async) import Control.Concurrent.STM.Stats (atomically, readTVarIO) @@ -81,9 +81,9 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged return $ drop lenAs1 <$> runActions (newKey "root") db (map unvoid as1 ++ as2) -shakedatabaseRuntimeRevDep :: ShakeDatabase -> IO [(Key, KeySet)] -shakedatabaseRuntimeRevDep (ShakeDatabase _ _ db) = - atomically $ ListT.toList $ SMap.listT (databaseRuntimeRevDep db) +shakedatabaseRuntimeDep :: ShakeDatabase -> IO [(Key, KeySet)] +shakedatabaseRuntimeDep (ShakeDatabase _ _ db) = + atomically $ ListT.toList $ SMap.listT (databaseRuntimeDep db) shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index dc2698fe37..71a98e8f03 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -57,7 +57,7 @@ newDatabase dataBaseLogger databaseQueue databaseExtra databaseRules = do databaseThreads <- newTVarIO [] databaseValuesLock <- newTVarIO True databaseValues <- atomically SMap.new - databaseRuntimeRevDep <- atomically SMap.new + databaseRuntimeDep <- atomically SMap.new pure Database{..} -- | Increment the step and mark dirty. @@ -133,7 +133,7 @@ builderOne parentKey db@Database {..} stack id = do liftIO $ atomicallyNamed "builder" $ do -- Spawn the id if needed dbNotLocked db - insertdatabaseRuntimeRevDep id parentKey db + insertdatabaseRuntimeDep id parentKey db -- if a build is running, wait -- it will either be killed or continue -- depending on wether it is marked as dirty @@ -151,7 +151,7 @@ builderOne parentKey db@Database {..} stack id = do -- after an restart to skipped an rerun Just (Running entryStep _s _wait RunningStage1) -> entryStep _ -> current - return $ DeliverStatus cur (show (parentKey, id)) + return $ DeliverStatus cur (show (parentKey, id)) (newKey id) ) db ( \adyncH -> diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 808326783d..6325221517 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -20,7 +20,8 @@ import Data.Foldable (fold) import qualified Data.HashMap.Strict as Map import Data.IORef import Data.List (intercalate) -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isJust, + isNothing) import Data.Set (Set) import qualified Data.Set as S import Data.Typeable @@ -160,31 +161,56 @@ onKeyReverseDeps f it@KeyDetails{..} = type DBQue = TaskQueue (Either Dynamic (IO ())) data Database = Database { - databaseExtra :: Dynamic, + databaseExtra :: Dynamic, - databaseThreads :: TVar [(DeliverStatus, Async ())], - - databaseRuntimeRevDep :: SMap.Map Key KeySet, - -- For each key, the set of keys that depend on it directly. + databaseThreads :: TVar [(DeliverStatus, Async ())], + databaseRuntimeDep :: SMap.Map Key KeySet, -- it is used to compute the transitive reverse deps, so -- if not in any of the transitive reverse deps of a dirty node, it is clean -- we can skip clean the threads. -- this is update right before we query the database for the key result. - dataBaseLogger :: String -> IO (), + dataBaseLogger :: String -> IO (), - databaseQueue :: DBQue, + databaseQueue :: DBQue, - databaseRules :: TheRules, - databaseStep :: !(TVar Step), + databaseRules :: TheRules, + databaseStep :: !(TVar Step), - databaseValuesLock :: !(TVar Bool), + databaseValuesLock :: !(TVar Bool), -- when we restart a build, we set this to False to block any other -- threads from reading databaseValues - databaseValues :: !(Map Key KeyDetails) + databaseValues :: !(Map Key KeyDetails) } --------------------------------------------------------------------- +-- | Remove finished asyncs from 'databaseThreads' (non-blocking). +-- Uses 'poll' to check completion without waiting. +pruneFinished :: Database -> IO () +pruneFinished db@Database{..} = do + threads <- readTVarIO databaseThreads + statuses <- forM threads $ \(d,a) -> do + p <- poll a + return (d,a,p) + let still = [ (d,a) | (d,a,p) <- statuses, isNothing p ] + -- deleteDatabaseRuntimeDep of finished async keys + forM_ statuses $ \(d,_,p) -> when (isJust p) $ do + let k = deliverKey d + atomically $ deleteDatabaseRuntimeDep k db + atomically $ modifyTVar' databaseThreads (const still) + +deleteDatabaseRuntimeDep :: Key -> Database -> STM () +deleteDatabaseRuntimeDep k db = do + SMap.delete k (databaseRuntimeDep db) + +computeReverseRuntimeMap :: Database -> STM (Map Key KeySet) +computeReverseRuntimeMap db = do + -- Create a fresh STM Map and copy the current runtime reverse deps into it. + -- This yields a stable snapshot that won't be mutated by concurrent updates. + m <- SMap.new + pairs <- ListT.toList $ SMap.listT (databaseRuntimeDep db) + forM_ pairs $ \(k, ks) -> SMap.insert ks k m + pure m -- compute to preserve asyncs -- only the running stage 2 keys are actually running -- so we only need to preserve them if they are not affected by the dirty set @@ -197,7 +223,7 @@ computeToPreserve :: Database -> KeySet -> STM ([(Key, Async ())], [Key]) computeToPreserve db dirtySet = do -- All keys that depend (directly or transitively) on any dirty key affected <- computeTransitiveReverseDeps db dirtySet - allRunings <- getRunningKeys db + allRunings <- ListT.toList $ SMap.listT (databaseValues db) let allRuningkeys = map fst allRunings let running2UnAffected = [ (k ,async) | (k, v) <- allRunings, not (k `memberKeySet` affected), Running _ _ _ (RunningStage2 async) <- [keyStatus v] ] forM_ allRuningkeys $ \k -> do @@ -214,17 +240,14 @@ computeToPreserve db dirtySet = do -- Keep only those whose key is NOT affected by the dirty set pure ([kv | kv@(k, _async) <- running2UnAffected, not (memberKeySet k affected)], allRuningkeys) -getRunningKeys :: Database -> STM [(Key, KeyDetails)] -getRunningKeys db = do - ListT.toList $ SMap.listT (databaseValues db) - -- compute the transitive reverse dependencies of a set of keys --- using databaseRuntimeRevDep in the Database +-- using databaseRuntimeDep in the Database +-- compute the transitive reverse dependencies of a set of keys +-- using databaseRuntimeDep in the Database computeTransitiveReverseDeps :: Database -> KeySet -> STM KeySet computeTransitiveReverseDeps db seeds = do - let rev = databaseRuntimeRevDep db - - -- BFS worklist starting from all seed keys. + rev <- computeReverseRuntimeMap db + let -- BFS worklist starting from all seed keys. -- visited contains everything we've already enqueued (including seeds). go :: KeySet -> [Key] -> STM KeySet go visited [] = pure visited @@ -242,9 +265,9 @@ computeTransitiveReverseDeps db seeds = do go seeds (toListKeySet seeds) -insertdatabaseRuntimeRevDep :: Key -> Key -> Database -> STM () -insertdatabaseRuntimeRevDep k pk db = do - SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k (databaseRuntimeRevDep db) +insertdatabaseRuntimeDep :: Key -> Key -> Database -> STM () +insertdatabaseRuntimeDep k pk db = do + SMap.focus (Focus.alter (Just . maybe (singletonKeySet k) (insertKeySet k))) pk (databaseRuntimeDep db) --------------------------------------------------------------------- @@ -263,7 +286,7 @@ runInDataBase :: String -> Database -> [(IO result, Either SomeException result runInDataBase title db acts = do s <- getDataBaseStepInt db let actWithEmptyHook = map (\(x, y) -> (const $ return (), x, y)) acts - runInThreadStmInNewThreads db (return $ DeliverStatus s title) actWithEmptyHook + runInThreadStmInNewThreads db (return $ DeliverStatus s title (newKey "root")) actWithEmptyHook runInThreadStmInNewThreads :: Database -> IO DeliverStatus -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM () runInThreadStmInNewThreads db mkDeliver acts = do @@ -311,7 +334,7 @@ instance Exception AsyncParentKill where fromException = asyncExceptionFromException shutDatabase ::Set (Async ()) -> Database -> IO () -shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do +shutDatabase preserve db@Database{..} = uninterruptibleMask $ \unmask -> do -- wait for all threads to finish asyncs <- readTVarIO databaseThreads step <- readTVarIO databaseStep @@ -339,6 +362,7 @@ shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do traceEventIO $ "cleanupAsync: still running (deliverName, threadId) = " ++ show still withAsync warnIfTakingTooLong $ \_ -> mapM_ waitCatch $ map snd toCancel + pruneFinished db -- waitForDatabaseRunningKeys :: Database -> IO () -- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 3897120bf5..5fb86ba0e9 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -28,14 +28,16 @@ module Development.IDE.WorkerThread awaitRunInThread ) where -import Control.Concurrent.Async (withAsync) +import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM -import Control.Exception.Safe (SomeException, finally, throw, try) -import Control.Monad.Cont (ContT (ContT)) -import qualified Data.Text as T +import Control.Exception.Safe (SomeException, finally, + throw, try) +import Control.Monad.Cont (ContT (ContT)) +import qualified Data.Text as T import Control.Concurrent -import Data.Dynamic (Dynamic) +import Data.Dynamic (Dynamic) +import Development.IDE.Graph.Internal.Key (Key) import Prettyprinter data LogWorkerThread @@ -127,6 +129,7 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do data DeliverStatus = DeliverStatus { deliverStep :: Int , deliverName :: String + , deliverKey :: Key } deriving (Show) From 538b1f6aec60dcac4ec625dcb80bf7d404b093ec Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 11:53:13 +0800 Subject: [PATCH 101/107] prevent deletion of root key in pruneFinished function --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 6325221517..0fabe6ad07 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -196,7 +196,7 @@ pruneFinished db@Database{..} = do -- deleteDatabaseRuntimeDep of finished async keys forM_ statuses $ \(d,_,p) -> when (isJust p) $ do let k = deliverKey d - atomically $ deleteDatabaseRuntimeDep k db + when (k /= newKey "root") $ atomically $ deleteDatabaseRuntimeDep k db atomically $ modifyTVar' databaseThreads (const still) deleteDatabaseRuntimeDep :: Key -> Database -> STM () From 8689ff766abd67481e564c2e050f350cb2bec235 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 14:07:01 +0800 Subject: [PATCH 102/107] cleanup --- ghcide/src/Development/IDE/Core/Shake.hs | 9 ++++-- .../src/Development/IDE/Graph/Database.hs | 8 ++++- .../IDE/Graph/Internal/Database.hs | 30 ++++++++----------- .../Development/IDE/Graph/Internal/Types.hs | 6 +++- hls-graph/src/Development/IDE/WorkerThread.hs | 4 +++ 5 files changed, 34 insertions(+), 23 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4de57bf1f8..bdfea5402e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -151,6 +151,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, shakeGetDatabaseKeys, shakeNewDatabase, + shakePeekAsyncsDelivers, shakeProfileDatabase, shakeRunDatabaseForKeysSep, shakeShutDatabase, @@ -207,7 +208,7 @@ import Data.Foldable (foldl') data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !ShakeRestartArgs ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int + | LogBuildSessionRestart !ShakeRestartArgs ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int ![DeliverStatus] | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()]) @@ -249,13 +250,14 @@ instance Pretty Log where "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize - LogBuildSessionRestart restartArgs actionQueue keyBackLog abortDuration shakeProfilePath step -> + LogBuildSessionRestart restartArgs actionQueue keyBackLog abortDuration shakeProfilePath step delivers -> vcat [ "Restarting build session due to" <+> pretty (sraReason restartArgs) , "Restarts num:" <+> pretty (sraCount $ restartArgs) , "Action Queue:" <+> pretty (map actionName actionQueue) -- , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) , "Keys:" <+> pretty (length $ toListKeySet keyBackLog) + , "Deliveries still alive:" <+> pretty delivers , "Current step:" <+> pretty (show step) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> @@ -951,6 +953,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap (stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs + survivedDelivers <- shakePeekAsyncsDelivers shakeDb -- it is every important to update the dirty keys after we enter the critical section -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x newDirtyKeys @@ -961,7 +964,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do -- this log is required by tests step <- shakeGetBuildStep shakeDb - logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime res step + logWith recorder Info $ LogBuildSessionRestart shakeRestartArgs queue backlog stopTime res step survivedDelivers return shakeRestartArgs ) -- It is crucial to be masked here, otherwise we can get killed diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 80d7b1e004..cd0665e71a 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -14,7 +14,8 @@ module Development.IDE.Graph.Database( shakeShutDatabase, shakeGetActionQueueLength, shakeComputeToPreserve, - shakedatabaseRuntimeDep) where + shakedatabaseRuntimeDep, + shakePeekAsyncsDelivers) where import Control.Concurrent.Async (Async) import Control.Concurrent.STM.Stats (atomically, readTVarIO) @@ -32,6 +33,7 @@ import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import Development.IDE.WorkerThread (DeliverStatus) import qualified ListT import qualified StmContainers.Map import qualified StmContainers.Map as SMap @@ -89,6 +91,8 @@ shakedatabaseRuntimeDep (ShakeDatabase _ _ db) = shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) shakeComputeToPreserve (ShakeDatabase _ _ db) ks = atomically (computeToPreserve db ks) +--a dsfds +-- fds make it possible to do al ot of jobs shakeRunDatabaseForKeys :: Maybe [Key] -- ^ Set of keys changed since last run. 'Nothing' means everything has changed @@ -98,6 +102,8 @@ shakeRunDatabaseForKeys shakeRunDatabaseForKeys keysChanged sdb as2 = join $ shakeRunDatabaseForKeysSep keysChanged sdb as2 +shakePeekAsyncsDelivers :: ShakeDatabase -> IO [DeliverStatus] +shakePeekAsyncsDelivers (ShakeDatabase _ _ db) = peekAsyncsDelivers db -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 71a98e8f03..672604e17c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -88,26 +88,20 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> | otherwise = status in KeyDetails status' rdeps -- | Unwrap and build a list of keys in parallel -build - :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) - => Key -> Database -> Stack -> f key -> IO (f Key, f value) +build :: + forall f key value. + (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) => + Key -> Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined build pk db stack keys = do - step <- readTVarIO $ databaseStep db - go `catch` \e@(AsyncParentKill i s) -> do - if s == step - then throw e - else throw $ AsyncParentKill i $ Step (-1) - where - go = do - -- step <- readTVarIO $ databaseStep db - -- built <- mapConcurrently (builderOne db stack) (fmap newKey keys) - built <- builder pk db stack (fmap newKey keys) - let (ids, vs) = unzip built - pure (ids, fmap (asV . resultValue) vs) - where - asV :: Value -> value - asV (Value x) = unwrapDynamic x + -- step <- readTVarIO $ databaseStep db + -- built <- mapConcurrently (builderOne db stack) (fmap newKey keys) + built <- builder pk db stack (fmap newKey keys) + let (ids, vs) = unzip built + pure (ids, fmap (asV . resultValue) vs) + where + asV :: Value -> value + asV (Value x) = unwrapDynamic x -- | Build a list of keys and return their results. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 0fabe6ad07..6073d203d4 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -225,7 +225,7 @@ computeToPreserve db dirtySet = do affected <- computeTransitiveReverseDeps db dirtySet allRunings <- ListT.toList $ SMap.listT (databaseValues db) let allRuningkeys = map fst allRunings - let running2UnAffected = [ (k ,async) | (k, v) <- allRunings, not (k `memberKeySet` affected), Running _ _ _ (RunningStage2 async) <- [keyStatus v] ] + let running2UnAffected = [ (k, async) | (k, v) <- allRunings, not (k `memberKeySet` affected), Running _ _ _ (RunningStage2 async) <- [keyStatus v] ] forM_ allRuningkeys $ \k -> do -- if not dirty, bump its step unless (memberKeySet k affected) $ do @@ -364,6 +364,10 @@ shutDatabase preserve db@Database{..} = uninterruptibleMask $ \unmask -> do mapM_ waitCatch $ map snd toCancel pruneFinished db +peekAsyncsDelivers :: Database -> IO [DeliverStatus] +peekAsyncsDelivers db = do + asyncs <- readTVarIO (databaseThreads db) + return (map fst asyncs) -- waitForDatabaseRunningKeys :: Database -> IO () -- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index 5fb86ba0e9..c9e34b9a7b 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -132,6 +132,10 @@ data DeliverStatus = DeliverStatus , deliverKey :: Key } deriving (Show) +instance Pretty DeliverStatus where + pretty (DeliverStatus step _name key) = + "Step:" <+> pretty step <> "," <+> "Key:" <+> pretty (show key) + type Worker arg = arg -> IO () From 4ddcf49687a98adfe4dd8d41474563893a73b83b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 14:57:18 +0800 Subject: [PATCH 103/107] fix computeReverseRuntimeMap --- hls-graph/src/Development/IDE/Graph/Database.hs | 2 +- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index cd0665e71a..45ad5f4ebe 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -85,7 +85,7 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do shakedatabaseRuntimeDep :: ShakeDatabase -> IO [(Key, KeySet)] shakedatabaseRuntimeDep (ShakeDatabase _ _ db) = - atomically $ ListT.toList $ SMap.listT (databaseRuntimeDep db) + atomically $ (ListT.toList . SMap.listT) =<< computeReverseRuntimeMap db shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 6073d203d4..90ad751bd5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -209,7 +209,8 @@ computeReverseRuntimeMap db = do -- This yields a stable snapshot that won't be mutated by concurrent updates. m <- SMap.new pairs <- ListT.toList $ SMap.listT (databaseRuntimeDep db) - forM_ pairs $ \(k, ks) -> SMap.insert ks k m + forM_ pairs $ \(pk, ks) -> forM_ (toListKeySet ks) $ \k -> + SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k m pure m -- compute to preserve asyncs -- only the running stage 2 keys are actually running From 0d548be77861d43e270bd04033908fec7da5719a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 15:30:01 +0800 Subject: [PATCH 104/107] use hashmap to compute reverseDep --- .../src/Development/IDE/Graph/Database.hs | 7 ++----- .../Development/IDE/Graph/Internal/Types.hs | 20 ++++++++++--------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 45ad5f4ebe..0c942e9074 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -22,9 +22,9 @@ import Control.Concurrent.STM.Stats (atomically, import Control.Exception (SomeException) import Control.Monad (join) import Data.Dynamic +import Data.HashMap.Strict (toList) import Data.Maybe import Data.Set (Set) -import qualified Data.Set as Set import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database @@ -34,9 +34,6 @@ import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types import Development.IDE.WorkerThread (DeliverStatus) -import qualified ListT -import qualified StmContainers.Map -import qualified StmContainers.Map as SMap -- Placeholder to be the 'extra' if the user doesn't set it @@ -85,7 +82,7 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do shakedatabaseRuntimeDep :: ShakeDatabase -> IO [(Key, KeySet)] shakedatabaseRuntimeDep (ShakeDatabase _ _ db) = - atomically $ (ListT.toList . SMap.listT) =<< computeReverseRuntimeMap db + atomically $ toList <$> computeReverseRuntimeMap db shakeComputeToPreserve :: ShakeDatabase -> KeySet -> IO ([(Key, Async ())], [Key]) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 90ad751bd5..43151566b1 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -46,7 +46,7 @@ import UnliftIO (Async (asyncThreadId), asyncExceptionToException, poll, readTVar, readTVarIO, throwTo, waitCatch, - withAsync, writeTQueue) + withAsync) import UnliftIO.Concurrent (ThreadId, myThreadId) import qualified UnliftIO.Exception as UE @@ -203,15 +203,17 @@ deleteDatabaseRuntimeDep :: Key -> Database -> STM () deleteDatabaseRuntimeDep k db = do SMap.delete k (databaseRuntimeDep db) -computeReverseRuntimeMap :: Database -> STM (Map Key KeySet) +computeReverseRuntimeMap :: Database -> STM (Map.HashMap Key KeySet) computeReverseRuntimeMap db = do - -- Create a fresh STM Map and copy the current runtime reverse deps into it. - -- This yields a stable snapshot that won't be mutated by concurrent updates. - m <- SMap.new + -- Create a fresh snapshot (pure Data.Map) of the current runtime reverse deps. pairs <- ListT.toList $ SMap.listT (databaseRuntimeDep db) - forM_ pairs $ \(pk, ks) -> forM_ (toListKeySet ks) $ \k -> - SMap.focus (Focus.alter (Just . maybe (singletonKeySet pk) (insertKeySet pk))) k m - pure m + -- 'pairs' is a map from parent -> set of children (dependencies recorded at runtime). + -- We need to invert this to child -> set of parents (reverse dependencies). + let addParent acc (parent, children) = + foldr (\child m -> Map.insertWith (\new old -> unionKyeSet new old) child (singletonKeySet parent) m) acc (toListKeySet children) + m = foldl addParent Map.empty pairs + return m + -- compute to preserve asyncs -- only the running stage 2 keys are actually running -- so we only need to preserve them if they are not affected by the dirty set @@ -253,7 +255,7 @@ computeTransitiveReverseDeps db seeds = do go :: KeySet -> [Key] -> STM KeySet go visited [] = pure visited go visited (k:todo) = do - mDeps <- SMap.lookup k rev + let mDeps = Map.lookup k rev case mDeps of Nothing -> go visited todo Just direct -> From 28bff495130df61b1038883d9b27b300d5fab6e4 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 29 Aug 2025 05:32:38 +0800 Subject: [PATCH 105/107] Enhance testing workflow and progress reporting - Refactor test workflow to simplify test commands. - Introduce TestReporting style for progress reporting in IDE options. --- .../Development/IDE/Core/ProgressReporting.hs | 40 ++++++++++++++++--- ghcide/src/Development/IDE/Main.hs | 8 +++- ghcide/src/Development/IDE/Types/Options.hs | 1 + 3 files changed, 42 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 3d8a2bf989..4bf4b10ab5 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -23,24 +23,31 @@ import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, retry) -import Control.Concurrent.Strict (modifyVar_, newVar, - threadDelay) +import Control.Concurrent.Strict (modifyVar_, newBarrier, newVar, + signalBarrier, threadDelay, + waitBarrier) import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import qualified Data.Aeson as J import Data.Functor (($>)) import qualified Data.Text as T +import Data.Unique (hashUnique, newUnique) import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus +import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (ProgressAmount (..), +import qualified Language.LSP.Protocol.Types as L +import Language.LSP.Server (MonadLsp, ProgressAmount (..), ProgressCancellable (..), + sendNotification, sendRequest, withProgress) import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM import UnliftIO (Async, async, bracket, cancel) +import qualified UnliftIO.Exception as UE data ProgressEvent = ProgressNewStarted @@ -168,7 +175,7 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do let _progressUpdate event = liftIO $ updateStateVar $ Event event _progressStop = updateStateVar StopProgress updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) - return ProgressReporting {..} + return ProgressReporting {_progressUpdate, _progressStop} -- | `progressReporting` initiates a new progress reporting session. -- It necessitates the active tracking of progress using the `inProgress` function. @@ -196,6 +203,25 @@ progressReporting (Just lspEnv) title optProgressStyle = do f = recordProgress inProgress file +withProgressDummy :: + forall c m a. + MonadLsp c m => + T.Text -> + Maybe ProgressToken -> + ProgressCancellable -> + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressDummy title _ _ f = do + t <- L.ProgressToken . L.InR . T.pack . show . hashUnique <$> liftIO newUnique + r <- liftIO newBarrier + _ <- sendRequest SMethod_WindowWorkDoneProgressCreate (WorkDoneProgressCreateParams t) $ + \_ -> liftIO $ signalBarrier r () + -- liftIO $ waitBarrier r + sendProgressReport t $ WorkDoneProgressBegin L.AString title Nothing Nothing Nothing + f (const $ return ()) `UE.finally` sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) + where + sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report + -- Kill this to complete the progress session progressCounter :: LSP.LanguageContextEnv c -> @@ -205,8 +231,12 @@ progressCounter :: STM Int -> IO () progressCounter lspEnv title optProgressStyle getTodo getDone = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 + LSP.runLspT lspEnv $ withProgressChoice title Nothing NotCancellable $ \update -> loop update 0 where + withProgressChoice = case optProgressStyle of + TestReporting -> withProgressDummy + _ -> withProgress + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do (todo, done, nextPct) <- liftIO $ atomically $ do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index afb50de96f..6b791acd5e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,8 +77,9 @@ import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), + IdeOptions (..), IdeTesting (IdeTesting), + ProgressReportingStyle (TestReporting), clientSupportsProgress, defaultIdeOptions, optModifyDynFlags, @@ -276,7 +277,10 @@ testing recorder projectRoot plugins = let defOptions = argsIdeOptions config sessionLoader in - defOptions{ optTesting = IdeTesting True } + defOptions{ + optTesting = IdeTesting True + , optProgressStyle = TestReporting + } lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in arguments diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 8d4d91e166..124e7a9469 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -107,6 +107,7 @@ newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool data ProgressReportingStyle = Percentage -- ^ Report using the LSP @_percentage@ field | Explicit -- ^ Report using explicit 123/456 text + | TestReporting -- ^ Special mode for testing, reports only start/stop | NoProgress -- ^ Do not report any percentage deriving Eq From ed74540cd7efa8152e4320d72bff3defa602cd22 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Sat, 13 Sep 2025 15:47:52 +0800 Subject: [PATCH 106/107] fix 9.6 --- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 672604e17c..9102881299 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -35,6 +35,7 @@ import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import Development.IDE.WorkerThread (DeliverStatus (DeliverStatus)) import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap @@ -45,7 +46,6 @@ import UnliftIO (async, atomically, #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) -import Development.IDE.WorkerThread (DeliverStatus (DeliverStatus)) #else import Data.List.NonEmpty (unzip) #endif From 0cc888bd9e090803c22f6c68378dda63cd59829b Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 15 Sep 2025 08:18:50 +0800 Subject: [PATCH 107/107] cleanup --- .../Development/IDE/Graph/Internal/Action.hs | 35 ++++++++++--------- .../Development/IDE/Graph/Internal/Types.hs | 15 ++++---- hls-graph/src/Development/IDE/WorkerThread.hs | 16 +++++++-- 3 files changed, 40 insertions(+), 26 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index cd8cd67f41..adac90f3b9 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -21,8 +21,9 @@ import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class +import Control.Monad.RWS (MonadReader (ask), + asks) import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader import Data.Foldable (toList) import Data.Functor.Identity import Data.IORef @@ -41,13 +42,13 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) -- | Always rerun this rule when dirty, regardless of the dependencies. alwaysRerun :: Action () alwaysRerun = do - ref <- Action $ asks actionDeps + ref <- asks actionDeps liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) parallel :: [Action a] -> Action [Either SomeException a] parallel [] = return [] parallel xs = do - a <- Action ask + a <- ask deps <- liftIO $ readIORef $ actionDeps a case deps of UnknownDeps -> @@ -61,7 +62,7 @@ parallel xs = do -- non-blocking version of runActionInDb runActionInDbCb :: (a -> String) -> (a -> Action result) -> STM a -> (Either SomeException result -> IO ()) -> Action a runActionInDbCb getTitle work getAct handler = do - a <- Action ask + a <- ask liftIO $ atomicallyNamed "action queue - pop" $ do act <- getAct runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)] @@ -69,7 +70,7 @@ runActionInDbCb getTitle work getAct handler = do runActionInDb :: String -> [Action a] -> Action [Either SomeException a] runActionInDb title acts = do - a <- Action ask + a <- ask xs <- mapM (\x -> do barrier <- newEmptyTMVarIO return (x, barrier)) acts @@ -81,7 +82,7 @@ runActionInDb title acts = do ignoreState :: SAction -> Action b -> IO b ignoreState a x = do ref <- newIORef mempty - runReaderT (fromAction x) a{actionDeps=ref} + runActionMonad x a{actionDeps=ref} isAsyncException :: SomeException -> Bool isAsyncException e @@ -95,8 +96,8 @@ isAsyncException e actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a actionCatch a b = do - v <- Action ask - Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v) + v <- ask + liftIO $ catchJust f (runActionMonad a v) (\x -> runActionMonad (b x) v) where -- Catch only catches exceptions that were caused by this code, not those that -- are a result of program termination @@ -105,24 +106,24 @@ actionCatch a b = do actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c actionBracket a b c = do - v <- Action ask - Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v) + v <- ask + liftIO $ bracket a b (\x -> runActionMonad (c x) v) actionFinally :: Action a -> IO b -> Action a actionFinally a b = do v <- Action ask - Action $ lift $ finally (runReaderT (fromAction a) v) b + Action $ lift $ finally (runActionMonad a v) b apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value apply1 k = runIdentity <$> apply (Identity k) apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) apply ks = do - db <- Action $ asks actionDatabase - stack <- Action $ asks actionStack + db <- asks actionDatabase + stack <- asks actionStack pk <- getActionKey (is, vs) <- liftIO $ build pk db stack ks - ref <- Action $ asks actionDeps + ref <- asks actionDeps let !ks = force $ fromListKeySet $ toList is liftIO $ modifyIORef' ref (ResultDeps [ks] <>) pure vs @@ -130,8 +131,8 @@ apply ks = do -- | Evaluate a list of keys without recording any dependencies. applyWithoutDependency :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value) applyWithoutDependency ks = do - db <- Action $ asks actionDatabase - stack <- Action $ asks actionStack + db <- asks actionDatabase + stack <- asks actionStack pk <- getActionKey (_, vs) <- liftIO $ build pk db stack ks pure vs @@ -139,7 +140,7 @@ applyWithoutDependency ks = do runActions :: Key -> Database -> [Action a] -> IO [Either SomeException a] runActions pk db xs = do deps <- newIORef mempty - runReaderT (fromAction $ parallel xs) $ SAction pk db deps emptyStack + runActionMonad (parallel xs) $ SAction pk db deps emptyStack -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Action [(Key, Int)] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 43151566b1..447a9f9e8f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -11,7 +11,8 @@ import Control.Monad (forM, forM_, forever, unless, when) import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Monad.Trans.Reader +import Control.Monad.RWS (MonadReader (local), asks) +import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (second) import qualified Data.ByteString as BS @@ -88,7 +89,10 @@ data SRules = SRules { -- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is -- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'. newtype Action a = Action {fromAction :: ReaderT SAction IO a} - deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO) + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO, MonadReader SAction) + +runActionMonad :: Action a -> SAction -> IO a +runActionMonad (Action r) s = runReaderT r s data SAction = SAction { actionKey :: !Key, @@ -98,14 +102,13 @@ data SAction = SAction { } getDatabase :: Action Database -getDatabase = Action $ asks actionDatabase +getDatabase = asks actionDatabase getActionKey :: Action Key -getActionKey = Action $ asks actionKey +getActionKey = asks actionKey setActionKey :: Key -> Action a -> Action a -setActionKey k (Action act) = Action $ do - local (\s' -> s'{actionKey = k}) act +setActionKey k act = local (\s' -> s'{actionKey = k}) act -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. -- waitForDatabaseRunningKeysAction :: Action () diff --git a/hls-graph/src/Development/IDE/WorkerThread.hs b/hls-graph/src/Development/IDE/WorkerThread.hs index c9e34b9a7b..39783b220a 100644 --- a/hls-graph/src/Development/IDE/WorkerThread.hs +++ b/hls-graph/src/Development/IDE/WorkerThread.hs @@ -25,7 +25,8 @@ module Development.IDE.WorkerThread tryReadTaskQueue, withWorkerQueueSimpleRight, submitWorkAtHead, - awaitRunInThread + awaitRunInThread, + withAsyncs ) where import Control.Concurrent.Async (withAsync) @@ -81,8 +82,12 @@ withWorkerQueueSimple log title = withWorkerQueue log title id withWorkerQueueSimpleRight :: Logger -> T.Text -> ContT () IO (TaskQueue (Either Dynamic (IO ()))) withWorkerQueueSimpleRight log title = withWorkerQueue log title $ eitherWorker (const $ return ()) id + + withWorkerQueue :: Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) -withWorkerQueue log title workerAction = ContT $ \mainAction -> do +withWorkerQueue = withWorkersQueue 1 +withWorkersQueue :: Int -> Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) +withWorkersQueue n log title workerAction = ContT $ \mainAction -> do tid <- myThreadId log (LogMainThreadId title tid) q <- newTaskQueueIO @@ -94,7 +99,7 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job), -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant. b <- newEmptyTMVarIO - withAsync (writerThread q b) $ \_ -> do + withAsyncs (replicate n (writerThread q b)) $ do mainAction q -- if we want to debug the exact location the worker swallows an async exception, we can -- temporarily comment out the `finally` clause. @@ -121,6 +126,11 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do log $ LogSingleWorkEnded title writerThread q b +withAsyncs :: [IO ()] -> IO () -> IO () +withAsyncs ios mainAction = go ios + where + go [] = mainAction + go (x:xs) = withAsync x $ \_ -> go xs -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- and then blocks until the result is computed. If the action throws an