Skip to content

Commit cfeced8

Browse files
MangoIVmergify[bot]
MangoIV
and
mergify[bot]
authored
concurrency bug fixes/ improvements (#4663)
* [fix] don't bake ide state mvar into setup and getIdeState This is the right thing to do because othewise it is not possible to create new ideStates in a single instance of the executable. This will be useful if the hls executable is supposed to talk to multiple clients and lives beyond a single client disconnecting. * [fix] don't throw hard errors when no shutdown message is handled Previously, when there was no shutdown message by a client and the client disconnected, resulting in the handlers to be GC'd the race that was supposed to free resources for the HieDB & co. would throw a hard error talking about the MVar being unreachable. We would like to instead finish gracefully because finishing the race as soon as the MVar was GC'd is the right thing to do anyway. * [chore] apply suggestions from code review by @fendor * [chore] apply suggestions from code review by @fendor --------- Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 59b733f commit cfeced8

File tree

3 files changed

+49
-27
lines changed

3 files changed

+49
-27
lines changed

‎exe/Wrapper.hs

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,8 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT,
3838
import Data.Maybe
3939
import qualified Data.Text as T
4040
import qualified Data.Text.IO as T
41-
import Development.IDE.LSP.LanguageServer (runLanguageServer)
41+
import Development.IDE.LSP.LanguageServer (Setup (..),
42+
runLanguageServer)
4243
import qualified Development.IDE.Main as Main
4344
import Ide.Logger (Doc, Pretty (pretty),
4445
Recorder, WithPriority,
@@ -300,7 +301,12 @@ launchErrorLSP recorder errorMsg = do
300301
[ exitHandler exit ]
301302

302303
let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
303-
pure (doInitialize, asyncHandlers, interpretHandler)
304+
pure MkSetup
305+
{ doInitialize
306+
, staticHandlers = asyncHandlers
307+
, interpretHandler
308+
, onExit = [exit]
309+
}
304310

305311
runLanguageServer (cmapWithPrio pretty recorder)
306312
(Main.argsLspOptions defaultArguments)

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

Lines changed: 33 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Development.IDE.LSP.LanguageServer
1111
, Log(..)
1212
, ThreadQueue
1313
, runWithWorkerThreads
14+
, Setup (..)
1415
) where
1516

1617
import Control.Concurrent.STM
@@ -81,6 +82,17 @@ instance Pretty Log where
8182
LogLspServer msg -> pretty msg
8283
LogServerShutdownMessage -> "Received shutdown message"
8384

85+
data Setup config m a
86+
= MkSetup
87+
{ doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a))
88+
-- ^ the callback invoked when the language server receives the 'Method_Initialize' request
89+
, staticHandlers :: LSP.Handlers m
90+
-- ^ the statically known handlers of the lsp server
91+
, interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO
92+
-- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@
93+
, onExit :: [IO ()]
94+
-- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down
95+
}
8496

8597
runLanguageServer
8698
:: forall config a m. (Show config)
@@ -90,18 +102,16 @@ runLanguageServer
90102
-> Handle -- output
91103
-> config
92104
-> (config -> Value -> Either T.Text config)
93-
-> (config -> m config ())
94-
-> (MVar ()
95-
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)),
96-
LSP.Handlers (m config),
97-
(LanguageContextEnv config, a) -> m config <~> IO))
105+
-> (config -> m ())
106+
-> (MVar () -> IO (Setup config m a))
98107
-> IO ()
99108
runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do
100109
-- This MVar becomes full when the server thread exits or we receive exit message from client.
101110
-- LSP server will be canceled when it's full.
102111
clientMsgVar <- newEmptyMVar
103112

104-
(doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar
113+
MkSetup
114+
{ doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar
105115

106116
let serverDefinition = LSP.ServerDefinition
107117
{ LSP.parseConfig = parseConfig
@@ -115,28 +125,29 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh
115125
, LSP.options = modifyOptions options
116126
}
117127

118-
let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)
128+
let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog)
119129
lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder)
120130

121-
void $ untilMVar clientMsgVar $
122-
void $ LSP.runServerWithHandles
131+
let runServer =
132+
LSP.runServerWithHandles
123133
lspCologAction
124134
lspCologAction
125135
inH
126136
outH
127137
serverDefinition
128138

139+
untilMVar clientMsgVar $
140+
runServer `finally` sequence_ onExit
141+
129142
setupLSP ::
130-
forall config err.
143+
forall config.
131144
Recorder (WithPriority Log)
132145
-> FilePath -- ^ root directory, see Note [Root Directory]
133146
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
134147
-> LSP.Handlers (ServerM config)
135148
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
136149
-> MVar ()
137-
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
138-
LSP.Handlers (ServerM config),
139-
(LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
150+
-> IO (Setup config (ServerM config) IdeState)
140151
setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do
141152
-- Send everything over a channel, since you need to wait until after initialise before
142153
-- LspFuncs is available
@@ -171,7 +182,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar
171182
cancelled <- readTVar cancelledRequests
172183
unless (reqId `Set.member` cancelled) retry
173184

174-
let asyncHandlers = mconcat
185+
let staticHandlers = mconcat
175186
[ userHandlers
176187
, cancelHandler cancelRequest
177188
, exitHandler exit
@@ -184,7 +195,9 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar
184195

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

187-
pure (doInitialize, asyncHandlers, interpretHandler)
198+
let onExit = [stopReactorLoop, exit]
199+
200+
pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit}
188201

189202

190203
handleInit
@@ -266,10 +279,12 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do
266279
liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)
267280

268281
-- | Runs the action until it ends or until the given MVar is put.
282+
-- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should
283+
-- occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon
284+
-- as the thread receives the BlockedIndefinitelyOnMVar exception)
269285
-- Rethrows any exceptions.
270-
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
271-
untilMVar mvar io = void $
272-
waitAnyCancel =<< traverse async [ io , readMVar mvar ]
286+
untilMVar :: MonadUnliftIO m => MVar () -> m a -> m ()
287+
untilMVar mvar io = race_ (readMVar mvar) io
273288

274289
cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)
275290
cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ module Development.IDE.Main
1212
) where
1313

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

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

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

371-
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
370+
do
371+
ideStateVar <- newEmptyMVar
372+
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar)
372373
dumpSTMStats
373374
Check argFiles -> do
374375
let dir = argsProjectRoot

0 commit comments

Comments
 (0)