diff --git a/.github/workflows/flakiness.yml b/.github/workflows/flakiness.yml new file mode 100644 index 0000000000..4341946542 --- /dev/null +++ b/.github/workflows/flakiness.yml @@ -0,0 +1,109 @@ +name: flakiness + +defaults: + run: + shell: bash + +concurrency: + group: ${{ github.head_ref }}-${{ github.workflow }} + cancel-in-progress: true + +on: + # Run on PRs that touch relevant areas and on manual dispatch + pull_request: + branches: + - '**' + paths: + - 'scripts/flaky-test-loop.sh' + - 'scripts/flaky-test-patterns.txt' + - 'ghcide/**' + - 'ghcide-test/**' + - 'hls-test-utils/**' + - 'src/**' + - 'exe/**' + - 'plugins/**' + - 'cabal.project' + - 'stack.yaml' + - 'haskell-language-server.cabal' + - '.github/workflows/flakiness.yml' + workflow_dispatch: + inputs: + max_iter: + description: 'Maximum iterations to attempt' + required: false + default: '1000' + sleep_secs: + description: 'Seconds to sleep between iterations' + required: false + default: '0' + test_patterns: + description: 'Comma-separated Tasty patterns to run each iteration (overrides default)' + required: false + default: '' + +jobs: + loop: + name: Flakiness Test (broken pipe and test failures) + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + - macos-latest + # - windows-latest + + steps: + - uses: actions/checkout@v4 + + - name: Setup GHC and caching + uses: ./.github/actions/setup-build + with: + ghc: '9.12' + os: ${{ runner.os }} + + - name: Show cabal and GHC versions + run: | + cabal --version + ghc --version + - name: Build + env: + PATTERN_FILE: 'scripts/flaky-test-patterns.txt' + RUN_MODE: 'build' + run: HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh + + - name: Run flakiness loop + id: run-loop + # Let this run for a while; build is done once inside the script + timeout-minutes: 60 + env: + # Use workflow_dispatch inputs when present, else defaults + SLEEP_SECS: ${{ github.event.inputs.sleep_secs || '0' }} + LOG_STDERR: '1' + TEST_PATTERNS: ${{ github.event.inputs.test_patterns }} + PATTERN_FILE: 'scripts/flaky-test-patterns.txt' + NO_BUILD_ONCE: '1' + RUN_MODE: 'run' + # HLS_TEST_EXE: 'hls' # HLS_WRAPPER_TEST_EXE: 'hls-wrapper' + run: | + # Run with a sensible default of 500 iterations on PRs; + max_iter="${{ github.event.inputs.max_iter }}" + max_iter="${max_iter:-500}" + # copy hls to current dir so the script can find it + HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh "${max_iter}" + ec=$? + # Interpret exit codes from flaky-test-loop.sh + # 0 => no issues reproduced within MAX_ITER -> pass job + # 1 => issue reproduced (broken pipe or test failure) -> fail job + # 2+ => setup/infra error -> fail job + if [[ $ec -eq 1 ]]; then + echo "Issue reproduced (broken pipe or test failure): failing job" + exit 1 + elif [[ $ec -eq 0 ]]; then + echo "No issues reproduced within MAX_ITER=${max_iter}: passing" + exit 0 + else + echo "Loop script error (exit $ec): failing" + exit $ec + fi + diff --git a/cabal.project b/cabal.project index 8d8bd080af..d83e432492 100644 --- a/cabal.project +++ b/cabal.project @@ -56,3 +56,9 @@ if impl(ghc >= 9.11) allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, + +source-repository-package + type: git + location: https://github.com/soulomoon/lsp.git + tag: 640c7c755bf16128e3cb19c257688aa3305ff9f5 + subdir: lsp lsp-types lsp-test diff --git a/ghcide-test/exe/ResolveTests.hs b/ghcide-test/exe/ResolveTests.hs index 4fc917c56b..0886fd62ce 100644 --- a/ghcide-test/exe/ResolveTests.hs +++ b/ghcide-test/exe/ResolveTests.hs @@ -24,7 +24,7 @@ import Language.LSP.Test hiding (resolveCompletion) import Test.Hls (IdeState, SMethod (..), liftIO, mkPluginTestDescriptor, someMethodToMethodString, - waitForAllProgressDone) + waitForKickDone) import qualified Test.Hls.FileSystem as FS import Test.Tasty import Test.Tasty.HUnit @@ -100,7 +100,7 @@ resolveRequests = , "data Foo = Foo { foo :: Int }" , "bar = Foo 4" ] - waitForAllProgressDone + waitForKickDone items <- getCompletions doc (Position 2 7) let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems) @@ -113,7 +113,7 @@ resolveRequests = , "data Foo = Foo { foo :: Int }" , "bar = Foo 4" ] - waitForAllProgressDone + waitForKickDone -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic -- locations and we don't have diagnostics in these tests. cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0)) @@ -128,7 +128,7 @@ resolveRequests = , "data Foo = Foo { foo :: Int }" , "bar = Foo 4" ] - waitForAllProgressDone + waitForKickDone cd <- getCodeLenses doc let resolveCodeLenses = filter (\i -> case i ^. J.command of Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dde1cfdea5..4be4fd78e2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeFamilies #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -104,8 +105,7 @@ import qualified Data.HashSet as Set import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (awaitRunInThread, - withWorkerQueue) +import Development.IDE.Core.WorkerThread import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -119,6 +119,7 @@ import qualified System.Random as Random import System.Random (RandomGen) import Text.ParserCombinators.ReadP (readP_to_S) +import qualified Control.Monad.Catch as MC import GHC.Driver.Env (hsc_all_home_unit_ids) import GHC.Driver.Errors.Types import GHC.Types.Error (errMsgDiagnostic, @@ -149,10 +150,12 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogSessionWorkerThread LogWorkerThread deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionWorkerThread msg -> pretty msg LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -381,8 +384,8 @@ runWithDb recorder fp = ContT $ \k -> do _ <- withWriteDbRetryable deleteMissingRealFiles _ <- withWriteDbRetryable garbageCollectTypeNames - runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan -> - withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) + runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable)) + $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) where writer withHieDbRetryable l = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler @@ -415,7 +418,7 @@ getHieDbLoc dir = do -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] @@ -753,6 +756,7 @@ emptyHscEnv :: NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do -- We call setSessionDynFlags so that the loader is initialised -- We need to do this before we call initUnits. + -- we mask_ here because asynchronous exceptions might be swallowed env <- runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 48439e2ff3..5a3039c5fe 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -75,6 +75,7 @@ import Development.IDE.Core.Preprocessor import Development.IDE.Core.ProgressReporting (progressUpdate) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.Core.WorkerThread (writeTaskQueue) import Development.IDE.Core.Tracing (withTrace) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC @@ -882,7 +883,7 @@ indexHieFile se mod_summary srcPath !hash hf = do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \withHieDb -> do + writeTaskQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index e545ec7b14..37177a22d1 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -45,6 +45,7 @@ import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -252,8 +253,8 @@ getVersionedTextDoc doc = do maybe (pure Nothing) getVirtualFile $ uriToNormalizedFilePath $ toNormalizedUri uri let ver = case mvf of - Just (VirtualFile lspver _ _) -> lspver - Nothing -> 0 + Just (VirtualFile lspver _ _ _) -> lspver + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () @@ -304,7 +305,7 @@ 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 - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 3d8a2bf989..868674f99d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -23,24 +23,30 @@ import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, retry) -import Control.Concurrent.Strict (modifyVar_, newVar, - threadDelay) +import Control.Concurrent.Strict (modifyVar_, newBarrier, newVar, + signalBarrier, threadDelay) import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import qualified Data.Aeson as J import Data.Functor (($>)) import qualified Data.Text as T +import Data.Unique (hashUnique, newUnique) import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus +import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (ProgressAmount (..), +import qualified Language.LSP.Protocol.Types as L +import Language.LSP.Server (MonadLsp, ProgressAmount (..), ProgressCancellable (..), + sendNotification, sendRequest, withProgress) import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM import UnliftIO (Async, async, bracket, cancel) +import qualified UnliftIO.Exception as UE data ProgressEvent = ProgressNewStarted @@ -168,7 +174,7 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do let _progressUpdate event = liftIO $ updateStateVar $ Event event _progressStop = updateStateVar StopProgress updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) - return ProgressReporting {..} + return ProgressReporting {_progressUpdate, _progressStop} -- | `progressReporting` initiates a new progress reporting session. -- It necessitates the active tracking of progress using the `inProgress` function. @@ -196,6 +202,28 @@ progressReporting (Just lspEnv) title optProgressStyle = do f = recordProgress inProgress file +withProgressDummy :: + forall c m a. + MonadLsp c m => + T.Text -> + Maybe ProgressToken -> + ProgressCancellable -> + ((ProgressAmount -> m ()) -> m a) -> + m a +withProgressDummy title _ _ f = do + UE.bracket start end $ \_ -> + f (const $ return ()) + where + sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report + start = UE.uninterruptibleMask_ $ do + t <- L.ProgressToken . L.InR . T.pack . show . hashUnique <$> liftIO newUnique + r <- liftIO newBarrier + _ <- sendRequest SMethod_WindowWorkDoneProgressCreate (WorkDoneProgressCreateParams t) $ \_ -> liftIO $ signalBarrier r () + sendProgressReport t $ WorkDoneProgressBegin L.AString title Nothing Nothing Nothing + return t + end t = do + sendProgressReport t (WorkDoneProgressEnd L.AString Nothing) + -- Kill this to complete the progress session progressCounter :: LSP.LanguageContextEnv c -> @@ -205,8 +233,12 @@ progressCounter :: STM Int -> IO () progressCounter lspEnv title optProgressStyle getTodo getDone = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 + LSP.runLspT lspEnv $ withProgressChoice title Nothing NotCancellable $ \update -> loop update 0 where + withProgressChoice = case optProgressStyle of + TestReporting -> withProgressDummy + _ -> withProgress + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do (todo, done, nextPct) <- liftIO $ atomically $ do diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 964d6d379b..b78ad21641 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -516,8 +516,8 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybe vfsRef <- asks vfsVar vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of - Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + Just (Open vf) -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + _ -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..7356d673d7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -25,7 +25,7 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, - IdeRule, IdeResult, + IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, @@ -254,12 +254,15 @@ data HieDbWriter -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality -type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type RestartQueue = TaskQueue (IO ()) +type LoaderQueue = TaskQueue (IO ()) + data ThreadQueue = ThreadQueue { tIndexQueue :: IndexQueue - , tRestartQueue :: TQueue (IO ()) - , tLoaderQueue :: TQueue (IO ()) + , tRestartQueue :: RestartQueue + , tLoaderQueue :: LoaderQueue } -- Note [Semantic Tokens Cache Location] @@ -330,9 +333,9 @@ 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 :: TQueue (IO ()) + , restartQueue :: RestartQueue -- ^ Queue of restart actions to be run. - , loaderQueue :: TQueue (IO ()) + , loaderQueue :: LoaderQueue -- ^ Queue of loader actions to be run. } @@ -390,11 +393,16 @@ addPersistentRule k getVal = do class Typeable a => IsIdeGlobal a where +-- data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile +getOpenFile :: VirtualFileEntry -> Maybe VirtualFile +getOpenFile (Open vf) = Just vf +getOpenFile _ = Nothing -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras - pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map + let file = getOpenFile =<< Map.lookup (filePathToUri' nf) vfs + pure $! file -- Don't leak a reference to the entire map -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 6d141c7ef3..1c55d21c99 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -7,18 +7,38 @@ Description : This module provides an API for managing worker threads in the IDE see Note [Serializing runs in separate thread] -} module Development.IDE.Core.WorkerThread - (withWorkerQueue, awaitRunInThread) - where + ( LogWorkerThread (..), + withWorkerQueue, + awaitRunInThread, + TaskQueue, + writeTaskQueue, + withWorkerQueueSimple + ) +where -import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled), - withAsync) +import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM import Control.Concurrent.Strict (newBarrier, signalBarrier, waitBarrier) -import Control.Exception.Safe (Exception (fromException), - SomeException, throwIO, try) -import Control.Monad (forever) +import Control.Exception.Safe (SomeException, finally, throwIO, + try) import Control.Monad.Cont (ContT (ContT)) +import qualified Data.Text as T +import Ide.Logger + +data LogWorkerThread + = LogThreadEnding !T.Text + | LogThreadEnded !T.Text + | LogSingleWorkStarting !T.Text + | LogSingleWorkEnded !T.Text + deriving (Show) + +instance Pretty LogWorkerThread where + pretty = \case + LogThreadEnding t -> "Worker thread ending:" <+> pretty t + LogThreadEnded t -> "Worker thread ended:" <+> pretty t + LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t + LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t {- Note [Serializing runs in separate thread] @@ -30,30 +50,71 @@ Like the db writes, session loading in session loader, shake session restarts. Originally we used various ways to implement this, but it was hard to maintain and error prone. Moreover, we can not stop these threads uniformly when we are shutting down the server. -} +data TaskQueue a = TaskQueue (TQueue a) +newTaskQueueIO :: IO (TaskQueue a) +newTaskQueueIO = TaskQueue <$> newTQueueIO +data ExitOrTask t = Exit | Task t -- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker -- thread which polls the queue for requests and runs the given worker -- function on them. -withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) -withWorkerQueue workerAction = ContT $ \mainAction -> do - q <- newTQueueIO - withAsync (writerThread q) $ \_ -> mainAction q - where - writerThread q = - forever $ do - l <- atomically $ readTQueue q - workerAction l +withWorkerQueueSimple :: Recorder (WithPriority LogWorkerThread) -> T.Text -> ContT () IO (TaskQueue (IO ())) +withWorkerQueueSimple log title = withWorkerQueue log title id +withWorkerQueue :: Recorder (WithPriority LogWorkerThread) -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) +withWorkerQueue log title workerAction = ContT $ \mainAction -> do + q <- newTaskQueueIO + -- Use a TMVar as a stop flag to coordinate graceful shutdown. + -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately, + -- ensuring that no new work is started after shutdown is requested. + -- This mechanism is necessary because some downstream code may swallow async exceptions, + -- making 'cancel' unreliable for stopping the thread in all cases. + -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job), + -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant. + b <- newEmptyTMVarIO + withAsync (writerThread q b) $ \_ -> do + mainAction q + -- if we want to debug the exact location the worker swallows an async exception, we can + -- temporarily comment out the `finally` clause. + `finally` atomically (putTMVar b ()) + logWith log Debug (LogThreadEnding title) + logWith log Debug (LogThreadEnded title) + where + -- writerThread :: TaskQueue t -> TMVar () -> (forall a. IO a -> IO a) -> IO () + writerThread q b = + -- See above: check stop flag before dequeuing, exit if set, otherwise run next job. + do + task <- atomically $ do + task <- tryReadTaskQueue q + isEm <- isEmptyTMVar b + case (isEm, task) of + (False, _) -> return Exit -- stop flag set, exit + (_, Just t) -> return $ Task t -- got a task, run it + (_, Nothing) -> retry -- no task, wait + case task of + Exit -> return () + Task t -> do + logWith log Debug $ LogSingleWorkStarting title + workerAction t + logWith log Debug $ LogSingleWorkEnded title + writerThread q b + -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- and then blocks until the result is computed. If the action throws an -- non-async exception, it is rethrown in the calling thread. -awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result -awaitRunInThread q act = do - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - barrier <- newBarrier - atomically $ writeTQueue q $ try act >>= signalBarrier barrier - resultOrException <- waitBarrier barrier - case resultOrException of - Left e -> throwIO (e :: SomeException) - Right r -> return r +awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result +awaitRunInThread (TaskQueue q) act = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + barrier <- newBarrier + atomically $ writeTQueue q (try act >>= signalBarrier barrier) + resultOrException <- waitBarrier barrier + case resultOrException of + Left e -> throwIO (e :: SomeException) + Right r -> return r + +writeTaskQueue :: TaskQueue a -> a -> STM () +writeTaskQueue (TaskQueue q) = writeTQueue q + +tryReadTaskQueue :: TaskQueue a -> STM (Maybe a) +tryReadTaskQueue (TaskQueue q) = tryReadTQueue q diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 918e024a4f..d5d28ffaca 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -12,6 +12,8 @@ module Development.IDE.LSP.LanguageServer , ThreadQueue , runWithWorkerThreads , Setup (..) + , InitializationContext (..) + , untilMVar' ) where import Control.Concurrent.STM @@ -35,12 +37,16 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier, + signalBarrier, + waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service (shutdown) import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Core.WorkerThread (withWorkerQueue) +import Development.IDE.Core.WorkerThread import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..)) @@ -48,19 +54,35 @@ import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) +import System.Timeout (timeout) data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException | LogReactorMessageActionException !SomeException - | LogReactorThreadStopped + | LogReactorThreadStopped Int | LogCancelledRequest !SomeLspId | LogSession Session.Log | LogLspServer LspServerLog - | LogServerShutdownMessage + | LogReactorShutdownRequested Bool + | LogShutDownTimeout Int + | LogServerExitWith (Either () Int) + | LogReactorShutdownConfirmed !T.Text deriving Show instance Pretty Log where pretty = \case + LogReactorShutdownRequested b -> + "Requested reactor shutdown; stop signal posted: " <+> pretty b + LogReactorShutdownConfirmed msg -> + "Reactor shutdown confirmed: " <+> pretty msg + LogServerExitWith (Right 0) -> + "Server exited successfully" + LogServerExitWith (Right code) -> + "Server exited with failure code" <+> pretty code + LogServerExitWith (Left _) -> + "Server forcefully exited due to exception in reactor thread" + LogShutDownTimeout seconds -> + "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds <+> "seconds" LogRegisteringIdeConfig ideConfig -> -- This log is also used to identify if HLS starts successfully in vscode-haskell, -- don't forget to update the corresponding test in vscode-haskell if the text in @@ -74,13 +96,38 @@ instance Pretty Log where vcat [ "ReactorMessageActionException" , pretty $ displayException e ] - LogReactorThreadStopped -> - "Reactor thread stopped" + LogReactorThreadStopped i -> + "Reactor thread stopped" <+> pretty i LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId LogSession msg -> pretty msg LogLspServer msg -> pretty msg - LogServerShutdownMessage -> "Received shutdown message" + +-- | Context for initializing the LSP language server. +-- This record encapsulates all the configuration and callback functions +-- needed to set up and run the language server initialization process. +data InitializationContext config = InitializationContext + { ctxRecorder :: Recorder (WithPriority Log) + -- ^ Logger for recording server events and diagnostics + , ctxDefaultRoot :: FilePath + -- ^ Default root directory for the workspace, see Note [Root Directory] + , ctxGetHieDbLoc :: FilePath -> IO FilePath + -- ^ Function to determine the HIE database location for a given root path + , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState + -- ^ Function to create and initialize the IDE state with the given environment + , ctxUntilReactorStopSignal :: IO () -> IO () + -- ^ Lifetime control: MVar to signal reactor shutdown + , ctxconfirmReactorShutdown :: T.Text -> IO () + -- ^ Callback to log/confirm reactor shutdown with a reason + , ctxForceShutdown :: IO () + -- ^ Action to forcefully exit the server when exception occurs + , ctxClearReqId :: SomeLspId -> IO () + -- ^ Function to clear/cancel a request by its ID + , ctxWaitForCancel :: SomeLspId -> IO () + -- ^ Function to wait for a request cancellation by its ID + , ctxClientMsgChan :: Chan ReactorMessage + -- ^ Channel for communicating with the reactor message loop + } data Setup config m a = MkSetup @@ -136,8 +183,8 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh outH serverDefinition - untilMVar clientMsgVar $ - runServer `finally` sequence_ onExit + untilMVar' clientMsgVar runServer `finally` sequence_ onExit + >>= logWith recorder Info . LogServerExitWith setupLSP :: forall config. @@ -155,8 +202,21 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full - reactorLifetime <- newEmptyMVar - let stopReactorLoop = void $ tryPutMVar reactorLifetime () + reactorStopSignal <- newEmptyMVar + reactorConfirmBarrier <- newBarrier + let + untilReactorStopSignal = untilMVar reactorStopSignal + confirmReactorShutdown reason = do + logWith recorder Debug $ LogReactorShutdownConfirmed reason + signalBarrier reactorConfirmBarrier () + requestReactorShutdown = do + k <- tryPutMVar reactorStopSignal () + logWith recorder Info $ LogReactorShutdownRequested k + let timeOutSeconds = 2 + timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case + Just () -> pure () + -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. + Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -185,49 +245,63 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler exit - , shutdownHandler recorder stopReactorLoop + , shutdownHandler recorder requestReactorShutdown ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let initParams = InitializationContext + { ctxRecorder = recorder + , ctxDefaultRoot = defaultRoot + , ctxGetHieDbLoc = getHieDbLoc + , ctxGetIdeState = getIdeState + , ctxUntilReactorStopSignal = untilReactorStopSignal + , ctxconfirmReactorShutdown = confirmReactorShutdown + , ctxForceShutdown = exit + , ctxClearReqId = clearReqId + , ctxWaitForCancel = waitForCancel + , ctxClientMsgChan = clientMsgChan + } + + let doInitialize = handleInit initParams let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - - let onExit = [stopReactorLoop, exit] + let onExit = [void $ tryPutMVar reactorStopSignal ()] pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit - :: Recorder (WithPriority Log) - -> FilePath -- ^ root directory, see Note [Root Directory] - -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) - -> MVar () - -> IO () - -> (SomeLspId -> IO ()) - -> (SomeLspId -> IO ()) - -> Chan ReactorMessage + :: InitializationContext config -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - -- only shift if lsp root is different from the rootDir - -- see Note [Root Directory] + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + let + recorder = ctxRecorder initParams + defaultRoot = ctxDefaultRoot initParams + untilReactorStopSignal = ctxUntilReactorStopSignal initParams + lifetimeConfirm = ctxconfirmReactorShutdown initParams root <- case LSP.resRootPath env of - Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot - _ -> pure defaultRoot - dbLoc <- getHieDbLoc root + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- ctxGetHieDbLoc initParams root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig - dbMVar <- newEmptyMVar - - - let handleServerException (Left e) = do - logWith recorder Error $ LogReactorThreadException e - exitClientMsg - handleServerException (Right _) = pure () + ideMVar <- newEmptyMVar + + let handleServerExceptionOrShutDown me = do + -- shutdown shake + tryReadMVar ideMVar >>= mapM_ shutdown + case me of + Left e -> do + lifetimeConfirm "due to exception in reactor thread" + logWith recorder Error $ LogReactorThreadException e + ctxForceShutdown initParams + _ -> do + lifetimeConfirm "due to shutdown message" + return () exceptionInHandler e = do logWith recorder Error $ LogReactorMessageActionException e @@ -235,13 +309,13 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () checkCancelled _id act k = let sid = SomeLspId _id - in flip finally (clearReqId sid) $ + in flip finally (ctxClearReqId initParams sid) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel sid) act + cancelOrRes <- race (ctxWaitForCancel initParams sid) act case cancelOrRes of Left () -> do logWith recorder Debug $ LogCancelledRequest sid @@ -250,20 +324,22 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c ) $ \(e :: SomeException) -> do exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do - putMVar dbMVar (WithHieDbShield withHieDb',threadQueue') - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logWith recorder Info LogReactorThreadStopped - - (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb threadQueue + _ <- flip forkFinally handleServerExceptionOrShutDown $ do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> + do + ide <- ctxGetIdeState initParams env root withHieDb' threadQueue' + putMVar ideMVar ide + -- We might be blocked indefinitly at initialization if reactorStop is signaled + -- before we putMVar. + untilReactorStopSignal $ forever $ do + msg <- readChan $ ctxClientMsgChan initParams + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + + ide <- readMVar ideMVar registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) @@ -273,9 +349,9 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c -- see Note [Serializing runs in separate thread] runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () runWithWorkerThreads recorder dbLoc f = evalContT $ do - sessionRestartTQueue <- withWorkerQueue id - sessionLoaderTQueue <- withWorkerQueue id (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue" + sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue" liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. @@ -286,6 +362,9 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () untilMVar mvar io = race_ (readMVar mvar) io +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b) +untilMVar' mvar io = race (readMVar mvar) io + cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> liftIO $ cancelRequest (SomeLspId (toLspId _id)) @@ -294,18 +373,11 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T toLspId (InR y) = IdString y shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) -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 +shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do + -- stop the reactor to free up the hiedb connection and shut down shake + liftIO requestReactorShutdown resp $ Right Null -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit - modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index ad4a36327a..fec6aaf725 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,8 +77,9 @@ import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, - IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), + IdeOptions (..), IdeTesting (IdeTesting), + ProgressReportingStyle (TestReporting), clientSupportsProgress, defaultIdeOptions, optModifyDynFlags, @@ -276,7 +277,10 @@ testing recorder projectRoot plugins = let defOptions = argsIdeOptions config sessionLoader in - defOptions{ optTesting = IdeTesting True } + defOptions{ + optTesting = IdeTesting True + , optProgressStyle = TestReporting + } lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in arguments diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 0a5cecaca8..6c59a5ffe5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -857,7 +857,7 @@ mergeListsBy cmp all_lists = merge_lists all_lists -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo getCompletionPrefixFromRope pos@(Position l c) ropetext = diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 8d4d91e166..124e7a9469 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -107,6 +107,7 @@ newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool data ProgressReportingStyle = Percentage -- ^ Report using the LSP @_percentage@ field | Explicit -- ^ Report using explicit 123/456 text + | TestReporting -- ^ Special mode for testing, reports only start/stop | NoProgress -- ^ Do not report any percentage deriving Eq diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 6d47d9b511..30ef078ffe 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -81,8 +81,10 @@ actionFork act k = do isAsyncException :: SomeException -> Bool isAsyncException e + | Just (_ :: SomeAsyncException) <- fromException e = True | Just (_ :: AsyncCancelled) <- fromException e = True | Just (_ :: AsyncException) <- fromException e = True + | Just (_ :: AsyncParentKill) <- fromException e = True | Just (_ :: ExitCode) <- fromException e = True | otherwise = False diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 359e5ceb6a..8d85854c6a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -8,7 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where +module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, AsyncParentKill(..)) where import Prelude hiding (unzip) @@ -17,7 +17,7 @@ import Control.Concurrent.Extra import Control.Concurrent.STM.Stats (STM, atomically, atomicallyNamed, modifyTVar', newTVarIO, - readTVarIO) + readTVarIO, retry) import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -25,7 +25,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic -import Data.Either import Data.Foldable (for_, traverse_) import Data.IORef.Extra import Data.Maybe @@ -39,8 +38,9 @@ import Development.IDE.Graph.Internal.Types import qualified Focus import qualified ListT import qualified StmContainers.Map as SMap -import System.IO.Unsafe import System.Time.Extra (duration, sleep) +import UnliftIO (MonadUnliftIO (withRunInIO)) +import qualified UnliftIO.Exception as UE #if MIN_VERSION_base(4,19,0) import Data.Functor (unzip) @@ -78,7 +78,7 @@ incDatabase db Nothing = do updateDirty :: Monad m => Focus.Focus KeyDetails m () updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> let status' - | Running _ _ _ x <- status = Dirty x + | Running _ x <- status = Dirty x | Clean x <- status = Dirty (Just x) | otherwise = status in KeyDetails status' rdeps @@ -88,58 +88,56 @@ build => Database -> Stack -> f key -> IO (f Key, f value) -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do - built <- runAIO $ do - built <- builder db stack (fmap newKey keys) - case built of - Left clean -> return clean - Right dirty -> liftIO dirty + step <- readTVarIO $ databaseStep db + !built <- runAIO step $ builder db stack (fmap newKey keys) let (ids, vs) = unzip built pure (ids, fmap (asV . resultValue) vs) where asV :: Value -> value asV (Value x) = unwrapDynamic x +data BuildArity = BuildUnary | BuildNary -- | Build a list of keys and return their results. -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. -builder - :: Traversable f => Database -> Stack -> f Key -> AIO (Either (f (Key, Result)) (IO (f (Key, Result)))) +builder :: (Traversable f) => Database -> Stack -> f Key -> AIO (f (Key, Result)) -- builder _ st kk | traceShow ("builder", st,kk) False = undefined -builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do - -- Things that I need to force before my results are ready - toForce <- liftIO $ newTVarIO [] - current <- liftIO $ readTVarIO databaseStep - results <- liftIO $ for keys $ \id -> - -- Updating the status of all the dependencies atomically is not necessary. - -- Therefore, run one transaction per dep. to avoid contention - atomicallyNamed "builder" $ do - -- Spawn the id if needed - status <- SMap.lookup id databaseValues - val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of - Clean r -> pure r - Running _ force val _ - | memberStack id stack -> throw $ StackException stack - | otherwise -> do - modifyTVar' toForce (Wait force :) - pure val - Dirty s -> do - let act = run (refresh db stack id s) - (force, val) = splitIO (join act) - SMap.focus (updateStatus $ Running current force val s) id databaseValues - modifyTVar' toForce (Spawn force:) - pure val - - pure (id, val) - - toForceList <- liftIO $ readTVarIO toForce - let waitAll = run $ waitConcurrently_ toForceList - case toForceList of - [] -> return $ Left results - _ -> return $ Right $ do - waitAll - pure results - - +builder db stack keys = do + let ba = if length keys == 1 then BuildUnary else BuildNary + keyWaits <- for keys $ \k -> builderOne ba db stack k + !res <- for keyWaits $ \(k, waitR) -> do + !v<- liftIO waitR + return (k, v) + return res + +builderOne :: BuildArity -> Database -> Stack -> Key -> AIO (Key, IO Result) +builderOne ba db@Database {..} stack id = UE.mask $ \restore -> do + current <- liftIO $ readTVarIO databaseStep + (k, registerWaitResult) <- liftIO $ atomicallyNamed "builder" $ do + -- Spawn the id if needed + status <- SMap.lookup id databaseValues + val <- + let refreshRsult s = do + let act = + case ba of + BuildNary -> restore $ asyncWithCleanUp $ + refresh db stack id s + `UE.onException` (UE.uninterruptibleMask_ $ liftIO (atomicallyNamed "builder - onException" (SMap.focus updateDirty id databaseValues))) + BuildUnary -> fmap return $ refresh db stack id s + -- Mark the key as running + SMap.focus (updateStatus $ Running current s) id databaseValues + return act + in case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Dirty mbr -> refreshRsult mbr + Running step _mbr + | step /= current -> error $ "Inconsistent database state: key " ++ show id ++ " is marked Running at step " ++ show step ++ " but current step is " ++ show current + | memberStack id stack -> throw $ StackException stack + | otherwise -> retry + Clean r -> pure . pure . pure $ r + -- force here might contains async exceptions from previous runs + pure (id, val) + waitR <- registerWaitResult + return (k, waitR) -- | isDirty -- only dirty when it's build time is older than the changed time of one of its dependencies isDirty :: Foldable t => Result -> t (a, Result) -> Bool @@ -155,41 +153,37 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result refreshDeps visited db stack key result = \case -- no more deps to refresh - [] -> liftIO $ compute db stack key RunDependenciesSame (Just result) + [] -> 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 + if isDirty result res -- restart the computation if any of the deps are dirty - then liftIO $ compute db stack key RunDependenciesChanged (Just result) + then compute' db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps else refreshDeps newVisited db stack key result deps - Right iores -> do - res <- liftIO iores - if isDirty result res - 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 :: Database -> Stack -> Key -> Maybe Result -> IO Result -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined +refresh :: Database -> Stack -> Key -> Maybe Result -> AIO Result refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (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 + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) + (Right stack, _) -> compute' db stack key RunDependenciesChanged result +compute' :: Database -> Stack -> Key -> RunMode -> Maybe Result -> AIO Result +compute' db stack key mode result = liftIO $ compute db stack key mode result -- | Compute a key. compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result -- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode - deps <- newIORef UnknownDeps + deps <- liftIO $ newIORef UnknownDeps (execution, RunResult{..}) <- - duration $ runReaderT (fromAction act) $ SAction db deps stack - curStep <- readTVarIO databaseStep - deps <- readIORef deps + liftIO $ duration $ runReaderT (fromAction act) $ SAction db deps stack + curStep <- liftIO $ readTVarIO databaseStep + deps <- liftIO $ readIORef deps let lastChanged = maybe curStep resultChanged result let lastBuild = maybe curStep resultBuilt result -- changed time is always older than or equal to build time @@ -212,12 +206,12 @@ compute db@Database{..} stack key mode result = do -- If an async exception strikes before the deps have been recorded, -- we won't be able to accurately propagate dirtiness for this key -- on the next build. - void $ + liftIO $ void $ updateReverseDeps key db (getResultDepsDefault mempty previousDeps) deps _ -> pure () - atomicallyNamed "compute and run hook" $ do + liftIO $ atomicallyNamed "compute and run hook" $ do runHook SMap.focus (updateStatus $ Clean res) key databaseValues pure res @@ -247,18 +241,6 @@ getKeysAndVisitAge db = do getAge Result{resultVisited = Step s} = curr - s return keysWithVisitAge -------------------------------------------------------------------------------- --- Lazy IO trick - -data Box a = Box {fromBox :: a} - --- | Split an IO computation into an unsafe lazy value and a forcing computation -splitIO :: IO a -> (IO (), a) -splitIO act = do - let act2 = Box <$> act - let res = unsafePerformIO act2 - (void $ evaluate res, fromBox res) - --------------------------------------------------------------------------------- -- Reverse dependencies -- | Update the reverse dependencies of an Id @@ -304,11 +286,23 @@ transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a } deriving newtype (Applicative, Functor, Monad, MonadIO) +data AsyncParentKill = AsyncParentKill ThreadId Step + deriving (Show, Eq) + +instance Exception AsyncParentKill where + toException = asyncExceptionToException + fromException = asyncExceptionFromException + -- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises -runAIO :: AIO a -> IO a -runAIO (AIO act) = do - asyncs <- newIORef [] - runReaderT act asyncs `onException` cleanupAsync asyncs +runAIO :: Step -> AIO a -> IO a +runAIO s (AIO act) = do + asyncsRef <- newIORef [] + -- Log the exact exception (including async exceptions) before cleanup, + -- then rethrow to preserve previous semantics. + runReaderT act asyncsRef `onException` do + asyncs <- atomicModifyIORef' asyncsRef ([],) + tid <- myThreadId + cleanupAsync asyncs tid s -- | Like 'async' but with built-in cancellation. -- Returns an IO action to wait on the result. @@ -319,7 +313,7 @@ asyncWithCleanUp act = do -- mask to make sure we keep track of the spawned async liftIO $ uninterruptibleMask $ \restore -> do a <- async $ restore io - atomicModifyIORef'_ st (void a :) + atomicModifyIORef'_ st (void a:) return $ wait a unliftAIO :: AIO a -> AIO (IO a) @@ -327,19 +321,17 @@ unliftAIO act = do st <- AIO ask return $ runReaderT (unAIO act) st -newtype RunInIO = RunInIO (forall a. AIO a -> IO a) - -withRunInIO :: (RunInIO -> AIO b) -> AIO b -withRunInIO k = do - st <- AIO ask - k $ RunInIO (\aio -> runReaderT (unAIO aio) st) +instance MonadUnliftIO AIO where + withRunInIO k = do + st <- AIO ask + liftIO $ k (\aio -> runReaderT (unAIO aio) st) -cleanupAsync :: IORef [Async a] -> IO () +cleanupAsync :: [Async a] -> ThreadId -> Step -> IO () -- mask to make sure we interrupt all the asyncs -cleanupAsync ref = uninterruptibleMask $ \unmask -> do - asyncs <- atomicModifyIORef' ref ([],) +cleanupAsync asyncs tid step = uninterruptibleMask $ \unmask -> do -- interrupt all the asyncs without waiting - mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs + -- mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs + mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) asyncs -- Wait until all the asyncs are done -- But if it takes more than 10 seconds, log to stderr unless (null asyncs) $ do @@ -348,32 +340,3 @@ cleanupAsync ref = uninterruptibleMask $ \unmask -> do traceM "cleanupAsync: waiting for asyncs to finish" withAsync warnIfTakingTooLong $ \_ -> mapM_ waitCatch asyncs - -data Wait - = Wait {justWait :: !(IO ())} - | Spawn {justWait :: !(IO ())} - -fmapWait :: (IO () -> IO ()) -> Wait -> Wait -fmapWait f (Wait io) = Wait (f io) -fmapWait f (Spawn io) = Spawn (f io) - -waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ())) -waitOrSpawn (Wait io) = pure $ Left io -waitOrSpawn (Spawn io) = Right <$> async io - -waitConcurrently_ :: [Wait] -> AIO () -waitConcurrently_ [] = pure () -waitConcurrently_ [one] = liftIO $ justWait one -waitConcurrently_ many = do - ref <- AIO ask - -- spawn the async computations. - -- mask to make sure we keep track of all the asyncs. - (asyncs, syncs) <- liftIO $ uninterruptibleMask $ \unmask -> do - waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many - let (syncs, asyncs) = partitionEithers waits - liftIO $ atomicModifyIORef'_ ref (asyncs ++) - return (asyncs, syncs) - -- work on the sync computations - liftIO $ sequence_ syncs - -- wait for the async computations before returning - liftIO $ traverse_ wait asyncs diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 34bed42391..0b21494355 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -6,7 +6,6 @@ module Development.IDE.Graph.Internal.Types where import Control.Concurrent.STM (STM) -import Control.Monad ((>=>)) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -80,8 +79,8 @@ getDatabase :: Action Database getDatabase = Action $ asks actionDatabase -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running. -waitForDatabaseRunningKeysAction :: Action () -waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys +-- waitForDatabaseRunningKeysAction :: Action () +-- waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys --------------------------------------------------------------------- -- DATABASE @@ -89,7 +88,7 @@ waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunni data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int - deriving newtype (Eq,Ord,Hashable,Show) + deriving newtype (Eq,Ord,Hashable,Show,Num,Enum,Real,Integral) --------------------------------------------------------------------- -- Keys @@ -113,10 +112,12 @@ data Database = Database { databaseRules :: TheRules, databaseStep :: !(TVar Step), databaseValues :: !(Map Key KeyDetails) + -- ^ The set of dirty keys, which are the keys that have been marked as dirty + -- by the client, it would be removed once the target key is marked as clean. } -waitForDatabaseRunningKeys :: Database -> IO () -waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) +-- waitForDatabaseRunningKeys :: Database -> IO () +-- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd) getDatabaseValues :: Database -> IO [(Key, Status)] getDatabaseValues = atomically @@ -129,24 +130,20 @@ data Status = Clean !Result | Dirty (Maybe Result) | Running { - runningStep :: !Step, - runningWait :: !(IO ()), - runningResult :: Result, -- LAZY - runningPrev :: !(Maybe Result) + runningStep :: !Step, + -- runningWait :: !(IO ()), + -- runningResult :: Result, -- LAZY + runningPrev :: !(Maybe Result) } viewDirty :: Step -> Status -> Status -viewDirty currentStep (Running s _ _ re) | currentStep /= s = Dirty re +viewDirty currentStep (Running s re) | currentStep /= s = Dirty re viewDirty _ other = other getResult :: Status -> Maybe Result -getResult (Clean re) = Just re -getResult (Dirty m_re) = m_re -getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result - -waitRunning :: Status -> IO () -waitRunning Running{..} = runningWait -waitRunning _ = return () +getResult (Clean re) = Just re +getResult (Dirty m_re) = m_re +getResult (Running _ m_re) = m_re -- watch out: this returns the previous result data Result = Result { resultValue :: !Value, diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0ab203fe36..9e913662c8 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -29,6 +29,7 @@ module Test.Hls goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, goldenWithTestConfig, + hlsHelperTestRecorder, def, -- * Running HLS for integration tests runSessionWithServer, @@ -153,6 +154,17 @@ data Log = LogIDEMain IDEMain.Log | LogTestHarness LogTestHarness +data TestRunLog + = TestRunFinished + | TestServerExitTimeoutSeconds Int + | TestServerCancelFinished String + +instance Pretty TestRunLog where + pretty :: TestRunLog -> Logger.Doc ann + pretty TestRunFinished = "Test run finished" + pretty (TestServerExitTimeoutSeconds secs) = "Server does not exit in " <> pretty secs <> "s, canceling the async task..." + pretty (TestServerCancelFinished took) = "Finishing canceling (took " <> pretty took <> "s)" + instance Pretty Log where pretty = \case LogIDEMain log -> pretty log @@ -746,6 +758,7 @@ wrapClientLogger logger = do let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder' return (lspLogRecorder <> logger, cb1) + -- | Host a server, and run a test session on it. -- For setting custom timeout, set the environment variable 'LSP_TIMEOUT' -- * LSP_TIMEOUT=10 cabal test @@ -760,6 +773,7 @@ runSessionWithTestConfig TestConfig{..} session = (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + testRecorder <- hlsHelperTestRecorder -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") @@ -780,9 +794,10 @@ runSessionWithTestConfig TestConfig{..} session = timeout 3 (wait server) >>= \case Just () -> pure () Nothing -> do - putStrLn "Server does not exit in 3s, canceling the async task..." + logWith testRecorder Info (TestServerExitTimeoutSeconds 3) (t, _) <- duration $ cancel server - putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" + logWith testRecorder Info (TestServerCancelFinished (showDuration t)) + logWith testRecorder Info TestRunFinished pure result where diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 210e9f3910..1585965132 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -66,7 +66,8 @@ import System.Environment (setEnv, import Development.IDE.GHC.Compat (DynFlags, extensionFlags, ms_hspp_opts, - topDir) + topDir, + uninterruptibleMaskM_) import qualified Development.IDE.GHC.Compat.Util as EnumSet #if MIN_GHC_API_VERSION(9,4,0) @@ -205,7 +206,7 @@ rules recorder plugin = do defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin - liftIO $ argsSettings flags + liftIO $ uninterruptibleMask_ $ argsSettings flags action $ do files <- Map.keys <$> getFilesOfInterestUntracked diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index a0d1648fb3..7daae0df51 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -90,7 +90,7 @@ docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Sessio docLspSemanticTokensString doc = do res <- Test.getSemanticTokens doc textContent <- documentContents doc - let vfs = VirtualFile 0 0 (Rope.fromText textContent) + let vfs = VirtualFile 0 0 (Rope.fromText textContent) (Just LanguageKind_Haskell) case res ^? Language.LSP.Protocol.Types._L of Just tokens -> do either (error . show) pure $ recoverLspSemanticTokens vfs tokens diff --git a/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs index 4ac665e7d1..f6518552ae 100644 --- a/plugins/hls-signature-help-plugin/test/Main.hs +++ b/plugins/hls-signature-help-plugin/test/Main.hs @@ -11,7 +11,8 @@ import qualified Data.Text as T import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (PosPrefixInfo)) import Ide.Plugin.SignatureHelp (descriptor) import qualified Language.LSP.Protocol.Lens as L -import Test.Hls +import Test.Hls hiding + (getSignatureHelp) import Test.Hls.FileSystem (VirtualFileTree, directCradle, file, mkVirtualFileTree, diff --git a/scripts/eventlog-dump.fish b/scripts/eventlog-dump.fish new file mode 100755 index 0000000000..5122b48590 --- /dev/null +++ b/scripts/eventlog-dump.fish @@ -0,0 +1,122 @@ +#!/usr/bin/env fish + +# Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI. +# Usage: +# scripts/eventlog-dump.fish [output.txt] [starts_with_prefix] [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 .events.txt in the current directory. + +function usage + echo "Usage: (basename (status filename)) [output.txt] [starts_with_prefix] [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 prefix filter: only keep lines that start with this string +set filter_prefix "" +if test (count $argv) -ge 3 + set filter_prefix $argv[3] +end + +# Optional contains filter: only keep lines that contain this substring (applied after prefix filter if both provided) +set filter_contains "" +if test (count $argv) -ge 4 + set filter_contains $argv[4] +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..." +set -l stream_cmd "$ghc_events_bin show $evlog" + +if test -n "$filter_prefix" -o -n "$filter_contains" + # Stream through filters + eval $stream_cmd | while read -l line + set -l keep 1 + if test -n "$filter_prefix" + if not string match -q -- "$filter_prefix*" -- $line + set keep 0 + end + end + if test $keep -eq 1 -a -n "$filter_contains" + if not string match -q -- "*$filter_contains*" -- $line + set keep 0 + end + end + if test $keep -eq 1 + echo $line + end + end > $out +else + eval $stream_cmd > $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)." diff --git a/scripts/flaky-test-loop.sh b/scripts/flaky-test-loop.sh new file mode 100755 index 0000000000..ec3f1010eb --- /dev/null +++ b/scripts/flaky-test-loop.sh @@ -0,0 +1,232 @@ +#!/usr/bin/env bash +# Loop running HLS tasty tests until a Broken pipe or test failure is observed. +# Originally ran only the "open close" test; now supports multiple patterns. +# Ensures successful build before running any tests. +# Logs each run to test-logs/-loop-.log, rotating every 100 files per pattern. +# +# Environment you can tweak: +# MAX_ITER : maximum iterations before giving up (default: 1000) +# SLEEP_SECS : seconds to sleep between iterations (default: 0) +# SHOW_EVERY : print progress/iteration header every N iterations (default: 100, 1 = every run, <=0 = disabled) +# LOG_STDERR : set to 1 to enable verbose stderr logging (HLS_TEST_LOG_STDERR & HLS_TEST_HARNESS_STDERR) (default: 1) +# NO_BUILD_ONCE : set to non-empty to skip the initial cabal build step +# RUN_MODE : choose 'build' (build once and exit), 'run' (skip upfront build and just run), or 'both' (default) +# +# Test selection: +# TEST_PATTERNS : comma-separated list of entries to run each iteration. +# Each entry can be either a plain tasty pattern, or 'BIN::PATTERN' to select a test binary. +# Examples: +# TEST_PATTERNS='open close' +# TEST_PATTERNS='ghcide-tests::open close,func-test::sends indefinite progress notifications' +# If set and non-empty, this takes precedence over PATTERN_FILE. +# If unset, defaults to 'ghcide-tests::open close' to match prior behavior. +# PATTERN_FILE : path to a file with one entry per line. +# Lines start with optional 'BIN::', then the tasty pattern. '#' comments and blank lines ignored. +# Examples: +# ghcide-tests::open close +# func-test::sends indefinite progress notifications +# Used only if TEST_PATTERNS is empty/unset; otherwise ignored. +# +# Exit codes: +# 1 on success (broken pipe or test failure reproduced) +# 0 on reaching MAX_ITER without reproduction +# 2 on other setup error + +set -euo pipefail + +MAX_ITER="${MAX_ITER:-}" +SLEEP_SECS="${SLEEP_SECS:-0}" +SHOW_EVERY="${SHOW_EVERY:-1}" +LOG_STDERR="${LOG_STDERR:-1}" +RUN_MODE="${RUN_MODE:-both}" # build | run | both + +# Allow providing a positional max iteration: ./open-close-loop.sh 50 +if [[ $# -ge 1 && -z "${MAX_ITER}" ]]; then + MAX_ITER="$1" +fi + +# fallback to default if not set +if [[ -z "${MAX_ITER}" ]]; then + MAX_ITER=1000 +fi + +mkdir -p test-logs + +iter=0 +start_ts=$(date -Iseconds) +echo "[loop] Starting at ${start_ts}" >&2 + +# Patterns to detect issues +# - Use case-insensitive extended regex for failures/timeouts in logs +# - Broken pipe: case-insensitive fixed-string search +BROKEN_PIPE_RE='Broken pipe' +TEST_FAILED_RE='tests failed|timeout' +DEBUG_DETECT="${DEBUG_DETECT:-0}" + +# Resolve what to run each iteration as pairs of BIN and PATTERN +items=() # each item is 'BIN::PATTERN' +if [[ -n "${TEST_PATTERNS:-}" ]]; then + IFS=',' read -r -a raw_items <<< "${TEST_PATTERNS}" + for it in "${raw_items[@]}"; do + # trim + it="${it#${it%%[![:space:]]*}}"; it="${it%${it##*[![:space:]]}}" + [[ -z "$it" ]] && continue + if [[ "$it" == *"::"* ]]; then + items+=("$it") + else + items+=("ghcide-tests::${it}") + fi + done +elif [[ -n "${PATTERN_FILE:-}" && -r "${PATTERN_FILE}" ]]; then + while IFS= read -r line; do + # trim whitespace, skip comments and blank lines + trimmed="${line#${line%%[![:space:]]*}}"; trimmed="${trimmed%${trimmed##*[![:space:]]}}" + [[ -z "${trimmed}" || "${trimmed}" =~ ^[[:space:]]*# ]] && continue + if [[ "${trimmed}" == *"::"* ]]; then + items+=("${trimmed}") + else + items+=("ghcide-tests::${trimmed}") + fi + done < "${PATTERN_FILE}" +else + # default to the original single test + items+=("ghcide-tests::open close") +fi + +if [[ ${#items[@]} -eq 0 ]]; then + echo "[loop][error] No test entries provided (via PATTERN_FILE or TEST_PATTERNS)." >&2 + exit 2 +fi + +# Helper to build required test binaries once +build_required_bins_once() { + # collect unique BIN names from global 'items' + declare -a bins_to_build=() + local it bin seen b + for it in "${items[@]}"; do + bin="${it%%::*}"; seen=0 + if (( ${#bins_to_build[@]} > 0 )); then + for b in "${bins_to_build[@]}"; do [[ "$b" == "$bin" ]] && seen=1 && break; done + fi + [[ $seen -eq 0 ]] && bins_to_build+=("$bin") + done + if (( ${#bins_to_build[@]} > 0 )); then + echo "[loop] Building test targets once upfront: ${bins_to_build[*]}" >&2 + if ! cabal build "${bins_to_build[@]}" >&2; then + echo "[loop][error] Build failed." >&2 + return 2 + fi + echo "[loop] Build succeeded." >&2 + fi + return 0 +} + +# Honor RUN_MODE before any build/run +case "${RUN_MODE}" in + build) + if ! build_required_bins_once; then exit 2; fi + echo "[loop] RUN_MODE=build completed. Exiting without running tests." >&2 + exit 0 + ;; + run) + echo "[loop] RUN_MODE=run: skipping upfront build, proceeding to run loop." >&2 + ;; + both) + : # default behavior below + ;; + *) + echo "[loop][error] Invalid RUN_MODE='${RUN_MODE}'. Use one of: build | run | both." >&2 + exit 2 + ;; +esac + +# Build required test binaries once upfront (unless NO_BUILD_ONCE is set or RUN_MODE=run) +if [[ -z "${NO_BUILD_ONCE:-}" && "${RUN_MODE}" != "run" ]]; then + if ! build_required_bins_once; then + echo "[loop][error] Cannot proceed with tests due to build failure." >&2 + exit 2 + fi + echo "[loop] Proceeding with tests." >&2 +fi + +# Resolve binary path by name (cache results) +BIN_NAMES=() +BIN_PATHS=() +get_bin_path() { + local name="$1" + local i + for ((i=0; i<${#BIN_NAMES[@]}; i++)); do + if [[ "${BIN_NAMES[i]}" == "$name" ]]; then + echo "${BIN_PATHS[i]}"; return + fi + done + local path="" + path=$(find dist-newstyle -type f -name "$name" -perm -111 2>/dev/null | head -n1 || true) + BIN_NAMES+=("$name"); BIN_PATHS+=("$path") + echo "$path" +} + +while true; do + iter=$((iter+1)) + ts=$(date -Iseconds) + file_num=$((iter % 2)) + # if [[ ${file_num} -eq 0 ]]; then file_num=100; fi + + # Run each selected item (BIN::PATTERN) in this iteration + for item in "${items[@]}"; do + bin_name="${item%%::*}" + pattern="${item#*::}" + # sanitize pattern for a log slug + slug=$(printf '%s' "${bin_name}-${pattern}" | tr -cs 'A-Za-z0-9._-' '-' | sed -E 's/^-+|-+$//g') + [[ -z "${slug}" ]] && slug="pattern" + log="test-logs/${slug}-loop-${file_num}.log" + + # Show iteration start at first run and then every SHOW_EVERY runs (if > 0) + if [[ ${iter} -eq 1 || ( ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ) ]]; then + echo "[loop] Iteration ${iter} (${ts}) pattern='${pattern}' -> ${log}" | tee -a "${log}" >&2 + fi + + # We don't fail the loop on non-zero exit (capture output then decide). + set +e + # HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 \ + HLS_TEST_LOG_STDERR="${LOG_STDERR}" \ + HLS_TEST_HARNESS_STDERR="${LOG_STDERR}" \ + TASTY_NUM_THREADS=1 \ + TASTY_PATTERN="${pattern}" \ + "$(get_bin_path "${bin_name}")" +RTS -l -olhlint.eventlog -RTS >"${log}" 2>&1 + set -e + + if grep -aFiq -- "${BROKEN_PIPE_RE}" "${log}"; then + echo "[loop] Broken pipe reproduced in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + elif grep -aEq -- "${TEST_FAILED_RE}" "${log}"; then + echo "[loop] Test failure detected in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + else + if [[ ${DEBUG_DETECT} -eq 1 ]]; then + echo "[loop][debug] No match for '${BROKEN_PIPE_RE}' or '${TEST_FAILED_RE}' in iteration ${iter} (pattern='${pattern}')." | tee -a "${log}" >&2 + fi + fi + done + + if [[ -n "${MAX_ITER}" && ${iter} -ge ${MAX_ITER} ]]; then + echo "[loop] Reached MAX_ITER=${MAX_ITER} without reproducing issues." >&2 + exit 0 + fi + + # Show progress at the configured cadence + if [[ ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ]]; then + echo "[loop] Progress: Completed ${iter} iterations without detecting issues." >&2 + fi + + if [[ ${SLEEP_SECS} -gt 0 ]]; then + echo "[loop] Sleeping ${SLEEP_SECS}s" >&2 + sleep "${SLEEP_SECS}" + fi +done diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt new file mode 100644 index 0000000000..4a4b4681d1 --- /dev/null +++ b/scripts/flaky-test-patterns.txt @@ -0,0 +1,20 @@ +# One tasty pattern per line. Lines starting with # are comments. +# Blank lines are ignored. + +open close +# non local variable +# Notification Handlers +# bidirectional module dependency with hs-boot + +# InternalError over InvalidParams +# ghcide restarts shake session on config changes: +# addDependentFile +# Another interesting one you can try: +# func-test::sends indefinite progress notifications +# hls-pragmas-plugin-tests::/inline: RULES/ + +# hls-graph cancel leaks asynchronous exception to the next session +# hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics +# hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps +# hls-class-plugin-tests::Creates a placeholder for fmap +# hls-rename-plugin-tests::Rename