Skip to content

Commit 10eb6f1

Browse files
soulomoonsoulomoon
authored
Merge branch 'master' into fix-stuck-at-exit
2 parents 5a90cd0 + 3084c7f commit 10eb6f1

File tree

15 files changed

+176
-136
lines changed

15 files changed

+176
-136
lines changed

‎ghcide/session-loader/Development/IDE/Session.hs

+13-18
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,7 @@ import qualified Data.HashSet as Set
106106
import Database.SQLite.Simple
107107
import Development.IDE.Core.Tracing (withTrace)
108108
import Development.IDE.Session.Diagnostics (renderCradleError)
109-
import Development.IDE.Types.Shake (WithHieDb)
109+
import Development.IDE.Types.Shake (WithHieDb, toNoFileKey)
110110
import HieDb.Create
111111
import HieDb.Types
112112
import HieDb.Utils
@@ -474,10 +474,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
474474
clientConfig <- getClientConfigAction
475475
extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
476476
} <- getShakeExtras
477-
let invalidateShakeCache :: IO ()
478-
invalidateShakeCache = do
477+
let invalidateShakeCache = do
479478
void $ modifyVar' version succ
480-
join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath]
479+
return $ toNoFileKey GhcSessionIO
481480

482481
IdeOptions{ optTesting = IdeTesting optTesting
483482
, optCheckProject = getCheckProject
@@ -510,16 +509,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
510509
TargetModule _ -> do
511510
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
512511
return [(targetTarget, Set.fromList found)]
513-
hasUpdate <- join $ atomically $ do
512+
hasUpdate <- atomically $ do
514513
known <- readTVar knownTargetsVar
515514
let known' = flip mapHashed known $ \k ->
516515
HM.unionWith (<>) k $ HM.fromList knownTargets
517516
hasUpdate = if known /= known' then Just (unhashed known') else Nothing
518517
writeTVar knownTargetsVar known'
519-
logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]
520-
return (logDirtyKeys >> pure hasUpdate)
518+
pure hasUpdate
521519
for_ hasUpdate $ \x ->
522520
logWith recorder Debug $ LogKnownFilesUpdated x
521+
return $ toNoFileKey GetKnownTargets
523522

524523
-- Create a new HscEnv from a hieYaml root and a set of options
525524
let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
@@ -612,18 +611,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
612611
, "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
613612
]
614613

615-
void $ modifyVar' fileToFlags $
616-
Map.insert hieYaml this_flags_map
617-
void $ modifyVar' filesMap $
618-
flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
619-
620-
void $ extendKnownTargets all_targets
621-
622-
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
623-
invalidateShakeCache
624-
614+
void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map
615+
void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
625616
-- The VFS doesn't change on cradle edits, re-use the old one.
626-
restartShakeSession VFSUnmodified "new component" []
617+
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
618+
keys2 <- invalidateShakeCache
619+
restartShakeSession VFSUnmodified "new component" [] $ do
620+
keys1 <- extendKnownTargets all_targets
621+
return [keys1, keys2]
627622

628623
-- Typecheck all files in the project on startup
629624
checkProject <- getCheckProject

‎ghcide/src/Development/IDE/Core/FileExists.hs

+8-7
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import qualified Development.IDE.Core.Shake as Shake
2828
import Development.IDE.Graph
2929
import Development.IDE.Types.Location
3030
import Development.IDE.Types.Options
31+
import Development.IDE.Types.Shake (toKey)
3132
import qualified Focus
3233
import Ide.Logger (Pretty (pretty),
3334
Recorder, WithPriority,
@@ -105,12 +106,12 @@ getFileExistsMapUntracked = do
105106
FileExistsMapVar v <- getIdeGlobalAction
106107
return v
107108

108-
-- | Modify the global store of file exists.
109-
modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
109+
-- | Modify the global store of file exists and return the keys that need to be marked as dirty
110+
modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key]
110111
modifyFileExists state changes = do
111112
FileExistsMapVar var <- getIdeGlobalState state
112113
-- Masked to ensure that the previous values are flushed together with the map update
113-
join $ mask_ $ atomicallyNamed "modifyFileExists" $ do
114+
mask_ $ atomicallyNamed "modifyFileExists" $ do
114115
forM_ changes $ \(f,c) ->
115116
case fromChange c of
116117
Just c' -> STM.focus (Focus.insert c') f var
@@ -119,10 +120,10 @@ modifyFileExists state changes = do
119120
-- flush previous values
120121
let (fileModifChanges, fileExistChanges) =
121122
partition ((== FileChangeType_Changed) . snd) changes
122-
mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
123-
io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
124-
io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
125-
return (io1 <> io2)
123+
keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
124+
let keys1 = map (toKey GetFileExists . fst) fileExistChanges
125+
let keys2 = map (toKey GetModificationTime . fst) fileModifChanges
126+
return (keys0 <> keys1 <> keys2)
126127

127128
fromChange :: FileChangeType -> Maybe Bool
128129
fromChange FileChangeType_Created = Just True

‎ghcide/src/Development/IDE/Core/FileStore.hs

+19-19
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ import Development.IDE.Import.DependencyInformation
4949
import Development.IDE.Types.Diagnostics
5050
import Development.IDE.Types.Location
5151
import Development.IDE.Types.Options
52+
import Development.IDE.Types.Shake (toKey)
5253
import HieDb.Create (deleteMissingRealFiles)
5354
import Ide.Logger (Pretty (pretty),
5455
Priority (Info),
@@ -148,24 +149,24 @@ isInterface :: NormalizedFilePath -> Bool
148149
isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"]
149150

150151
-- | Reset the GetModificationTime state of interface files
151-
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
152+
resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key]
152153
resetInterfaceStore state f = do
153154
deleteValue state GetModificationTime f
154155

155156
-- | Reset the GetModificationTime state of watched files
156157
-- Assumes the list does not include any FOIs
157-
resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO ()
158+
resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key]
158159
resetFileStore ideState changes = mask $ \_ -> do
159160
-- we record FOIs document versions in all the stored values
160161
-- so NEVER reset FOIs to avoid losing their versions
161162
-- FOI filtering is done by the caller (LSP Notification handler)
162-
forM_ changes $ \(nfp, c) -> do
163-
case c of
164-
LSP.FileChangeType_Changed
165-
-- already checked elsewhere | not $ HM.member nfp fois
166-
-> atomically $
167-
deleteValue (shakeExtras ideState) GetModificationTime nfp
168-
_ -> pure ()
163+
fmap concat <$>
164+
forM changes $ \(nfp, c) -> do
165+
case c of
166+
LSP.FileChangeType_Changed
167+
-- already checked elsewhere | not $ HM.member nfp fois
168+
-> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp
169+
_ -> pure []
169170

170171

171172
modificationTime :: FileVersion -> Maybe UTCTime
@@ -215,16 +216,18 @@ setFileModified :: Recorder (WithPriority Log)
215216
-> IdeState
216217
-> Bool -- ^ Was the file saved?
217218
-> NormalizedFilePath
219+
-> IO [Key]
218220
-> IO ()
219-
setFileModified recorder vfs state saved nfp = do
221+
setFileModified recorder vfs state saved nfp actionBefore = do
220222
ideOptions <- getIdeOptionsIO $ shakeExtras state
221223
doCheckParents <- optCheckParents ideOptions
222224
let checkParents = case doCheckParents of
223225
AlwaysCheck -> True
224226
CheckOnSave -> saved
225227
_ -> False
226-
join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
227-
restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") []
228+
restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do
229+
keys<-actionBefore
230+
return (toKey GetModificationTime nfp:keys)
228231
when checkParents $
229232
typecheckParents recorder state nfp
230233

@@ -244,14 +247,11 @@ typecheckParentsAction recorder nfp = do
244247
-- | Note that some keys have been modified and restart the session
245248
-- Only valid if the virtual file system was initialised by LSP, as that
246249
-- independently tracks which files are modified.
247-
setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
248-
setSomethingModified vfs state keys reason = do
250+
setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
251+
setSomethingModified vfs state reason actionBetweenSession = do
249252
-- Update database to remove any files that might have been renamed/deleted
250-
atomically $ do
251-
writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
252-
modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->
253-
foldl' (flip insertKeySet) x keys
254-
void $ restartShakeSession (shakeExtras state) vfs reason []
253+
atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
254+
void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
255255

256256
registerFileWatches :: [String] -> LSP.LspT Config IO Bool
257257
registerFileWatches globs = do

‎ghcide/src/Development/IDE/Core/OfInterest.hs

+8-5
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ import Development.IDE.Plugin.Completions.Types
4040
import Development.IDE.Types.Exports
4141
import Development.IDE.Types.Location
4242
import Development.IDE.Types.Options (IdeTesting (..))
43+
import Development.IDE.Types.Shake (toKey)
4344
import GHC.TypeLits (KnownSymbol)
4445
import Ide.Logger (Pretty (pretty),
4546
Priority (..),
@@ -103,24 +104,26 @@ getFilesOfInterestUntracked = do
103104
OfInterestVar var <- getIdeGlobalAction
104105
liftIO $ readVar var
105106

106-
addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO ()
107+
addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key]
107108
addFileOfInterest state f v = do
108109
OfInterestVar var <- getIdeGlobalState state
109110
(prev, files) <- modifyVar var $ \dict -> do
110111
let (prev, new) = HashMap.alterF (, Just v) f dict
111112
pure (new, (prev, new))
112-
when (prev /= Just v) $ do
113-
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
113+
if prev /= Just v
114+
then do
114115
logWith (ideLogger state) Debug $
115116
LogSetFilesOfInterest (HashMap.toList files)
117+
return [toKey IsFileOfInterest f]
118+
else return []
116119

117-
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
120+
deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key]
118121
deleteFileOfInterest state f = do
119122
OfInterestVar var <- getIdeGlobalState state
120123
files <- modifyVar' var $ HashMap.delete f
121-
join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
122124
logWith (ideLogger state) Debug $
123125
LogSetFilesOfInterest (HashMap.toList files)
126+
return [toKey IsFileOfInterest f]
124127
scheduleGarbageCollection :: IdeState -> IO ()
125128
scheduleGarbageCollection state = do
126129
GarbageCollectVar var <- getIdeGlobalState state

‎ghcide/src/Development/IDE/Core/Shake.hs

+45-21
Original file line numberDiff line numberDiff line change
@@ -57,7 +57,7 @@ module Development.IDE.Core.Shake(
5757
FileVersion(..),
5858
updatePositionMapping,
5959
updatePositionMappingHelper,
60-
deleteValue, recordDirtyKeys,
60+
deleteValue,
6161
WithProgressFunc, WithIndefiniteProgressFunc,
6262
ProgressEvent(..),
6363
DelayedAction, mkDelayedAction,
@@ -315,6 +315,7 @@ data ShakeExtras = ShakeExtras
315315
:: VFSModified
316316
-> String
317317
-> [DelayedAction ()]
318+
-> IO [Key]
318319
-> IO ()
319320
#if MIN_VERSION_ghc(9,3,0)
320321
,ideNc :: NameCache
@@ -572,26 +573,17 @@ setValues state key file val diags =
572573

573574

574575
-- | Delete the value stored for a given ide build key
576+
-- and return the key that was deleted.
575577
deleteValue
576578
:: Shake.ShakeValue k
577579
=> ShakeExtras
578580
-> k
579581
-> NormalizedFilePath
580-
-> STM ()
581-
deleteValue ShakeExtras{dirtyKeys, state} key file = do
582+
-> STM [Key]
583+
deleteValue ShakeExtras{state} key file = do
582584
STM.delete (toKey key file) state
583-
modifyTVar' dirtyKeys $ insertKeySet (toKey key file)
585+
return [toKey key file]
584586

585-
recordDirtyKeys
586-
:: Shake.ShakeValue k
587-
=> ShakeExtras
588-
-> k
589-
-> [NormalizedFilePath]
590-
-> STM (IO ())
591-
recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
592-
modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file)
593-
return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
594-
addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file)
595587

596588
-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
597589
getValues ::
@@ -783,12 +775,16 @@ delayedAction a = do
783775
-- | Restart the current 'ShakeSession' with the given system actions.
784776
-- Any actions running in the current session will be aborted,
785777
-- but actions added via 'shakeEnqueue' will be requeued.
786-
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO ()
787-
shakeRestart recorder IdeState{..} vfs reason acts =
778+
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
779+
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
788780
withMVar'
789781
shakeSession
790782
(\runner -> do
791783
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
784+
keys <- ioActionBetweenShakeSession
785+
-- it is every important to update the dirty keys after we enter the critical section
786+
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
787+
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
792788
res <- shakeDatabaseProfile shakeDb
793789
backlog <- readTVarIO $ dirtyKeys shakeExtras
794790
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
@@ -1222,7 +1218,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
12221218
Just (v@(Succeeded _ x), diags) -> do
12231219
ver <- estimateFileVersionUnsafely key (Just x) file
12241220
doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags
1225-
return $ Just $ RunResult ChangedNothing old $ A v
1221+
return $ Just $ RunResult ChangedNothing old (A v) $ return ()
12261222
_ -> return Nothing
12271223
_ ->
12281224
-- assert that a "clean" rule is never a cache miss
@@ -1246,7 +1242,6 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
12461242
Nothing -> do
12471243
pure (toShakeValue ShakeStale mbBs, staleV)
12481244
Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v)
1249-
liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags)
12501245
doDiagnostics (vfsVersion =<< ver) diags
12511246
let eq = case (bs, fmap decodeShakeValue mbOld) of
12521247
(ShakeResult a, Just (ShakeResult b)) -> cmp a b
@@ -1256,9 +1251,12 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
12561251
_ -> False
12571252
return $ RunResult
12581253
(if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
1259-
(encodeShakeValue bs) $
1260-
A res
1261-
liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
1254+
(encodeShakeValue bs)
1255+
(A res) $ do
1256+
-- this hook needs to be run in the same transaction as the key is marked clean
1257+
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
1258+
setValues state key file res (Vector.fromList diags)
1259+
modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
12621260
return res
12631261
where
12641262
-- Highly unsafe helper to compute the version of a file
@@ -1282,6 +1280,32 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
12821280
-- * creating bogus "file does not exists" diagnostics
12831281
| otherwise = useWithoutDependency (GetModificationTime_ False) fp
12841282

1283+
-- Note [Housekeeping rule cache and dirty key outside of hls-graph]
1284+
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1285+
-- Hls-graph contains its own internal running state for each key in the shakeDatabase.
1286+
-- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became
1287+
-- dirty in between build sessions) that is not visible to the hls-graph
1288+
-- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state
1289+
-- in sync.
1290+
1291+
-- 1. A dirty key collected in a session should not be removed from dirty keys in the same session.
1292+
-- Since if we clean out the dirty key in the same session,
1293+
-- 1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart.
1294+
-- 1.2. a key might be marked as dirty in ShakeExtras while it's being recomputed by hls-graph which could lead to it's premature removal from dirtyKeys.
1295+
-- See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details.
1296+
1297+
-- 2. When a key is marked clean in the hls-graph's internal running
1298+
-- state, the rule cache and dirty keys are updated in the same transaction.
1299+
-- otherwise, some situations like the following can happen:
1300+
-- thread 1: hls-graph session run a key
1301+
-- thread 1: defineEarlyCutoff' run the action for the key
1302+
-- thread 1: the action is done, rule cache and dirty key are updated
1303+
-- thread 2: we restart the hls-graph session, thread 1 is killed, the
1304+
-- hls-graph's internal state is not updated.
1305+
-- This is problematic with early cut off because we are having a new rule cache matching the
1306+
-- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation.
1307+
-- See https://github.com/haskell/haskell-language-server/issues/4194 for more details.
1308+
12851309
traceA :: A v -> String
12861310
traceA (A Failed{}) = "Failed"
12871311
traceA (A Stale{}) = "Stale"

‎ghcide/src/Development/IDE/Core/Tracing.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -112,7 +112,7 @@ otTracedAction key file mode result act
112112
ExitCaseSuccess res -> do
113113
setTag sp "result" (pack $ result $ runValue res)
114114
setTag sp "changed" $ case res of
115-
RunResult x _ _ -> fromString $ show x
115+
RunResult x _ _ _ -> fromString $ show x
116116
endSpan sp)
117117
(\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics ))
118118
| otherwise = act (\_ -> return ())

0 commit comments

Comments
 (0)