From 684a85042f6ca209d6c8f3b18e41b6d1d774da66 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 23 Apr 2024 04:59:55 +0800 Subject: [PATCH 01/32] passing keys need to be update directly to restartShakeSession --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/FileStore.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 6 ++++-- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 2 +- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a0d870d590..4b4294cd8a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -623,7 +623,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do invalidateShakeCache -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] + restartShakeSession VFSUnmodified "new component" [] [] -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7be4c71827..49e9ad3b5c 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -224,7 +224,7 @@ setFileModified recorder vfs state saved nfp = do CheckOnSave -> saved _ -> False join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] [] when checkParents $ typecheckParents recorder state nfp @@ -251,7 +251,7 @@ setSomethingModified vfs state keys reason = do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> foldl' (flip insertKeySet) x keys - void $ restartShakeSession (shakeExtras state) vfs reason [] + void $ restartShakeSession (shakeExtras state) vfs reason [] keys 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 a215ee42ef..d5ed2bc579 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -300,6 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] + -> [Key] -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -759,13 +760,14 @@ delayedAction a = do -- | 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 () -shakeRestart recorder IdeState{..} vfs reason acts = +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> [Key] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts keys = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7126dc14b1..2e305b2e45 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -133,7 +133,7 @@ Then we restart the shake session, so that changes to our virtual files are actu restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg = do join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] [] -- ---------------------------------------------------------------- -- Plugin Rules From 5d098374c0129b545721cd433d74bbe8988c8be5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:42:02 +0800 Subject: [PATCH 02/32] send actions to run between restart --- .../session-loader/Development/IDE/Session.hs | 20 ++++++-------- ghcide/src/Development/IDE/Core/FileStore.hs | 23 +++++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 8 +++--- .../src/Development/IDE/LSP/Notifications.hs | 26 +++++++++---------- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 20 +++++++------- 5 files changed, 48 insertions(+), 49 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4b4294cd8a..e862261480 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -611,19 +611,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do [ "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" ] - - void $ modifyVar' fileToFlags $ - Map.insert hieYaml this_flags_map - void $ modifyVar' filesMap $ - flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) - - void $ extendKnownTargets all_targets - - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] [] + restartShakeSession VFSUnmodified "new component" [] $ 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)) + void $ extendKnownTargets all_targets + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + invalidateShakeCache -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 49e9ad3b5c..d0e5d69876 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -216,15 +216,17 @@ setFileModified :: Recorder (WithPriority Log) -> Bool -- ^ Was the file saved? -> NormalizedFilePath -> IO () -setFileModified recorder vfs state saved nfp = do + -> IO () +setFileModified recorder vfs state saved nfp actionBefore = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSave -> saved _ -> False - join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + actionBefore + join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] when checkParents $ typecheckParents recorder state nfp @@ -244,14 +246,15 @@ 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 -> [Key] -> String -> IO () -setSomethingModified vfs state keys reason = do +setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () -> IO () +setSomethingModified vfs state keys reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted - atomically $ do - writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip insertKeySet) x keys - void $ restartShakeSession (shakeExtras state) vfs reason [] keys + void $ restartShakeSession (shakeExtras state) vfs reason [] $ do + actionBetweenSession + atomically $ do + writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> + foldl' (flip insertKeySet) x keys 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 d5ed2bc579..9003917f0c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -300,7 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] - -> [Key] + -> IO () -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -760,14 +760,14 @@ delayedAction a = do -- | 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 ()] -> [Key] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts keys = +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -> IO () +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + ioActionBetweenShakeSession backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 1772612e2d..f468c55e55 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -72,32 +72,32 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logWith recorder Debug $ LogOpenedTextDocument _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=True} + logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=False} logWith recorder Debug $ LogModifiedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - addFileOfInterest ide file OnDisk - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ + addFileOfInterest ide file OnDisk logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do - deleteFileOfInterest ide file let msg = "Closed text document: " <> getUri _uri - scheduleGarbageCollection ide - setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg + setSomethingModified (VFSModified vfs) ide [] (Text.unpack msg) $ do + deleteFileOfInterest ide file + scheduleGarbageCollection ide logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -116,9 +116,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) - modifyFileExists ide fileEvents' - resetFileStore ide fileEvents' - setSomethingModified (VFSModified vfs) ide [] msg + setSomethingModified (VFSModified vfs) ide [] msg $ do + modifyFileExists ide fileEvents' + resetFileStore ide fileEvents' , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 2e305b2e45..34f0095f64 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -90,26 +90,26 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - addFileOfInterest recorder ide file Modified{firstOpen = True} - restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" + restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $ + addFileOfInterest recorder ide file Modified{firstOpen = True} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocModified _uri - addFileOfInterest recorder ide file Modified{firstOpen = False} - restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" + restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ + addFileOfInterest recorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri - addFileOfInterest recorder ide file OnDisk - restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" + restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ + addFileOfInterest recorder ide file OnDisk , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocClosed _uri - deleteFileOfInterest recorder ide file - restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" + restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $ + deleteFileOfInterest recorder ide file ] , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True @@ -132,8 +132,8 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg = do - join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] [] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ + join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] -- ---------------------------------------------------------------- -- Plugin Rules From 13528d7d4b5aba5e33fbdf970fc2eeabe9e87191 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:44:58 +0800 Subject: [PATCH 03/32] fix --- ghcide/src/Development/IDE/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 0c7581f75d..1d8f064709 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -364,7 +364,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re let msg = T.pack $ show cfg logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" + setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" $ return () runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats From fdbb7aaca816cdbf23d7904148969b41350d76c8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:49:24 +0800 Subject: [PATCH 04/32] fix --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 7 ++++--- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 6 ++---- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9003917f0c..f49bfe56b8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -766,8 +766,8 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - res <- shakeDatabaseProfile shakeDb ioActionBetweenShakeSession + res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 34f0095f64..404ba71ba2 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -130,9 +130,10 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -restartCabalShakeSession shakeExtras vfs file actionMsg = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -> IO () +restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + actionBetweenSession join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] -- ---------------------------------------------------------------- diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index bb7c51be59..4d9aec1ad2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -211,10 +211,8 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (do queueForEvaluation st nfp - setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") - (do unqueueForEvaluation st nfp - setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") + (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ queueForEvaluation st nfp) + (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ unqueueForEvaluation st nfp) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From 6fc3646741af3d62b9729f173ddcc903f443a4ef Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 01:08:01 +0800 Subject: [PATCH 05/32] some more fix up --- ghcide/src/Development/IDE/Core/FileStore.hs | 6 ++---- ghcide/src/Development/IDE/Core/Shake.hs | 11 +++++++++- .../src/Development/IDE/LSP/Notifications.hs | 4 ++-- ghcide/src/Development/IDE/Main.hs | 15 +++++++------ .../src/Ide/Plugin/Eval/CodeLens.hs | 21 +++++++++++++------ 5 files changed, 38 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index d0e5d69876..762f761dbe 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -246,15 +246,13 @@ 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 -> [Key] -> String -> IO () -> IO () -setSomethingModified vfs state keys reason actionBetweenSession = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO () -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted void $ restartShakeSession (shakeExtras state) vfs reason [] $ do actionBetweenSession atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip insertKeySet) x keys 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 f49bfe56b8..9348dd692e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, + deleteValue, recordDirtyKeys, recordDirtyKeySet, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -579,6 +579,15 @@ recordDirtyKeys ShakeExtras{dirtyKeys} key file = do return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) +recordDirtyKeySet + :: ShakeExtras + -> [Key] + -> STM (IO ()) +recordDirtyKeySet ShakeExtras{dirtyKeys} keys = do + modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys + return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do + addEvent (fromString $ unlines $ "dirty " : map show keys) + -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index f468c55e55..cbfa92380d 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -95,7 +95,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri - setSomethingModified (VFSModified vfs) ide [] (Text.unpack msg) $ do + setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do deleteFileOfInterest ide file scheduleGarbageCollection ide logWith recorder Debug $ LogClosedTextDocument _uri @@ -116,7 +116,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) - setSomethingModified (VFSModified vfs) ide [] msg $ do + setSomethingModified (VFSModified vfs) ide msg $ do modifyFileExists ide fileEvents' resetFileStore ide fileEvents' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1d8f064709..fc2e7be561 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -18,8 +18,8 @@ import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) -import Control.Monad.Extra (concatMapM, unless, - when) +import Control.Monad.Extra (concatMapM, join, + unless, when) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import Data.Coerce (coerce) @@ -56,6 +56,7 @@ import Development.IDE.Core.Service (initialise, import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, + recordDirtyKeys, shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake @@ -89,7 +90,8 @@ import Development.IDE.Types.Options (IdeGhcSession, optModifyDynFlags, optTesting) import Development.IDE.Types.Shake (WithHieDb, toKey) -import GHC.Conc (getNumProcessors) +import GHC.Conc (atomically, + getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) @@ -362,9 +364,10 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Nothing -> pure () Just ide -> liftIO $ do let msg = T.pack $ show cfg - logWith recorder Debug $ LogConfigurationChange msg - modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" $ return () + setSomethingModified Shake.VFSUnmodified ide "config change" $ do + logWith recorder Debug $ LogConfigurationChange msg + modifyClientSettings ide (const $ Just cfgObj) + join $ atomically $ recordDirtyKeys (shakeExtras ide) Rules.GetClientSettings [emptyFilePath] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 4d9aec1ad2..be9d0472c8 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -23,8 +23,8 @@ import Control.Exception (bracket_, try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, void, - when) +import Control.Monad (guard, join, + void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) @@ -47,7 +47,8 @@ import Development.IDE.Core.RuleTypes (LinkableResult (l NeedsCompilation (NeedsCompilation), TypeCheck (..), tmrTypechecked) -import Development.IDE.Core.Shake (useNoFile_, +import Development.IDE.Core.Shake (shakeExtras, + useNoFile_, useWithStale_, use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, @@ -84,15 +85,18 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetL GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) -import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified), + recordDirtyKeys) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), unLoc) import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) +import Control.Concurrent.STM.Stats (atomically) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils +import Development.IDE.Graph (ShakeOptions (shakeExtra)) import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) import Ide.Logger (Priority (..), @@ -211,8 +215,13 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ queueForEvaluation st nfp) - (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ unqueueForEvaluation st nfp) + (setSomethingModified VFSUnmodified st "Eval" $ do + join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] + queueForEvaluation st nfp + ) + (setSomethingModified VFSUnmodified st "Eval" $ do + join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] + unqueueForEvaluation st nfp) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From e247ae13e780a0475040a6285c1c976585528f29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 01:46:11 +0800 Subject: [PATCH 06/32] use IO [Key] --- .../session-loader/Development/IDE/Session.hs | 16 ++++++------- ghcide/src/Development/IDE/Core/FileExists.hs | 12 ++++++---- ghcide/src/Development/IDE/Core/FileStore.hs | 15 ++++++------ ghcide/src/Development/IDE/Core/OfInterest.hs | 13 +++++++---- ghcide/src/Development/IDE/Core/Shake.hs | 22 +++++------------- .../src/Development/IDE/LSP/Notifications.hs | 4 ++-- ghcide/src/Development/IDE/Main.hs | 3 +-- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 23 +++++++++++-------- .../src/Ide/Plugin/Eval/CodeLens.hs | 10 ++++---- 9 files changed, 58 insertions(+), 60 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e862261480..84e8a9011f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -106,7 +106,7 @@ import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, toKey) import HieDb.Create import HieDb.Types import HieDb.Utils @@ -474,10 +474,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do clientConfig <- getClientConfigAction extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras - let invalidateShakeCache :: IO () - invalidateShakeCache = do + let invalidateShakeCache = do void $ modifyVar' version succ - join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath] + return $ toKey GhcSessionIO emptyFilePath IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject @@ -516,10 +515,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do HM.unionWith (<>) k $ HM.fromList knownTargets hasUpdate = if known /= known' then Just (unhashed known') else Nothing writeTVar knownTargetsVar known' - logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] - return (logDirtyKeys >> pure hasUpdate) + return (pure hasUpdate) for_ hasUpdate $ \x -> logWith recorder Debug $ LogKnownFilesUpdated x + return $ toKey GetKnownTargets emptyFilePath -- Create a new HscEnv from a hieYaml root and a set of options let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) @@ -617,9 +616,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do Map.insert hieYaml this_flags_map void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) - void $ extendKnownTargets all_targets + key1 <- extendKnownTargets all_targets + key2 <- invalidateShakeCache + return [key1, key2] -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 4ca55a8d24..eb87051812 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -28,6 +28,7 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import qualified Focus import Ide.Logger (Pretty (pretty), Recorder, WithPriority, @@ -106,11 +107,11 @@ getFileExistsMapUntracked = do return v -- | Modify the global store of file exists. -modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - join $ mask_ $ atomicallyNamed "modifyFileExists" $ do + keys <- join $ mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -120,9 +121,10 @@ modifyFileExists state changes = do let (fileModifChanges, fileExistChanges) = partition ((== FileChangeType_Changed) . snd) changes mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges - io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges - io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges - return (io1 <> io2) + let keys1 = map (toKey GetFileExists . fst) fileExistChanges + let keys2 = map (toKey GetModificationTime . fst) fileModifChanges + return $ return (keys1 <> keys2) + return keys fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 762f761dbe..31d110c466 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -49,6 +49,7 @@ import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import HieDb.Create (deleteMissingRealFiles) import Ide.Logger (Pretty (pretty), Priority (Info), @@ -215,7 +216,7 @@ setFileModified :: Recorder (WithPriority Log) -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath - -> IO () + -> IO [Key] -> IO () setFileModified recorder vfs state saved nfp actionBefore = do ideOptions <- getIdeOptionsIO $ shakeExtras state @@ -225,8 +226,8 @@ setFileModified recorder vfs state saved nfp actionBefore = do CheckOnSave -> saved _ -> False restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do - actionBefore - join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] + keys<-actionBefore + return (toKey GetModificationTime nfp:keys) when checkParents $ typecheckParents recorder state nfp @@ -246,13 +247,13 @@ 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 () -> IO () +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 void $ restartShakeSession (shakeExtras state) vfs reason [] $ do - actionBetweenSession - atomically $ do - writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + keys <- actionBetweenSession + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + return keys registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 0be869b45a..098b2dedaa 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -40,6 +40,7 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options (IdeTesting (..)) +import Development.IDE.Types.Shake (toKey) import GHC.TypeLits (KnownSymbol) import Ide.Logger (Pretty (pretty), Priority (..), @@ -103,24 +104,26 @@ getFilesOfInterestUntracked = do OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + if prev /= Just v + then do logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] + else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do GarbageCollectVar var <- getIdeGlobalState state diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9348dd692e..f6c23a8405 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, recordDirtyKeySet, + deleteValue, recordDirtyKeys, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -300,7 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] - -> IO () + -> IO [Key] -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -569,21 +569,10 @@ deleteValue ShakeExtras{dirtyKeys, state} key file = do modifyTVar' dirtyKeys $ insertKeySet (toKey key file) recordDirtyKeys - :: Shake.ShakeValue k - => ShakeExtras - -> k - -> [NormalizedFilePath] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) - -recordDirtyKeySet :: ShakeExtras -> [Key] -> STM (IO ()) -recordDirtyKeySet ShakeExtras{dirtyKeys} keys = do +recordDirtyKeys ShakeExtras{dirtyKeys} keys = do modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " : map show keys) @@ -769,13 +758,14 @@ delayedAction a = do -- | 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 () -> IO () +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - ioActionBetweenShakeSession + keys <- ioActionBetweenShakeSession + join $ atomically $ recordDirtyKeys shakeExtras keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index cbfa92380d..7b5fe7adeb 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -96,8 +96,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do - deleteFileOfInterest ide file scheduleGarbageCollection ide + deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -117,8 +117,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) setSomethingModified (VFSModified vfs) ide msg $ do - modifyFileExists ide fileEvents' resetFileStore ide fileEvents' + modifyFileExists ide fileEvents' , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index fc2e7be561..b9c977e08e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -56,7 +56,6 @@ import Development.IDE.Core.Service (initialise, import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, - recordDirtyKeys, shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake @@ -367,7 +366,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re setSomethingModified Shake.VFSUnmodified ide "config change" $ do logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) - join $ atomically $ recordDirtyKeys (shakeExtras ide) Rules.GetClientSettings [emptyFilePath] + return [toKey Rules.GetClientSettings emptyFilePath] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 404ba71ba2..b9db5f816f 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -24,9 +24,10 @@ import Data.Typeable import Development.IDE as D import Development.IDE.Core.Shake (restartShakeSession) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (alwaysRerun) +import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import Development.IDE.Types.Shake (toKey) import GHC.Generics import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions @@ -130,11 +131,11 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -> IO () +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do - actionBetweenSession - join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] + keys <- actionBetweenSession + return (toKey GetModificationTime file:keys) -- ---------------------------------------------------------------- -- Plugin Rules @@ -250,24 +251,26 @@ getCabalFilesOfInterestUntracked = do OfInterestCabalVar var <- Shake.getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest recorder state f v = do OfInterestCabalVar var <- Shake.getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (,Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - log' Debug $ LogFOI files + if prev /= Just v + then do + log' Debug $ LogFOI files + return [toKey IsCabalFileOfInterest f] + else return [] where log' = logWith recorder -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest recorder state f = do OfInterestCabalVar var <- Shake.getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] where log' = logWith recorder diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index be9d0472c8..8701526b65 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -85,8 +85,7 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetL GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) -import Development.IDE.Core.Shake (VFSModified (VFSUnmodified), - recordDirtyKeys) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), unLoc) @@ -216,12 +215,13 @@ 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 - join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] queueForEvaluation st nfp + return [toKey IsEvaluating nfp] ) (setSomethingModified VFSUnmodified st "Eval" $ do - join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] - unqueueForEvaluation st nfp) + unqueueForEvaluation st nfp + return [toKey IsEvaluating nfp] + ) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From 7b7ea4d726a09d45cbeff28a92e807dd8b383d1b Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 02:56:23 +0800 Subject: [PATCH 07/32] remove double return --- ghcide/src/Development/IDE/Core/FileExists.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index eb87051812..deeee49c33 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -111,7 +111,7 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Ke modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - keys <- join $ mask_ $ atomicallyNamed "modifyFileExists" $ do + keys <- mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -123,7 +123,7 @@ modifyFileExists state changes = do mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges - return $ return (keys1 <> keys2) + return (keys1 <> keys2) return keys fromChange :: FileChangeType -> Maybe Bool From c31a3756ed3e428d6b5b6246922318453e6147b6 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 26 Apr 2024 20:54:46 +0800 Subject: [PATCH 08/32] Update ghcide/src/Development/IDE/Core/FileExists.hs Co-authored-by: wz1000 --- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index deeee49c33..af1fd45559 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -111,7 +111,7 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Ke modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - keys <- mask_ $ atomicallyNamed "modifyFileExists" $ do + mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var From bfb06a3565d4d6188b357061cc7f9c18aa1d7dd7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 26 Apr 2024 20:59:01 +0800 Subject: [PATCH 09/32] minor fix --- ghcide/session-loader/Development/IDE/Session.hs | 7 +++---- ghcide/src/Development/IDE/Core/FileExists.hs | 1 - ghcide/src/Development/IDE/Core/FileStore.hs | 6 ++---- 3 files changed, 5 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 84e8a9011f..d93f654e21 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -610,12 +610,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do [ "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" ] + + void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map + void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. restartShakeSession VFSUnmodified "new component" [] $ 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)) key1 <- extendKnownTargets all_targets key2 <- invalidateShakeCache return [key1, key2] diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index af1fd45559..f1840b9ffd 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -124,7 +124,6 @@ modifyFileExists state changes = do let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges return (keys1 <> keys2) - return keys fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 31d110c466..145e9dc905 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -250,10 +250,8 @@ 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 - void $ restartShakeSession (shakeExtras state) vfs reason [] $ do - keys <- actionBetweenSession - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - return keys + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do From bbc5c9507ae6aa7b66a78342de0265efbf7f6f46 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 03:52:43 +0800 Subject: [PATCH 10/32] capture more dirty keys to between sessions --- ghcide/src/Development/IDE/Core/FileExists.hs | 4 ++-- ghcide/src/Development/IDE/Core/FileStore.hs | 18 +++++++++--------- ghcide/src/Development/IDE/Core/Shake.hs | 5 +++-- .../src/Development/IDE/LSP/Notifications.hs | 5 +++-- 4 files changed, 17 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index f1840b9ffd..28c633f93d 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -120,10 +120,10 @@ modifyFileExists state changes = do -- flush previous values let (fileModifChanges, fileExistChanges) = partition ((== FileChangeType_Changed) . snd) changes - mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges - return (keys1 <> keys2) + return (keys0 <> keys1 <> keys2) fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 145e9dc905..e96a3984cf 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -149,24 +149,24 @@ isInterface :: NormalizedFilePath -> Bool isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key] resetInterfaceStore state f = do deleteValue state GetModificationTime f -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO () +resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key] resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) - forM_ changes $ \(nfp, c) -> do - case c of - LSP.FileChangeType_Changed - -- already checked elsewhere | not $ HM.member nfp fois - -> atomically $ - deleteValue (shakeExtras ideState) GetModificationTime nfp - _ -> pure () + fmap concat <$> + forM changes $ \(nfp, c) -> do + case c of + LSP.FileChangeType_Changed + -- already checked elsewhere | not $ HM.member nfp fois + -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp + _ -> pure [] modificationTime :: FileVersion -> Maybe UTCTime diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f6c23a8405..04381b65fa 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -563,10 +563,11 @@ deleteValue => ShakeExtras -> k -> NormalizedFilePath - -> STM () + -> STM [Key] deleteValue ShakeExtras{dirtyKeys, state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ insertKeySet (toKey key file) + return [toKey key file] + recordDirtyKeys :: ShakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 7b5fe7adeb..f5cc4abc96 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -117,8 +117,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) setSomethingModified (VFSModified vfs) ide msg $ do - resetFileStore ide fileEvents' - modifyFileExists ide fileEvents' + ks1 <- resetFileStore ide fileEvents' + ks2 <- modifyFileExists ide fileEvents' + return (ks1 <> ks2) , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do From 48d5644a527682eba22432ec56576c00f76450fc Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 06:06:47 +0800 Subject: [PATCH 11/32] cleanup --- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index b9db5f816f..c13ce9fe4a 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -6,7 +6,6 @@ module Ide.Plugin.Cabal (descriptor, Log (..)) where -import Control.Concurrent.STM import Control.Concurrent.Strict import Control.DeepSeq import Control.Lens ((^.)) From e967dde93bc66f6b692b3f5f2067e2b98c28644d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 22:25:42 +0800 Subject: [PATCH 12/32] fix the race between cache value updated but not updated hls-database --- ghcide/src/Development/IDE/Core/Shake.hs | 9 ++++----- ghcide/src/Development/IDE/Core/Tracing.hs | 2 +- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 4 +++- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 6 +++--- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 04381b65fa..0f2d376cb3 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1200,7 +1200,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old $ A v + return $ Just $ RunResult ChangedNothing old (A v) mempty _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss @@ -1224,7 +1224,6 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) - liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics (vfsVersion =<< ver) diags let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b @@ -1234,9 +1233,9 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do _ -> False return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) - (encodeShakeValue bs) $ - A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + (encodeShakeValue bs) + (A res) + (setValues state 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 diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 86212f0e83..b55dcc7af5 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -112,7 +112,7 @@ otTracedAction key file mode result act ExitCaseSuccess res -> do setTag sp "result" (pack $ result $ runValue res) setTag sp "changed" $ case res of - RunResult x _ _ -> fromString $ show x + RunResult x _ _ _ -> fromString $ show x endSpan sp) (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) | otherwise = act (\_ -> return ()) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 63e874c87d..8d956e74c9 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -200,7 +200,9 @@ compute db@Database{..} stack key mode result = do (getResultDepsDefault mempty previousDeps) deps _ -> pure () - atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues + atomicallyNamed "compute and run hook" $ do + runHook + SMap.focus (updateStatus $ Clean res) key databaseValues pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 02b5ccd4b0..227eb6ab4b 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 qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO) +import Control.Concurrent.STM (STM) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -202,11 +203,10 @@ data RunResult value = RunResult -- ^ The value to store in the Shake database. ,runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'. + ,runHook :: STM () + -- ^ The value to return from 'Development.Shake.Rule.apply'. } deriving Functor -instance NFData value => NFData (RunResult value) where - rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 - --------------------------------------------------------------------- -- EXCEPTIONS From 69c93964c547893d346bddc7adb70e3e152d9b2d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 22:38:45 +0800 Subject: [PATCH 13/32] fix build --- hls-graph/test/DatabaseSpec.hs | 2 +- hls-graph/test/Example.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 4f15e77639..489b50fc7e 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -20,6 +20,6 @@ spec = do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) - return $ RunResult ChangedRecomputeDiff "" () + return $ RunResult ChangedRecomputeDiff "" () mempty let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 2845b60e6c..2b12b3dcec 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -22,13 +22,13 @@ type instance RuleResult (Rule a) = a ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do - return $ RunResult ChangedRecomputeDiff "" () + return $ RunResult ChangedRecomputeDiff "" () mempty -- | Depends on Rule @() ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule - return $ RunResult ChangedRecomputeDiff "" True + return $ RunResult ChangedRecomputeDiff "" True mempty data CondRule = CondRule From 02f0d41f18d5c05c0722d5535735f2e01ba3073c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 23:01:40 +0800 Subject: [PATCH 14/32] fix hls-graph --- hls-graph/test/ActionSpec.hs | 2 +- hls-graph/test/Example.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index ffb319c614..0f4dd2627d 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -87,7 +87,7 @@ spec = do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] - return $ RunResult ChangedRecomputeDiff "" True + return $ RunResult ChangedRecomputeDiff "" True mempty let theKey = Rule @Bool res <- shakeRunDatabase db $ diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 2b12b3dcec..6c0d546684 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -39,7 +39,7 @@ type instance RuleResult CondRule = Bool ruleCond :: C.MVar Bool -> Rules () ruleCond mv = addRule $ \CondRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) - return $ RunResult ChangedRecomputeDiff "" r + return $ RunResult ChangedRecomputeDiff "" r mempty data BranchedRule = BranchedRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -50,9 +50,9 @@ ruleWithCond = addRule $ \BranchedRule _old _mode -> do r <- apply1 CondRule if r then do _ <- apply1 SubBranchRule - return $ RunResult ChangedRecomputeDiff "" (1 :: Int) + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) mempty else - return $ RunResult ChangedRecomputeDiff "" (2 :: Int) + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) mempty data SubBranchRule = SubBranchRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -61,4 +61,4 @@ type instance RuleResult SubBranchRule = Int ruleSubBranch :: C.MVar Int -> Rules () ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) - return $ RunResult ChangedRecomputeDiff "" r + return $ RunResult ChangedRecomputeDiff "" r mempty From c983727d29ec00132c50116a4bc0b455fe4d6a29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 29 Apr 2024 05:24:15 +0800 Subject: [PATCH 15/32] fix 9.2.8 --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Development/IDE/Graph/Internal/Types.hs | 2 +- hls-graph/test/ActionSpec.hs | 2 +- hls-graph/test/DatabaseSpec.hs | 2 +- hls-graph/test/Example.hs | 12 ++++++------ 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0f2d376cb3..0d1eb3ea60 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1200,7 +1200,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old (A v) mempty + return $ Just $ RunResult ChangedNothing old (A v) $ return () _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 227eb6ab4b..e8d09359c8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -204,7 +204,7 @@ data RunResult value = RunResult ,runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'. ,runHook :: STM () - -- ^ The value to return from 'Development.Shake.Rule.apply'. + -- ^ The hook to run after the rule completes. } deriving Functor --------------------------------------------------------------------- diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 0f4dd2627d..eece9b03ca 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -87,7 +87,7 @@ spec = do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] - return $ RunResult ChangedRecomputeDiff "" True mempty + return $ RunResult ChangedRecomputeDiff "" True $ return () let theKey = Rule @Bool res <- shakeRunDatabase db $ diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 489b50fc7e..97a04d3007 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -20,6 +20,6 @@ spec = do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) - return $ RunResult ChangedRecomputeDiff "" () mempty + return $ RunResult ChangedRecomputeDiff "" () (return ()) let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 6c0d546684..a15cb5487f 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -22,13 +22,13 @@ type instance RuleResult (Rule a) = a ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do - return $ RunResult ChangedRecomputeDiff "" () mempty + return $ RunResult ChangedRecomputeDiff "" () (return ()) -- | Depends on Rule @() ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule - return $ RunResult ChangedRecomputeDiff "" True mempty + return $ RunResult ChangedRecomputeDiff "" True (return ()) data CondRule = CondRule @@ -39,7 +39,7 @@ type instance RuleResult CondRule = Bool ruleCond :: C.MVar Bool -> Rules () ruleCond mv = addRule $ \CondRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) - return $ RunResult ChangedRecomputeDiff "" r mempty + return $ RunResult ChangedRecomputeDiff "" r (return ()) data BranchedRule = BranchedRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -50,9 +50,9 @@ ruleWithCond = addRule $ \BranchedRule _old _mode -> do r <- apply1 CondRule if r then do _ <- apply1 SubBranchRule - return $ RunResult ChangedRecomputeDiff "" (1 :: Int) mempty + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) (return ()) else - return $ RunResult ChangedRecomputeDiff "" (2 :: Int) mempty + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) (return ()) data SubBranchRule = SubBranchRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -61,4 +61,4 @@ type instance RuleResult SubBranchRule = Int ruleSubBranch :: C.MVar Int -> Rules () ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) - return $ RunResult ChangedRecomputeDiff "" r mempty + return $ RunResult ChangedRecomputeDiff "" r (return ()) From 3748fc2f0e0f5ebb9cd8af30740a45754186f166 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 29 Apr 2024 08:36:30 +0800 Subject: [PATCH 16/32] format --- 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 e8d09359c8..3474289b42 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -5,6 +5,7 @@ module Development.IDE.Graph.Internal.Types where +import Control.Concurrent.STM (STM) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -27,7 +28,6 @@ import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO) -import Control.Concurrent.STM (STM) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) From a65ac5c15fc8d6d5a2456b805a61ccd464b862f7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 18:19:22 +0800 Subject: [PATCH 17/32] run refreshDeps in a single asyncWithCleanUp --- .../Development/IDE/Graph/Internal/Database.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 8d956e74c9..7f2cee0a8c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -143,31 +143,31 @@ 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 (IO Result) +refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result refreshDeps visited db stack key result = \case -- no more deps to refresh - [] -> pure $ compute db stack key RunDependenciesSame (Just result) + [] -> liftIO $ 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 -- restart the computation if any of the deps are dirty - then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result) + then liftIO $ compute db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps else refreshDeps newVisited db stack key result deps - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores + Right iores -> do + res <- liftIO iores if isDirty result res - then compute db stack key RunDependenciesChanged (Just result) - else join $ runAIO $ refreshDeps newVisited db stack key result deps + 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 _ st k _ | traceShow ("refresh", st, k) False = undefined 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, 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 From f4690c577cea0a31d3a956aa080c5bb9c5b4da52 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 23:35:21 +0800 Subject: [PATCH 18/32] shut the session before shut the reactor --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..19f2d93b16 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM 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 + -- stop the reactor to free up the hiedb connection + liftIO stopReactor resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 0d85ef1655d9232e0bbae239a5f4f13e135cdf19 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 2 May 2024 22:47:42 +0800 Subject: [PATCH 19/32] swap shakeShut and stopReactor --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..7521aed938 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,13 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM 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 + -- we need to shut down the ide session before stopping the reactor + -- since SessionIO depends on the reactor, we may hang if we stop the reactor first + -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide + -- stop the reactor to free up the hiedb connection + liftIO stopReactor resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 610355cb00ed350ff510d0010ac67fcfd2d2a7e4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 05:02:48 +0800 Subject: [PATCH 20/32] Revert "shut the session before shut the reactor" This reverts commit f4690c577cea0a31d3a956aa080c5bb9c5b4da52. --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 19f2d93b16..e4493436cb 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logWith recorder Debug LogServerShutdownMessage - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide -- 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 resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From abf55389fab20ec0d1c554e8f800d5b3ee1d1b3c Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 05:20:36 +0800 Subject: [PATCH 21/32] take awasy the session in shutdown to prevent race condition --- ghcide/src/Development/IDE/Core/Shake.hs | 17 +++++++++-------- .../src/Development/IDE/LSP/LanguageServer.hs | 7 ++----- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index a215ee42ef..4d9bf88fed 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -75,6 +75,7 @@ module Development.IDE.Core.Shake( VFSModified(..), getClientConfigAction, ) where +import Control.Concurrent (withMVar) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) @@ -724,14 +725,14 @@ shakeSessionInit recorder ide@IdeState{..} = do logWith recorder Debug LogSessionInitialised shakeShut :: IdeState -> IO () -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 - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring +shakeShut IdeState{..} = + withMVar shakeSession $ \ runner -> do + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + cancelShakeSession runner + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 7521aed938..e4493436cb 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,13 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logWith recorder Debug LogServerShutdownMessage - -- we need to shut down the ide session before stopping the reactor - -- since SessionIO depends on the reactor, we may hang if we stop the reactor first - - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide -- 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 resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 53ab0d5e19c03a0f6e43f26f5d31e58281946c27 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 05:55:14 +0800 Subject: [PATCH 22/32] use try takeMVar --- ghcide/src/Development/IDE/Core/Shake.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4d9bf88fed..84c723fe74 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -725,14 +725,14 @@ shakeSessionInit recorder ide@IdeState{..} = do logWith recorder Debug LogSessionInitialised shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = - withMVar shakeSession $ \ runner -> do - -- Shake gets unhappy if you try to close when there is a running - -- request so we first abort that. - cancelShakeSession runner - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring +shakeShut IdeState{..} = do + runner <- tryTakeMVar shakeSession + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + for_ runner cancelShakeSession + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws From 63b1956d34e3f8c64695f663ae6276f22aa60f0b Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 06:25:10 +0800 Subject: [PATCH 23/32] remove record dirty key recordDirtyKeys --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 13 ++----------- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d93f654e21..2d12125b7b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -613,10 +613,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = 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)) + key1 <- extendKnownTargets all_targets + key2 <- invalidateShakeCache -- The VFS doesn't change on cradle edits, re-use the old one. restartShakeSession VFSUnmodified "new component" [] $ do - key1 <- extendKnownTargets all_targets - key2 <- invalidateShakeCache return [key1, key2] -- Invalidate all the existing GhcSession build nodes by restarting the Shake session diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0d1eb3ea60..3973a8a3e8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, + deleteValue, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -569,15 +569,6 @@ deleteValue ShakeExtras{dirtyKeys, state} key file = do return [toKey key file] -recordDirtyKeys - :: ShakeExtras - -> [Key] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} keys = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " : map show keys) - -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. @@ -766,7 +757,7 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner keys <- ioActionBetweenShakeSession - join $ atomically $ recordDirtyKeys shakeExtras 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 From ceb7020b3fddc322d70a728a092cbb3a8d653afe Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 09:40:27 +0800 Subject: [PATCH 24/32] time out the shakeShut --- ghcide/src/Development/IDE/Core/Shake.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 84c723fe74..c3fd797240 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -197,6 +197,7 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogTimeOutShuttingDownWaitForSessionVar !Seconds deriving Show instance Pretty Log where @@ -240,6 +241,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) + LogTimeOutShuttingDownWaitForSessionVar seconds -> + "Timed out waiting for session var after" <+> pretty seconds <+> "seconds" -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -724,15 +727,18 @@ shakeSessionInit recorder ide@IdeState{..} = do putMVar shakeSession initSession logWith recorder Debug LogSessionInitialised -shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = do - runner <- tryTakeMVar shakeSession - -- Shake gets unhappy if you try to close when there is a running - -- request so we first abort that. - for_ runner cancelShakeSession - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring +shakeShut :: Recorder (WithPriority Log) -> IdeState -> IO () +shakeShut recorder IdeState{..} = do + res <- timeout 1 $ withMVar shakeSession $ \runner -> do + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + cancelShakeSession runner + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring + case res of + Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 + Just _ -> pure () -- | This is a variant of withMVar where the first argument is run unmasked and if it throws From 84e673180ead20900de3adb2ce9c77a9af4532c4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 09:49:09 +0800 Subject: [PATCH 25/32] fix --- ghcide/src/Development/IDE/Core/Service.hs | 3 ++- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..80a44fd862 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -93,7 +93,8 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with mainRule -- | Shutdown the Compiler Service. -shutdown :: IdeState -> IO () +-- shutdown :: Recorder (WithPriority Log) -> IdeState -> IO () +shutdown :: Recorder (WithPriority Shake.Log) -> IdeState -> IO () shutdown = shakeShut -- This will return as soon as the result of the action is diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..f68568071a 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -35,6 +35,7 @@ import qualified Colog.Core as Colog import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log, Priority) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) @@ -49,6 +50,7 @@ data Log | LogReactorThreadStopped | LogCancelledRequest !SomeLspId | LogSession Session.Log + | LogShake Shake.Log | LogLspServer LspServerLog | LogServerShutdownMessage deriving Show @@ -265,7 +267,7 @@ shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ -- 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 + liftIO $ shakeShut (cmapWithPrio LogShake recorder) ide resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From e4fd8531ea60364e77bcb655c126d48cc689e74d Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 09:59:18 +0800 Subject: [PATCH 26/32] use takeMVar --- 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 c3fd797240..5cb2ea02ac 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -75,7 +75,7 @@ module Development.IDE.Core.Shake( VFSModified(..), getClientConfigAction, ) where -import Control.Concurrent (withMVar) +import Control.Concurrent (takeMVar, withMVar) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) @@ -729,16 +729,17 @@ shakeSessionInit recorder ide@IdeState{..} = do shakeShut :: Recorder (WithPriority Log) -> IdeState -> IO () shakeShut recorder IdeState{..} = do - res <- timeout 1 $ withMVar shakeSession $ \runner -> do - -- Shake gets unhappy if you try to close when there is a running - -- request so we first abort that. - cancelShakeSession runner - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring + res <- timeout 1 $ takeMVar shakeSession case res of + Just session -> do + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + cancelShakeSession session + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring + case res of Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 - Just _ -> pure () -- | This is a variant of withMVar where the first argument is run unmasked and if it throws From 036ad1fa7d79a02083e6b3033d691034397c66aa Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 10:29:37 +0800 Subject: [PATCH 27/32] use withMVar to prevent stm dead lock --- ghcide/src/Development/IDE/Core/Shake.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5cb2ea02ac..c3fd797240 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -75,7 +75,7 @@ module Development.IDE.Core.Shake( VFSModified(..), getClientConfigAction, ) where -import Control.Concurrent (takeMVar, withMVar) +import Control.Concurrent (withMVar) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) @@ -729,17 +729,16 @@ shakeSessionInit recorder ide@IdeState{..} = do shakeShut :: Recorder (WithPriority Log) -> IdeState -> IO () shakeShut recorder IdeState{..} = do - res <- timeout 1 $ takeMVar shakeSession + res <- timeout 1 $ withMVar shakeSession $ \runner -> do + -- Shake gets unhappy if you try to close when there is a running + -- request so we first abort that. + cancelShakeSession runner + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring case res of - Just session -> do - -- Shake gets unhappy if you try to close when there is a running - -- request so we first abort that. - cancelShakeSession session - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring - case res of Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 + Just _ -> pure () -- | This is a variant of withMVar where the first argument is run unmasked and if it throws From 9b8e966f07ce69ae58acbd2ef07a1c9d52b03523 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 17:42:57 +0800 Subject: [PATCH 28/32] show error in test --- .github/workflows/test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index b86b6b8302..732cc86cd3 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -61,6 +61,8 @@ jobs: needs: - pre_job runs-on: ${{ matrix.os }} + env: + LSP_TEST_LOG_STDERR: 1 strategy: # We don't want to fail fast. # We used to fail fast, to avoid caches of failing PRs to overpopulate the CI From 335274bb3d003beddfcfc66b3b19bda1cdbb799d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 4 May 2024 17:50:03 +0800 Subject: [PATCH 29/32] stop the progress regardless but do profile if we can get the shake session --- ghcide/src/Development/IDE/Core/Shake.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c3fd797240..7d0892de71 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -734,12 +734,11 @@ shakeShut recorder IdeState{..} = do -- request so we first abort that. cancelShakeSession runner void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring case res of Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 Just _ -> pure () - + progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws -- an exception, the previous value is restored while the second argument is executed masked. From a3c86b09abc701818c533297eb43c5813dedd320 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 5 May 2024 00:52:46 +0800 Subject: [PATCH 30/32] do not use progressStop if shake could not be cancel yet --- ghcide/src/Development/IDE/Core/Shake.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7d0892de71..d192ed2f11 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -75,7 +75,7 @@ module Development.IDE.Core.Shake( VFSModified(..), getClientConfigAction, ) where -import Control.Concurrent (withMVar) +import Control.Concurrent (tryReadMVar, withMVar) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Stats (atomicallyNamed) @@ -734,11 +734,14 @@ shakeShut recorder IdeState{..} = do -- request so we first abort that. cancelShakeSession runner void $ shakeDatabaseProfile shakeDb + -- might hang if there are still running + progressStop $ progress shakeExtras + stopMonitoring case res of - Nothing -> logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 + Nothing -> do + logWith recorder Error $ LogTimeOutShuttingDownWaitForSessionVar 1 + stopMonitoring Just _ -> pure () - progressStop $ progress shakeExtras - stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws -- an exception, the previous value is restored while the second argument is executed masked. From 53e601e49802675eb4f0c10f42c22f3d82ed4363 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 5 May 2024 10:08:08 +0800 Subject: [PATCH 31/32] add to for remove value but not dirty --- ghcide/src/Development/IDE/Core/Compile.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 1c46362c19..aa870d656d 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -833,6 +833,7 @@ atomicFileWrite se targetPath write = do let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir + -- todo value delete key value here but not mark as dirty. (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) `onException` cleanUp From c558220905b3b36fa2ae9483e8215e8c5c32b2ca Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 5 May 2024 10:16:04 +0800 Subject: [PATCH 32/32] do not log err by default --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 732cc86cd3..aeef764214 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -62,7 +62,7 @@ jobs: - pre_job runs-on: ${{ matrix.os }} env: - LSP_TEST_LOG_STDERR: 1 + LSP_TEST_LOG_STDERR: 0 strategy: # We don't want to fail fast. # We used to fail fast, to avoid caches of failing PRs to overpopulate the CI