prefer restart than other actions in shakeControlQueu

Author: soulomoon

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

@@ -27,7 +27,7 @@ module Development.IDE.Core.Shake(
     KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets,
     ShakeRestartArgs(..),
     shakeRestart,
-    IdeRule, IdeResult, RestartQueue,
+    IdeRule, IdeResult, ShakeControlQueue,
     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
     shakeOpen, shakeShut,
     shakeEnqueue,
@@ -78,7 +78,7 @@ module Development.IDE.Core.Shake(
     Log(..),
     VFSModified(..), getClientConfigAction,
     ThreadQueue(..),
-    runWithSignal, runRestartTask, runRestartTaskDync, dynShakeRestart
+    runWithSignal, runRestartTask, runRestartTaskDyn, dynShakeRestart
     ) where
 
 import           Control.Concurrent.Async
@@ -289,16 +289,16 @@ data HieDbWriter
 -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()`
 -- with (currently) retry functionality
 type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
--- type RestartQueue = TaskQueue ShakeRestartArgs
+-- type ShakeControlQueue = TaskQueue ShakeRestartArgs
 type ShakeQueue = DBQue
-type RestartQueue = ShakeQueue
+type ShakeControlQueue = ShakeQueue
 type LoaderQueue = TaskQueue (IO ())
 
 
 data ThreadQueue = ThreadQueue {
-    tIndexQueue     :: IndexQueue
-    , tRestartQueue :: RestartQueue
-    , tLoaderQueue  :: LoaderQueue
+    tIndexQueue          :: IndexQueue
+    , tShakeControlQueue :: ShakeControlQueue
+    , tLoaderQueue       :: LoaderQueue
 }
 
 -- Note [Semantic Tokens Cache Location]
@@ -369,7 +369,7 @@ data ShakeExtras = ShakeExtras
       -- ^ Default HLS config, only relevant if the client does not provide any Config
     , dirtyKeys :: TVar KeySet
       -- ^ Set of dirty rule keys since the last Shake run
-    , restartQueue :: RestartQueue
+    , shakeControlQueue :: ShakeControlQueue
       -- ^ Queue of restart actions to be run.
     , loaderQueue :: LoaderQueue
       -- ^ Queue of loader actions to be run.
@@ -707,7 +707,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
   withHieDb threadQueue opts argMonitoring rules rootDir = mdo
     -- see Note [Serializing runs in separate thread]
     let indexQueue = tIndexQueue threadQueue
-        restartQueue = tRestartQueue threadQueue
+        shakeControlQueue = tShakeControlQueue threadQueue
         loaderQueue = tLoaderQueue threadQueue
 
     ideNc <- initNameCache 'r' knownKeyNames
@@ -720,7 +720,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         semanticTokensCache <- STM.newIO
         positionMapping <- STM.newIO
         knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets
-        let restartShakeSession = shakeRestart restartQueue
+        let restartShakeSession = shakeRestart shakeControlQueue
         persistentKeys <- newTVarIO mempty
         indexPending <- newTVarIO HMap.empty
         indexCompleted <- newTVarIO 0
@@ -751,7 +751,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         pure ShakeExtras{shakeRecorder = recorder, ..}
     shakeDb  <-
         shakeNewDatabase
-            restartQueue
+            shakeControlQueue
             opts { shakeExtra = newShakeExtra shakeExtras }
             rules
     shakeSession <- newEmptyMVar
@@ -855,13 +855,13 @@ delayedAction a = do
 
 
 data ShakeRestartArgs = ShakeRestartArgs
-    { sraVfs             :: !VFSModified
-    , sraReason          :: !String
-    , sraActions         :: ![DelayedAction ()]
-    , sraBetweenSessions :: IO [Key]
-    , sraReStartQueue    :: !RestartQueue
-    , sraCount           :: !Int
-    , sraWaitMVars       :: ![MVar ()]
+    { sraVfs               :: !VFSModified
+    , sraReason            :: !String
+    , sraActions           :: ![DelayedAction ()]
+    , sraBetweenSessions   :: IO [Key]
+    , sraShakeControlQueue :: !ShakeControlQueue
+    , sraCount             :: !Int
+    , sraWaitMVars         :: ![MVar ()]
     -- ^ Just for debugging, how many restarts have been requested so far
     }
 
@@ -878,18 +878,20 @@ instance Semigroup ShakeRestartArgs where
             , sraReason = sraReason a ++ "; " ++ sraReason b
             , sraActions = sraActions a ++ sraActions b
             , sraBetweenSessions = (++) <$> sraBetweenSessions a <*> sraBetweenSessions b
-            , sraReStartQueue = sraReStartQueue a
+            , sraShakeControlQueue = sraShakeControlQueue a
             , sraCount = sraCount a + sraCount b
             , sraWaitMVars = sraWaitMVars a ++ sraWaitMVars b
             }
 
 -- | Restart the current 'ShakeSession' with the given system actions.
 --   Any actions running in the current session will be aborted,
 --   but actions added via 'shakeEnqueue' will be requeued.
-shakeRestart :: RestartQueue ->  VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
+shakeRestart :: ShakeControlQueue ->  VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
 shakeRestart rts vfs reason acts ioActionBetweenShakeSession = do
     waitMVar <- newEmptyMVar
-    void $ submitWork rts $ Left $
+    -- submit at the head of the queue,
+    -- prefer restart request over any pending actions
+    void $ submitWorkAtHead rts $ Left $
         toDyn $ ShakeRestartArgs vfs reason acts ioActionBetweenShakeSession rts 1 [waitMVar]
     -- Wait until the restart is done
     takeMVar waitMVar
@@ -901,8 +903,8 @@ dynShakeRestart dy = case fromDynamic dy of
 
 -- runRestartTask :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
 -- runRestartTask recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
-runRestartTaskDync :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO ()
-runRestartTaskDync recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy)
+runRestartTaskDyn :: Recorder (WithPriority Log) -> MVar IdeState -> Dynamic -> IO ()
+runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar (dynShakeRestart dy)
 
 runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO ()
 runRestartTask recorder ideStateVar shakeRestartArgs = do
@@ -913,15 +915,15 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
         -- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
         atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
         -- Check if there is another restart request pending, if so, we run that one too
-        readAndGo sra sraReStartQueue
-      readAndGo sra sraReStartQueue = do
-        nextRestartArg <- atomically $ tryReadTaskQueue sraReStartQueue
+        readAndGo sra sraShakeControlQueue
+      readAndGo sra sraShakeControlQueue = do
+        nextRestartArg <- atomically $ tryReadTaskQueue sraShakeControlQueue
         case nextRestartArg of
           Nothing -> return sra
           Just (Left dy) -> do
             res <- prepareRestart $ dynShakeRestart dy
             return $ sra <> res
-          Just (Right _) -> readAndGo sra sraReStartQueue
+          Just (Right _) -> readAndGo sra sraShakeControlQueue
   withMVar'
     shakeSession
     ( \runner -> do

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -357,8 +357,8 @@ runShakeThread :: Recorder (WithPriority Log) -> MVar IdeState -> ContT () IO DB
 runShakeThread recorder mide =
   withWorkerQueue
     (logWith (cmapWithPrio (LogSession . Session.LogSessionWorkerThread) recorder) Debug)
-    "ShakeRestartQueue"
-    (eitherWorker (runRestartTaskDync (cmapWithPrio LogShake recorder) mide) id)
+    "ShakeShakeControlQueue"
+    (eitherWorker (runRestartTaskDyn (cmapWithPrio LogShake recorder) mide) id)
 -- | runWithWorkerThreads
 -- create several threads to run the session, db and session loader
 -- see Note [Serializing runs in separate thread]

hlint.eventlog

@@ -26,7 +26,8 @@ module Development.IDE.WorkerThread
     Worker,
     tryReadTaskQueue,
     awaitRunInThreadAtHead,
-    withWorkerQueueSimpleRight
+    withWorkerQueueSimpleRight,
+    submitWorkAtHead
   ) where
 
 import           Control.Concurrent.Async (Async, async, withAsync)
@@ -157,10 +158,12 @@ eitherWorker w1 w2 = \case
 
 -- submitWork without waiting for the result
 submitWork :: TaskQueue arg -> arg -> IO ()
-submitWork (TaskQueue q) arg = do
-  -- Take an action from TQueue, run it and
-  -- use barrier to wait for the result
-  atomically $ writeTQueue q arg
+submitWork (TaskQueue q) arg = do atomically $ writeTQueue q arg
+
+-- submit work at the head of the queue, so it will be executed next
+submitWorkAtHead :: TaskQueue arg -> arg -> IO ()
+submitWorkAtHead (TaskQueue q) arg = do
+  atomically $ unGetTQueue q arg
 
 awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result
 awaitRunInThread (TaskQueue q) act = do

hls-graph/src/Development/IDE/WorkerThread.hs

@@ -0,0 +1,117 @@
+#!/usr/bin/env fish
+
+# Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI.
+# Usage:
+#   scripts/eventlog-dump.fish <file.eventlog> [output.txt] [contains_substring]
+#
+# Notes:
+# - Attempts to find ghc-events in PATH, ~/.cabal/bin, or ~/.local/bin.
+# - If not found, will try: cabal install ghc-events
+# - Output defaults to <basename>.events.txt in the current directory.
+
+function usage
+  echo "Usage: (basename (status filename)) <file.eventlog> [output.txt] [contains_substring]"
+  exit 2
+end
+
+if test (count $argv) -lt 1
+  usage
+end
+
+set evlog $argv[1]
+if not test -f $evlog
+  echo "error: file not found: $evlog" >&2
+  exit 1
+end
+
+if test (count $argv) -ge 2
+  set out $argv[2]
+else
+  set base (basename $evlog)
+  if string match -q '*\.eventlog' $base
+    set out (string replace -r '\\.eventlog$' '.events.txt' -- $base)
+  else
+    set out "$base.events.txt"
+  end
+end
+
+# Optional contains filter: only keep lines that contain any of the substrings (pipe-separated)
+set filter_contains ""
+set filter_contains_list
+if test (count $argv) -ge 3
+  set filter_contains $argv[3]
+  set filter_contains_list (string split '|' -- $filter_contains)
+end
+
+function find_ghc_events --description "echo absolute path to ghc-events or empty"
+  if command -sq ghc-events
+    command -s ghc-events
+    return 0
+  end
+  if test -x ~/.cabal/bin/ghc-events
+    echo ~/.cabal/bin/ghc-events
+    return 0
+  end
+  if test -x ~/.local/bin/ghc-events
+    echo ~/.local/bin/ghc-events
+    return 0
+  end
+  return 1
+end
+
+set ghc_events_bin (find_ghc_events)
+
+if test -z "$ghc_events_bin"
+  echo "ghc-events not found; attempting to install via 'cabal install ghc-events'..." >&2
+  if not command -sq cabal
+    echo "error: cabal not found; please install ghc-events manually (e.g., via cabal)." >&2
+    exit 1
+  end
+  cabal install ghc-events
+  set ghc_events_bin (find_ghc_events)
+  if test -z "$ghc_events_bin"
+    echo "error: ghc-events still not found after installation." >&2
+    exit 1
+  end
+end
+
+echo "Dumping events from $evlog to $out..."
+if test -n "$filter_contains"
+  $ghc_events_bin show $evlog | while read -l line
+    set keep 1
+    if (count $filter_contains_list) -gt 0
+      set found 0
+      for substr in $filter_contains_list
+        if string match -q -- "*$substr*" -- $line
+          set found 1
+          break
+        end
+      end
+      if test $found -eq 0
+        set keep 0
+      end
+    end
+    if test $keep -eq 1
+      echo $line
+    end
+  end > $out
+else
+  $ghc_events_bin show $evlog > $out
+end
+set exit_code $status
+
+if test $exit_code -ne 0
+  echo "error: dump failed with exit code $exit_code" >&2
+  exit $exit_code
+end
+
+set -l size ""
+if command -sq stat
+  # macOS stat prints size with -f%z; suppress errors if not supported
+  set size (stat -f%z $out 2>/dev/null)
+end
+if test -z "$size"
+  set size (wc -c < $out)
+end
+
+echo "Wrote $out ($size bytes)."