Skip to content

concurrency bug fixes/ improvements #4663

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

concurrency bug fixes/ improvements #4663

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
43e8cb0
[fix] don't bake ide state mvar into setup and getIdeState
MangoIV Jul 16, 2025
6696657
[fix] don't throw hard errors when no shutdown message is handled
MangoIV Jul 16, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion exe/Wrapper.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}

Check warning on line 1 in exe/Wrapper.hs

View workflow job for this annotation

GitHub Actions / Hlint check run 

Warning in module Main: Use module export list ▫︎ Found: "module Main where" ▫︎ Perhaps: "module Main (\n module Main\n ) where" ▫︎ Note: an explicit list is usually better
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
Expand Down Expand Up @@ -300,7 +300,7 @@
[ exitHandler exit ]

let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
pure (doInitialize, asyncHandlers, interpretHandler)
pure (doInitialize, asyncHandlers, interpretHandler, [exit])

runLanguageServer (cmapWithPrio pretty recorder)
(Main.argsLspOptions defaultArguments)
Expand Down
27 changes: 17 additions & 10 deletions ghcide/src/Development/IDE/LSP/LanguageServer.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ import UnliftIO.Directory
import UnliftIO.Exception

import qualified Colog.Core as Colog
import Control.Exception (BlockedIndefinitelyOnMVar (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans.Cont (evalContT)
import Development.IDE.Core.IdeConfiguration
Expand Down Expand Up @@ -94,14 +95,14 @@ runLanguageServer
-> (MVar ()
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)),
LSP.Handlers (m config),
(LanguageContextEnv config, a) -> m config <~> IO))
(LanguageContextEnv config, a) -> m config <~> IO, [IO ()]))
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change
(LanguageContextEnv config, a) -> m config <~> IO, [IO ()]))
(LanguageContextEnv config, a) -> m config <~> IO,
[IO ()]))

And since you are already here, you could document the type :)

-> IO ()
runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do
-- This MVar becomes full when the server thread exits or we receive exit message from client.
-- LSP server will be canceled when it's full.
clientMsgVar <- newEmptyMVar

(doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar
(doInitialize, staticHandlers, interpretHandler, onExit) <- setup clientMsgVar

let serverDefinition = LSP.ServerDefinition
{ LSP.parseConfig = parseConfig
Expand All @@ -118,13 +119,14 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh
let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)
lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder)

void $ untilMVar clientMsgVar $
void $ LSP.runServerWithHandles
untilMVar clientMsgVar $
LSP.runServerWithHandles
lspCologAction
lspCologAction
inH
outH
serverDefinition
`finally` sequence_ onExit
Comment on lines +122 to +129
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Comment with the explanation what onExit does, please :)

Perhaps introducing an intermediate variable for the runServerWithHabdles action?


setupLSP ::
forall config err.
Expand All @@ -136,7 +138,8 @@ setupLSP ::
-> MVar ()
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
LSP.Handlers (ServerM config),
(LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
(LanguageContextEnv config, IdeState) -> ServerM config <~> IO,
[IO ()])
setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do
-- Send everything over a channel, since you need to wait until after initialise before
-- LspFuncs is available
Expand Down Expand Up @@ -184,7 +187,9 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar

let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO

pure (doInitialize, asyncHandlers, interpretHandler)
let finalHandlers = [stopReactorLoop, exit]

pure (doInitialize, asyncHandlers, interpretHandler, finalHandlers)


handleInit
Expand Down Expand Up @@ -265,11 +270,13 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do
(WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc
liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)

-- | Runs the action until it ends or until the given MVar is put.
-- | Runs the action until it ends or until the given MVar is put or the thread to fill the mvar is dropped, in which case the MVar will never be filled.
-- This happens when the thread that handles the shutdown notification dies. Ideally, this should not rely on the RTS detecting the blocked MVar
-- and instead *also* run the shutdown inf a finally block enclosing the handlers. In which case the BlockedIndefinitelyOnMVar Exception also wouldn't
-- be thrown.
Comment on lines +273 to +276
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Outdated comment? Or still kind of accurate?

-- Rethrows any exceptions.
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar mvar io = void $
waitAnyCancel =<< traverse async [ io , readMVar mvar ]
untilMVar :: MonadUnliftIO m => MVar () -> m a -> m ()
untilMVar mvar io = race_ (readMVar mvar) io

cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)
cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->
Expand Down
15 changes: 8 additions & 7 deletions ghcide/src/Development/IDE/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ module Development.IDE.Main
) where

import Control.Concurrent.Extra (withNumCapabilities)
import Control.Concurrent.MVar (newEmptyMVar,
import Control.Concurrent.MVar (MVar, newEmptyMVar,
putMVar, tryReadMVar)
import Control.Concurrent.STM.Stats (dumpSTMStats)
import Control.Monad.Extra (concatMapM, unless,
Expand Down Expand Up @@ -318,9 +318,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
ioT <- offsetTime
logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)

ideStateVar <- newEmptyMVar
let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState
getIdeState env rootPath withHieDb threadQueue = do
let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState
getIdeState ideStateVar env rootPath withHieDb threadQueue = do
t <- ioT
logWith recorder Info $ LogLspStartDuration t
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue)
Expand Down Expand Up @@ -353,9 +352,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
putMVar ideStateVar ide
pure ide

let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState
let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar)
-- See Note [Client configuration in Rules]
onConfigChange cfg = do
onConfigChange ideStateVar cfg = do
-- TODO: this is nuts, we're converting back to JSON just to get a fingerprint
let cfgObj = J.toJSON cfg
mide <- liftIO $ tryReadMVar ideStateVar
Expand All @@ -368,7 +367,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
modifyClientSettings ide (const $ Just cfgObj)
return [toNoFileKey Rules.GetClientSettings]

runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
do
ideStateVar <- newEmptyMVar
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar)
dumpSTMStats
Check argFiles -> do
let dir = argsProjectRoot
Expand Down
Loading