Stabilize the build system by correctly house keeping the dirtykeys and rule values [flaky test #4185 #4093] (#4190)

The main problem is the out of sync state in the build system. Several states involved, the shake database running result state for key. shake extra's dirty state for key and shake extra's rule values state.
To stablize the build system. This PR force some of the updates of these state into a single STM block.

1. collect dirtykeys and ship it to session restart directly. No more invalid removal before session restart. Fixing Flaky test failure result in error of GetLinkable #4093
2. move the dirtykey removal and rules values updating to hls-graph by adding a call back fucntion to RunResult. Properly handle the dirtykeys and rule value state after session start and closely followed by another session restart Fixing ghcide-tests' addDependentFile test #4194
3. properly handle clean up by wrapping the asyncWithCleanUp to refreshDeps

---------

Co-authored-by: wz1000 <[email protected]>
Co-authored-by: Jan Hrcek <[email protected]>
Co-authored-by: Michael Peyton Jones <[email protected]>

Author: 4 people

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, toNoFileKey)
 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 $ toNoFileKey GhcSessionIO
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject
@@ -510,16 +509,16 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
                 return [(targetTarget, Set.fromList found)]
-          hasUpdate <- join $ atomically $ do
+          hasUpdate <- atomically $ do
             known <- readTVar knownTargetsVar
             let known' = flip mapHashed known $ \k ->
                             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)
+            pure hasUpdate
           for_ hasUpdate $ \x ->
             logWith recorder Debug $ LogKnownFilesUpdated x
+          return $ toNoFileKey GetKnownTargets
 
     -- Create a new HscEnv from a hieYaml root and a set of options
     let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
@@ -612,18 +611,14 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                                        , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
                                        ]
 
-          void $ modifyVar' fileToFlags $
-              Map.insert hieYaml this_flags_map
-          void $ modifyVar' filesMap $
-              flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
-
-          void $ extendKnownTargets all_targets
-
-          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
-          invalidateShakeCache
-
+          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" []
+          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
+          keys2 <- invalidateShakeCache
+          restartShakeSession VFSUnmodified "new component" [] $ do
+            keys1 <- extendKnownTargets all_targets
+            return [keys1, keys2]
 
           -- Typecheck all files in the project on startup
           checkProject <- getCheckProject

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,
@@ -105,12 +106,12 @@ getFileExistsMapUntracked = do
   FileExistsMapVar v <- getIdeGlobalAction
   return v
 
--- | Modify the global store of file exists.
-modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
+-- | Modify the global store of file exists and return the keys that need to be marked as dirty
+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
+  mask_ $ atomicallyNamed "modifyFileExists" $ do
     forM_ changes $ \(f,c) ->
         case fromChange c of
             Just c' -> STM.focus (Focus.insert c') f var
@@ -119,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
-    io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
-    io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
-    return (io1 <> io2)
+    keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
+    let keys1 = map (toKey GetFileExists . fst) fileExistChanges
+    let keys2 = map (toKey GetModificationTime . fst) fileModifChanges
+    return (keys0 <> keys1 <> keys2)
 
 fromChange :: FileChangeType -> Maybe Bool
 fromChange FileChangeType_Created = Just True

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),
@@ -148,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
@@ -215,16 +216,18 @@ setFileModified :: Recorder (WithPriority Log)
                 -> IdeState
                 -> Bool -- ^ Was the file saved?
                 -> NormalizedFilePath
+                -> IO [Key]
                 -> IO ()
-setFileModified recorder vfs state saved nfp = do
+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
+        keys<-actionBefore
+        return (toKey GetModificationTime nfp:keys)
     when checkParents $
       typecheckParents recorder state nfp
 
@@ -244,14 +247,11 @@ typecheckParentsAction recorder nfp = do
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
-setSomethingModified vfs state keys reason = do
+setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModified vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
-    atomically $ 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 []
+    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

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

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,
@@ -300,6 +300,7 @@ data ShakeExtras = ShakeExtras
         :: VFSModified
         -> String
         -> [DelayedAction ()]
+        -> IO [Key]
         -> IO ()
 #if MIN_VERSION_ghc(9,3,0)
     ,ideNc :: NameCache
@@ -557,26 +558,17 @@ setValues state key file val diags =
 
 
 -- | Delete the value stored for a given ide build key
+-- and return the key that was deleted.
 deleteValue
   :: Shake.ShakeValue k
   => ShakeExtras
   -> k
   -> NormalizedFilePath
-  -> STM ()
-deleteValue ShakeExtras{dirtyKeys, state} key file = do
+  -> STM [Key]
+deleteValue ShakeExtras{state} key file = do
     STM.delete (toKey key file) state
-    modifyTVar' dirtyKeys $ insertKeySet (toKey key file)
+    return [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)
 
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues ::
@@ -759,12 +751,16 @@ 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 ()] -> IO [Key] -> IO ()
+shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
     withMVar'
         shakeSession
         (\runner -> do
               (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
+              keys <- ioActionBetweenShakeSession
+              -- it is every important to update the dirty keys after we enter the critical section
+              -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
+              atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
               res <- shakeDatabaseProfile shakeDb
               backlog <- readTVarIO $ dirtyKeys shakeExtras
               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
@@ -1198,7 +1194,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) $ return ()
                     _ -> return Nothing
             _ ->
                 -- assert that a "clean" rule is never a cache miss
@@ -1222,7 +1218,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
@@ -1232,9 +1227,12 @@ 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) $ do
+                        -- this hook needs to be run in the same transaction as the key is marked clean
+                        -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
+                        setValues state key file res (Vector.fromList diags)
+                        modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
         return res
   where
     -- Highly unsafe helper to compute the version of a file
@@ -1258,6 +1256,32 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
         --  * creating bogus "file does not exists" diagnostics
         | otherwise = useWithoutDependency (GetModificationTime_ False) fp
 
+-- Note [Housekeeping rule cache and dirty key outside of hls-graph]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Hls-graph contains its own internal running state for each key in the shakeDatabase.
+-- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became
+-- dirty in between build sessions) that is not visible to the hls-graph
+-- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state
+-- in sync.
+
+-- 1. A dirty key collected in a session should not be removed from dirty keys in the same session.
+-- Since if we clean out the dirty key in the same session,
+--     1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart.
+--     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.
+--          See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details.
+
+-- 2. When a key is marked clean in the hls-graph's internal running
+-- state, the rule cache and dirty keys are updated in the same transaction.
+-- otherwise, some situations like the following can happen:
+-- thread 1: hls-graph session run a key
+-- thread 1: defineEarlyCutoff' run the action for the key
+-- thread 1: the action is done, rule cache and dirty key are updated
+-- thread 2: we restart the hls-graph session, thread 1 is killed, the
+--           hls-graph's internal state is not updated.
+-- This is problematic with early cut off because we are having a new rule cache matching the
+-- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation.
+-- See https://github.com/haskell/haskell-language-server/issues/4194 for more details.
+
 traceA :: A v -> String
 traceA (A Failed{})    = "Failed"
 traceA (A Stale{})     = "Stale"

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