fix old actions runs because we did not increment the step

before releasing the serialized queue

Author: soulomoon

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

@@ -129,9 +129,9 @@ import           Development.IDE.Types.Options           as Options
 import qualified Language.LSP.Protocol.Message           as LSP
 import qualified Language.LSP.Server                     as LSP
 
-import           Control.Exception                       (Exception (fromException))
-import           Data.Either                             (isLeft, isRight,
-                                                          lefts)
+import           Data.Either                             (isRight, lefts)
+import           Data.Int                                (Int64)
+import           Data.IORef.Extra                        (atomicModifyIORef'_)
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat              (NameCache,
                                                           NameCacheUpdater,
@@ -142,13 +142,15 @@ import           Development.IDE.Graph                   hiding (ShakeValue,
                                                           action)
 import qualified Development.IDE.Graph                   as Shake
 import           Development.IDE.Graph.Database          (ShakeDatabase,
+                                                          shakeGetActionQueueLength,
                                                           shakeGetBuildStep,
                                                           shakeGetDatabaseKeys,
                                                           shakeNewDatabase,
                                                           shakeProfileDatabase,
                                                           shakeRunDatabaseForKeys,
+                                                          shakeRunDatabaseForKeysSep,
                                                           shakeShutDatabase)
-import           Development.IDE.Graph.Internal.Action   (runActionInDb)
+import           Development.IDE.Graph.Internal.Action   (runActionInDbCb)
 import           Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill))
 import           Development.IDE.Graph.Internal.Types    (Step (..),
                                                           getShakeStep)
@@ -184,15 +186,15 @@ import qualified StmContainers.Map                       as STM
 import           System.FilePath                         hiding (makeRelative)
 import           System.IO.Unsafe                        (unsafePerformIO)
 import           System.Time.Extra
-import           UnliftIO                                (MonadUnliftIO (withRunInIO))
-import qualified UnliftIO.Exception                      as UE
+import           UnliftIO                                (MonadUnliftIO (withRunInIO),
+                                                          newIORef, readIORef)
 
 
 
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)
+  | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) !Int
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !Step !(Either SomeException [Either SomeException ()])
@@ -207,10 +209,13 @@ data Log
   -- * OfInterest Log messages
   | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
   | LogShakeText !T.Text
+  | LogMonitering !T.Text !Int64
   deriving Show
 
 instance Pretty Log where
   pretty = \case
+    LogMonitering name value ->
+      "Monitoring:" <+> pretty name <+> "value:" <+> pretty value
     LogDiagsPublishLog key lastDiags diags ->
         vcat
             [ "Publishing diagnostics for" <+> pretty (show key)
@@ -222,11 +227,12 @@ instance Pretty Log where
       "Initializing exports map from hiedb"
     LogCreateHieDbExportsMapFinish exportsMapSize ->
       "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize
-    LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath ->
+    LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath step ->
       vcat
         [ "Restarting build session due to" <+> pretty reason
         , "Action Queue:" <+> pretty (map actionName actionQueue)
         , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
+        , "Current step:" <+> pretty (show step)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
         "Build restart is taking too long (" <> pretty seconds <> " seconds)"
@@ -690,7 +696,7 @@ shakeOpen :: Recorder (WithPriority Log)
 shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
   shakeProfileDir (IdeReportProgress reportProgress)
   ideTesting
-  withHieDb threadQueue opts monitoring rules rootDir = mdo
+  withHieDb threadQueue opts argMonitoring rules rootDir = mdo
     -- see Note [Serializing runs in separate thread]
     let indexQueue = tIndexQueue threadQueue
         restartQueue = tRestartQueue threadQueue
@@ -717,12 +723,12 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         let hiedbWriter = HieDbWriter{..}
         exportsMap <- newTVarIO mempty
         -- lazily initialize the exports map with the contents of the hiedb
-        -- TODO: exceptions can be swallowed here?
-        _ <- async $ do
+        async <- async $ do
             logWith recorder Debug LogCreateHieDbExportsMapStart
             em <- createExportsMapHieDb withHieDb
             atomically $ modifyTVar' exportsMap (<> em)
             logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)
+        link async
 
         progress <-
             if reportProgress
@@ -750,26 +756,46 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
 
     checkParents <- optCheckParents
 
+
+    logMonitoring <- newLogMonitoring recorder
+    let monitoring = logMonitoring <> argMonitoring
     -- monitoring
     let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
         readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
         readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
         readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)
         readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
         readDatabaseStep =  fromIntegral <$> shakeGetBuildStep shakeDb
+        readDatabaseActionQueueCount = fromIntegral <$> shakeGetActionQueueLength shakeDb
 
     registerGauge monitoring "ghcide.values_count" readValuesCounter
     registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys
     registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending
     registerGauge monitoring "ghcide.exports_map_count" readExportsMap
     registerGauge monitoring "ghcide.database_count" readDatabaseCount
     registerCounter monitoring "ghcide.num_builds" readDatabaseStep
+    registerCounter monitoring "ghcide.database_action_queue_count" readDatabaseActionQueueCount
 
     stopMonitoring <- start monitoring
 
     let ideState = IdeState{..}
     return ideState
-
+newLogMonitoring :: MonadIO m => Recorder (WithPriority Log) -> m Monitoring
+newLogMonitoring logger = do
+    actions <- newIORef []
+    let registerCounter name readA = do
+            let update = do
+                    val <- readA
+                    logWith logger Info $ LogMonitering name (fromIntegral val)
+            atomicModifyIORef'_ actions (update :)
+        registerGauge = registerCounter
+    let start = do
+            a <- regularly 10 $ sequence_ =<< readIORef actions
+            return (cancel a)
+    return Monitoring{..}
+    where
+        regularly :: Seconds -> IO () -> IO (Async ())
+        regularly delay act = async $ forever (act >> sleep delay)
 
 getStateKeys :: ShakeExtras -> IO [Key]
 getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . stateValues
@@ -837,7 +863,8 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
                 res <- shakeDatabaseProfile shakeDb
                 backlog <- readTVarIO $ dirtyKeys shakeExtras
                 -- this log is required by tests
-                logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res
+                step <- shakeGetBuildStep shakeDb
+                logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res step
             )
             -- It is crucial to be masked here, otherwise we can get killed
             -- between spawning the new thread and updating shakeSession.
@@ -859,12 +886,13 @@ shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
 shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
     (b, dai) <- instantiateDelayedAction act
     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue
+    logWith shakeRecorder Debug $ LogShakeText (T.pack $ "Enqueued action: " <> actionName act)
     let wait' barrier =
             waitBarrier barrier `catches`
               [ Handler(\BlockedIndefinitelyOnMVar ->
                     fail $ "internal bug: forever blocked on MVar for " <>
                             actionName act)
-              , Handler (\e@AsyncCancelled -> do
+              , Handler (\e@(SomeAsyncException _) -> do
                   logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)
 
                   atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue
@@ -892,6 +920,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
       VFSModified vfs -> atomically $ writeTVar vfsVar vfs
 
     IdeOptions{optRunSubset} <- getIdeOptionsIO extras
+
     reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
     step <- getShakeStep shakeDb
     allPendingKeys <-
@@ -907,37 +936,39 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
             Left e  -> logWith recorder Error $ LogShakeText (T.pack $ label ++ " failed: " ++ show e)
             Right r -> logWith recorder Debug $ LogShakeText (T.pack $ label ++ " finished: " ++ show r)
         pumpActionThread = do
-            d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue
-            r <- runActionInDb [run d]
-            liftIO $ logResult "pumpActionThread" r
+            logWith recorder Debug $ LogShakeText (T.pack $ "Starting action" ++ "(step: " <> show step)
+            d <- runActionInDbCb actionName run (popQueue actionQueue) (logResult "pumpActionThread" . return)
+            step <- getShakeStep shakeDb
+            logWith recorder Debug $ LogShakeText (T.pack $ "started action" ++ "(step: " <> show step <> "): " <> actionName d)
             pumpActionThread
 
         -- TODO figure out how to thread the otSpan into defineEarlyCutoff
-        run d  = do
+        run d = do
             start <- liftIO offsetTime
             getAction d
             liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue
             runTime <- liftIO start
             logWith recorder (actionPriority d) $ LogDelayedAction d runTime
 
         -- The inferred type signature doesn't work in ghc >= 9.0.1
-        workRun :: (forall b. IO b -> IO b) -> IO ()
-        workRun restore = withSpan "Shake session" $ \otSpan -> do
+        -- workRun :: (forall b. IO b -> IO b) -> IO ()
+        workRun start restore = withSpan "Shake session" $ \otSpan -> do
           setTag otSpan "reason" (fromString reason)
           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)
           whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)
-          let keysActs = pumpActionThread : map run (reenqueued ++ acts)
-          res <- try @SomeException $
-                    restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs
-          logWith recorder Debug $ LogBuildSessionFinish step $ res
+          res <- try @SomeException $ restore start
+          logWith recorder Debug $ LogBuildSessionFinish step res
 
+
+    let keysActs = pumpActionThread : map run (reenqueued ++ acts)
+    -- first we increase the step, so any actions started from here on
+    start <- shakeRunDatabaseForKeysSep (toListKeySet <$> allPendingKeys) shakeDb keysActs
     -- Do the work in a background thread
     parentTid <- myThreadId
     workThread <- asyncWithUnmask $ \x -> do
         childThreadId <- myThreadId
         logWith recorder Info $ LogShakeText ("Starting shake thread: " <> T.pack (show childThreadId) <> " (parent: " <> T.pack (show parentTid) <> ")")
-        workRun x
-
+        workRun start x
 
     --  Cancelling is required to flush the Shake database when either
     --  the filesystem or the Ghc configuration have changed
@@ -949,7 +980,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
             cancelWith workThread $ AsyncParentKill tid step
             shakeShutDatabase shakeDb
 
-
+    -- should wait until the step has increased
     pure (ShakeSession{..})
 
 instantiateDelayedAction

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -4,15 +4,19 @@ module Development.IDE.Graph.Database(
     shakeNewDatabase,
     shakeRunDatabase,
     shakeRunDatabaseForKeys,
+    shakeRunDatabaseForKeysSep,
     shakeProfileDatabase,
     shakeGetBuildStep,
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
     shakeGetCleanKeys
     ,shakeGetBuildEdges,
-    shakeShutDatabase) where
-import           Control.Concurrent.STM.Stats            (readTVarIO)
+    shakeShutDatabase,
+    shakeGetActionQueueLength) where
+import           Control.Concurrent.STM.Stats            (atomically,
+                                                          readTVarIO)
 import           Control.Exception                       (SomeException)
+import           Control.Monad                           (join)
 import           Data.Dynamic
 import           Data.Maybe
 import           Development.IDE.Graph.Classes           ()
@@ -40,7 +44,7 @@ shakeNewDatabase que opts rules = do
     pure $ ShakeDatabase (length actions) actions db
 
 shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [Either SomeException a]
-shakeRunDatabase = shakeRunDatabaseForKeys Nothing
+shakeRunDatabase s xs = shakeRunDatabaseForKeys Nothing s xs
 
 -- | Returns the set of dirty keys annotated with their age (in # of builds)
 shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
@@ -58,15 +62,26 @@ unvoid :: Functor m => m () -> m a
 unvoid = fmap undefined
 
 -- | Assumes that the database is not running a build
-shakeRunDatabaseForKeys
+-- The nested IO is to
+-- seperate incrementing the step from running the build
+shakeRunDatabaseForKeysSep
     :: Maybe [Key]
       -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
     -> ShakeDatabase
     -> [Action a]
-    -> IO [Either SomeException a]
-shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
+    -> IO (IO [Either SomeException a])
+shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
     incDatabase db keysChanged
-    drop lenAs1 <$> runActions db (map unvoid as1 ++ as2)
+    return $ drop lenAs1 <$> runActions db (map unvoid as1 ++ as2)
+
+shakeRunDatabaseForKeys
+    :: Maybe [Key]
+      -- ^ Set of keys changed since last run. 'Nothing' means everything has changed
+    -> ShakeDatabase
+    -> [Action a]
+    -> (IO [Either SomeException a])
+shakeRunDatabaseForKeys keysChanged sdb as2 = join $ shakeRunDatabaseForKeysSep keysChanged sdb as2
+
 
 
 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run.
@@ -90,3 +105,7 @@ shakeGetBuildEdges (ShakeDatabase _ _ db) = do
 --   annotated with how long ago (in # builds) they were visited
 shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)]
 shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db
+
+shakeGetActionQueueLength :: ShakeDatabase -> IO Int
+shakeGetActionQueueLength (ShakeDatabase _ _ db) =
+    atomically $ databaseGetActionQueueLength db

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -13,10 +13,11 @@ module Development.IDE.Graph.Internal.Action
 , runActions
 , Development.IDE.Graph.Internal.Action.getDirtySet
 , getKeysAndVisitedAge
-, runActionInDb
+, runActionInDbCb
 ) where
 
 import           Control.Concurrent.Async
+import           Control.Concurrent.STM.Stats            (atomicallyNamed)
 import           Control.DeepSeq                         (force)
 import           Control.Exception
 import           Control.Monad.IO.Class
@@ -31,7 +32,7 @@ import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Rules    (RuleResult)
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
-import           UnliftIO                                (atomically,
+import           UnliftIO                                (STM, atomically,
                                                           newEmptyTMVarIO,
                                                           putTMVar, readTMVar)
 
@@ -48,23 +49,32 @@ parallel [] = return []
 parallel xs = do
     a <- Action ask
     deps <- liftIO $ readIORef $ actionDeps a
-
     case deps of
         UnknownDeps ->
             -- if we are already in the rerun mode, nothing we do is going to impact our state
-            runActionInDb xs
+            runActionInDb "parallel" xs
         deps -> error $ "parallel not supported when we have precise dependencies: " ++ show deps
             -- (newDeps, res) <- liftIO $ unzip <$> runActionInDb usingState xs
             -- liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
             -- return ()
 
-runActionInDb :: [Action a] -> Action [Either SomeException a]
-runActionInDb acts = do
+-- non-blocking version of runActionInDb
+runActionInDbCb :: (a -> String) -> (a -> Action result) -> STM a -> (Either SomeException result -> IO ()) -> Action a
+runActionInDbCb getTitle work getAct handler = do
+    a <- Action ask
+    liftIO $ atomicallyNamed "action queue - pop" $ do
+        act <- getAct
+        runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)]
+        return act
+
+runActionInDb :: String -> [Action a] -> Action [Either SomeException a]
+runActionInDb title acts = do
     a <- Action ask
     xs <- mapM (\x -> do
         barrier <- newEmptyTMVarIO
         return (x, barrier)) acts
-    liftIO $ atomically $ runInDataBase (actionDatabase a) (map (\(x, b) -> (ignoreState a x >>= (atomically . putTMVar b . Right), atomically . putTMVar b . Left)) xs)
+    liftIO $ atomically $ runInDataBase title (actionDatabase a)
+        (map (\(x, b) -> (ignoreState a x, atomically . putTMVar b)) xs)
     results <- liftIO $ mapM (atomically . readTMVar) $ fmap snd xs
     return results
 

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -123,7 +123,7 @@ builderOne db@Database {..} stack id = do
       Dirty s -> do
         SMap.focus (updateStatus $ Running current s) id databaseValues
         traceEvent ("Starting build of key: " ++ show id ++ ", step "++ show current)
-            $ runOneInDataBase db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues
+            $ runOneInDataBase (show id) db (refresh db stack id s) $ \e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues
         return Nothing
       Clean r -> return $ Just r
       -- force here might contains async exceptions from previous runs