Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Simplify the abortion mechanism with async #353

Merged
merged 6 commits into from
Jan 25, 2020
Merged
Changes from all commits
Commits
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
49 changes: 26 additions & 23 deletions src/Development/IDE/Core/Shake.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,6 +72,7 @@ import qualified Data.SortedList as SL
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.Types.Options
import Control.Concurrent.Async
import Control.Concurrent.Extra
import Control.Exception
import Control.DeepSeq
Expand Down Expand Up @@ -378,11 +379,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do

-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
-- an exception, the previous value is restored while the second argument is executed masked.
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
withMVar' var unmasked masked = mask $ \restore -> do
a <- takeMVar var
b <- restore (unmasked a) `onException` putMVar var a
(a', c) <- masked b
restore (unmasked a) `onException` putMVar var a
(a', c) <- masked
putMVar var a'
pure c

Expand All @@ -394,29 +395,31 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
(\stop -> do
(stopTime,_) <- duration stop
logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
bar <- newBarrier
start <- offsetTime
pure (start, bar))
)
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
-- It is crucial to be masked here, otherwise we can get killed
-- between spawning the new thread and updating shakeAbort.
-- See https://github.com/digital-asset/ghcide/issues/79
(\(start, bar) -> do
thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
runTime <- start
let res' = case res of
Left e -> "exception: " <> displayException e
Right _ -> "completed"
profile = case res of
Right (_, Just fp) ->
let link = case filePathToUri' $ toNormalizedFilePath fp of
NormalizedUri x -> x
in ", profile saved at " <> T.unpack link
_ -> ""
logDebug logger $ T.pack $
"Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
signalBarrier bar (fst <$> res)
-- important: we send an async exception to the thread, then wait for it to die, before continuing
pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
(do
start <- offsetTime
aThread <- asyncWithUnmask $ \restore -> do
pepeiborra marked this conversation as resolved.
Show resolved Hide resolved
res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
runTime <- start
let res' = case res of
Left e -> "exception: " <> displayException e
Right _ -> "completed"
profile = case res of
Right (_, Just fp) ->
let link = case filePathToUri' $ toNormalizedFilePath fp of
NormalizedUri x -> x
in ", profile saved at " <> T.unpack link
_ -> ""
let logMsg = logDebug logger $ T.pack $
"Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
return (fst <$> res, logMsg)
let wrapUp (res, logMsg) = do
() <- logMsg
either (throwIO @SomeException) return res
pure (cancel aThread, wrapUp =<< wait aThread))

getDiagnostics :: IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
Expand Down