Skip to content

Commit 6d34bac

Browse files
soulomoonsoulomoon
committed
split to restarting to stoping thread and starting thread
1 parent 39a45a2 commit 6d34bac

File tree

2 files changed

+127
-39
lines changed

2 files changed

+127
-39
lines changed

‎ghcide/src/Development/IDE/Core/Service.hs

Lines changed: 10 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -35,15 +35,22 @@ import qualified Language.LSP.Server as LSP
3535

3636
import Control.Concurrent.Async (async, withAsync)
3737
import Control.Concurrent.STM (TQueue, atomically,
38-
newTQueueIO, readTQueue,
39-
writeTBQueue, writeTQueue)
38+
flushTQueue, newTQueueIO,
39+
readTQueue, writeTBQueue,
40+
writeTQueue)
4041
import Control.Monad
42+
import qualified Data.List.NonEmpty as NE
43+
import Data.Semigroup (Semigroup (sconcat))
44+
import qualified Data.Text as T
45+
import Debug.Trace (traceM)
4146
import qualified Development.IDE.Core.FileExists as FileExists
4247
import qualified Development.IDE.Core.OfInterest as OfInterest
4348
import Development.IDE.Core.Shake hiding (Log)
4449
import qualified Development.IDE.Core.Shake as Shake
4550
import Development.IDE.Types.Monitoring (Monitoring)
4651
import Development.IDE.Types.Shake (WithHieDb)
52+
import Extra (sleep)
53+
import Ide.Logger (Priority (Info), logWith)
4754
import Ide.Types (IdePlugins)
4855
import System.Environment (lookupEnv)
4956

@@ -102,7 +109,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
102109

103110
-- | Shutdown the Compiler Service.
104111
shutdown :: IdeState -> IO ()
105-
shutdown st = atomically $ writeTQueue (shakeOpQueue $ shakeExtras st) $ shakeShut st
112+
shutdown st = shakeShut st
106113

107114
-- This will return as soon as the result of the action is
108115
-- available. There might still be other rules running at this point,
@@ -112,12 +119,3 @@ runAction herald ide act =
112119
join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act)
113120

114121

115-
runWithShake :: (ShakeOpQueue-> IO ()) -> IO ()
116-
runWithShake f = do
117-
q <- newTQueueIO
118-
withAsync (runShakeOp q) $ const $ f q
119-
where
120-
runShakeOp :: ShakeOpQueue -> IO ()
121-
runShakeOp q = do
122-
join $ atomically $ readTQueue q
123-
runShakeOp q

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

Lines changed: 117 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -25,9 +25,10 @@ module Development.IDE.Core.Shake(
2525
IdeState, shakeSessionInit, shakeExtras, shakeDb,
2626
ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
2727
KnownTargets, Target(..), toKnownFiles,
28-
IdeRule, IdeResult,
28+
IdeRule, IdeResult, restartRecorder,
2929
GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
30-
shakeOpen, shakeShut,
30+
shakeOpen, shakeShut, runWithShake,
31+
doShakeRestart,
3132
shakeEnqueue,
3233
ShakeOpQueue,
3334
newSession,
@@ -106,10 +107,12 @@ import Data.Hashable
106107
import qualified Data.HashMap.Strict as HMap
107108
import Data.HashSet (HashSet)
108109
import qualified Data.HashSet as HSet
109-
import Data.List.Extra (foldl', partition,
110-
takeEnd)
110+
import Data.List.Extra (foldl', intercalate,
111+
partition, takeEnd)
112+
import qualified Data.List.NonEmpty as NE
111113
import qualified Data.Map.Strict as Map
112114
import Data.Maybe
115+
import Data.Semigroup (Semigroup (sconcat))
113116
import qualified Data.SortedList as SL
114117
import Data.String (fromString)
115118
import qualified Data.Text as T
@@ -120,6 +123,7 @@ import Data.Typeable
120123
import Data.Unique
121124
import Data.Vector (Vector)
122125
import qualified Data.Vector as Vector
126+
import Debug.Trace (traceM)
123127
import Development.IDE.Core.Debouncer
124128
import Development.IDE.Core.FileUtils (getModTime)
125129
import Development.IDE.Core.PositionMapping
@@ -196,6 +200,7 @@ data Log
196200
| LogCancelledAction !T.Text
197201
| LogSessionInitialised
198202
| LogLookupPersistentKey !T.Text
203+
| LogRestartDebounceCount !Int
199204
| LogShakeGarbageCollection !T.Text !Int !Seconds
200205
-- * OfInterest Log messages
201206
| LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
@@ -242,6 +247,8 @@ instance Pretty Log where
242247
LogSetFilesOfInterest ofInterest ->
243248
"Set files of interst to" <> Pretty.line
244249
<> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
250+
LogRestartDebounceCount count ->
251+
"Restart debounce count:" <+> pretty count
245252

246253
-- | We need to serialize writes to the database, so we send any function that
247254
-- needs to write to the database over the channel, where it will be picked up by
@@ -262,7 +269,7 @@ type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
262269

263270
-- ShakeOpQueue is used to enqueue Shake operations.
264271
-- shutdown, restart
265-
type ShakeOpQueue = TQueue (IO ())
272+
type ShakeOpQueue = TQueue RestartArguments
266273

267274
-- Note [Semantic Tokens Cache Location]
268275
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -756,38 +763,118 @@ delayedAction a = do
756763
extras <- ask
757764
liftIO $ shakeEnqueue extras a
758765

759-
-- | Restart the current 'ShakeSession' with the given system actions.
760-
-- Any actions running in the current session will be aborted,
761-
-- but actions added via 'shakeEnqueue' will be requeued.
762-
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
763-
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do
764-
barrier <- newBarrier
765-
atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ do
766-
withMVar'
767-
shakeSession
766+
data RestartArguments = RestartArguments
767+
{ restartVFS :: VFSModified
768+
, restartReasons :: [String]
769+
, restartActions :: [DelayedAction ()]
770+
, restartActionBetweenShakeSession :: IO [Key]
771+
-- barrier to wait for the session stopped
772+
, restartBarriers :: [Barrier ()]
773+
, restartRecorder :: Recorder (WithPriority Log)
774+
, restartIdeState :: IdeState
775+
}
776+
777+
instance Semigroup RestartArguments where
778+
RestartArguments a1 a2 a3 a4 a5 a6 a7 <> RestartArguments b1 b2 b3 b4 b5 b6 _b7 =
779+
RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) (a6 <> b6) a7
780+
781+
-- do x until time up and do y
782+
-- doUntil time out
783+
doUntil :: IO a -> IO [a]
784+
doUntil x = do
785+
res <- x
786+
rest <- doUntil x
787+
return (res:rest)
788+
789+
runWithShake :: (ShakeOpQueue-> IO ()) -> IO ()
790+
runWithShake f = do
791+
stopQueue <- newTQueueIO
792+
doQueue <- newTQueueIO
793+
withAsync (stopShakeLoop stopQueue doQueue) $
794+
const $ withAsync (runShakeLoop doQueue) $
795+
const $ f stopQueue
796+
where
797+
-- keep running the stopShakeOp and stop the shake session
798+
-- and send the restart arguments to the runShakeLoop
799+
stopShakeLoop :: ShakeOpQueue -> ShakeOpQueue -> IO ()
800+
stopShakeLoop stopq doq = do
801+
arg <- atomically $ readTQueue stopq
802+
-- todo print this out
803+
_stopTime <- stopShakeSession arg
804+
traceM $ "Stopped shake session"
805+
atomically $ writeTQueue doq arg
806+
stopShakeLoop stopq doq
807+
runShakeLoop :: ShakeOpQueue -> IO ()
808+
runShakeLoop q = do
809+
sleep 0.1
810+
x <- atomically (tryPeekTQueue q)
811+
when (isJust x) $ do
812+
sleep 0.1
813+
args <- atomically $ flushTQueue q
814+
traceM $ "Restarting shake with " ++ show (length args) ++ " arguments"
815+
case NE.nonEmpty args of
816+
Nothing -> return ()
817+
Just x -> do
818+
let count = length x
819+
let arg = sconcat x
820+
let recorder = restartRecorder arg
821+
logWith recorder Info $ LogRestartDebounceCount count
822+
-- traceM $ "Restarting shake with " ++ show count ++ " arguments"
823+
doShakeRestart arg 1
824+
runShakeLoop q
825+
826+
-- prepare the restart
827+
stopShakeSession :: RestartArguments -> IO Seconds
828+
stopShakeSession RestartArguments{restartIdeState=IdeState{..}, ..} = do
829+
withMVar shakeSession
830+
(\runner -> do
831+
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
832+
keys <- restartActionBetweenShakeSession
833+
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
834+
-- signal the caller that we are done stopping and ready to restart
835+
mapM_ (flip signalBarrier ()) restartBarriers
836+
return stopTime
837+
)
838+
where
839+
logErrorAfter :: Seconds -> IO () -> IO ()
840+
logErrorAfter seconds action = flip withAsync (const action) $ do
841+
sleep seconds
842+
logWith restartRecorder Error (LogBuildSessionRestartTakingTooLong seconds)
843+
844+
845+
doShakeRestart :: RestartArguments -> Seconds -> IO ()
846+
doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} stopTime = do
847+
withMVar' shakeSession
768848
(\runner -> do
769-
(stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
770-
keys <- ioActionBetweenShakeSession
771-
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
772849
res <- shakeDatabaseProfile shakeDb
773850
backlog <- readTVarIO $ dirtyKeys shakeExtras
774851
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
775-
776852
-- this log is required by tests
777-
logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res
853+
logWith restartRecorder Debug $ LogBuildSessionRestart (intercalate ", " restartReasons) queue backlog stopTime res
778854
)
779855
-- It is crucial to be masked here, otherwise we can get killed
780856
-- between spawning the new thread and updating shakeSession.
781857
-- See https://github.com/haskell/ghcide/issues/79
782858
(\() -> do
783-
(,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason)
784-
signalBarrier barrier ()
785-
waitBarrier barrier
786-
where
787-
logErrorAfter :: Seconds -> IO () -> IO ()
788-
logErrorAfter seconds action = flip withAsync (const action) $ do
789-
sleep seconds
790-
logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds)
859+
(,()) <$> newSession restartRecorder shakeExtras restartVFS shakeDb restartActions (intercalate ", " restartReasons))
860+
861+
862+
-- | Restart the current 'ShakeSession' with the given system actions.
863+
-- Any actions running in the current session will be aborted,
864+
-- but actions added via 'shakeEnqueue' will be requeued.
865+
shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
866+
shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do
867+
barrier <- newBarrier
868+
let restartArgs = RestartArguments
869+
{ restartVFS = vfs
870+
, restartReasons = [reason]
871+
, restartActions = acts
872+
, restartActionBetweenShakeSession = ioActionBetweenShakeSession
873+
, restartBarriers = [barrier]
874+
, restartRecorder = recorder
875+
, restartIdeState = IdeState{..}
876+
}
877+
atomically $ writeTQueue (shakeOpQueue $ shakeExtras) restartArgs
791878

792879
-- | Enqueue an action in the existing 'ShakeSession'.
793880
-- Returns a computation to block until the action is run, propagating exceptions.
@@ -812,6 +899,9 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do
812899
return (wait' b >>= either throwIO return)
813900

814901
data VFSModified = VFSUnmodified | VFSModified !VFS
902+
instance Semigroup VFSModified where
903+
VFSUnmodified <> x = x
904+
x <> _ = x
815905

816906
-- | Set up a new 'ShakeSession' with a set of initial actions
817907
-- Will crash if there is an existing 'ShakeSession' running.

0 commit comments

Comments
 (0)