Skip to content

Commit 2cc8c97

Browse files
soulomoonsoulomoon
committed
kill thread that actually needed to be killed
1 parent eaff72e commit 2cc8c97

File tree

8 files changed

+229
-222
lines changed

8 files changed

+229
-222
lines changed

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

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -175,6 +175,7 @@ import System.Info.Extra (isWindows)
175175

176176
import qualified Data.IntMap as IM
177177
import GHC.Fingerprint
178+
import Debug.Trace (traceEventIO)
178179

179180
data Log
180181
= LogShake Shake.Log
@@ -910,16 +911,20 @@ getModSummaryRule displayTHWarning recorder = do
910911
return (Just fp, Just res{msrModSummary = ms})
911912
Nothing -> return (Nothing, Nothing)
912913

913-
generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
914-
generateCore runSimplifier file = do
914+
generateCore :: Recorder (WithPriority Log) -> RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
915+
generateCore recorder runSimplifier file = do
916+
liftIO $ traceEventIO "Generating Core1"
915917
packageState <- hscEnv <$> use_ GhcSessionDeps file
918+
liftIO $ traceEventIO "Generating Core2"
916919
hsc' <- setFileCacheHook packageState
920+
liftIO $ traceEventIO "Generating Core3"
917921
tm <- use_ TypeCheck file
922+
liftIO $ traceEventIO "Generating Core4"
918923
liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm)
919924

920925
generateCoreRule :: Recorder (WithPriority Log) -> Rules ()
921926
generateCoreRule recorder =
922-
define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True)
927+
define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore recorder (RunSimplifier True)
923928

924929
getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
925930
getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do

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

Lines changed: 5 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -773,7 +773,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
773773
pure ShakeExtras{shakeRecorder = recorder, ..}
774774
shakeDb <-
775775
shakeNewDatabase
776-
(\logText -> logWith recorder Info (LogShakeText $ T.pack logText))
776+
(\logText -> logWith recorder Debug (LogShakeText $ T.pack logText))
777777
shakeControlQueue
778778
opts { shakeExtra = newShakeExtra shakeExtras }
779779
rules
@@ -848,6 +848,7 @@ shakeShut IdeState{..} = do
848848
-- Shake gets unhappy if you try to close when there is a running
849849
-- request so we first abort that.
850850
for_ runner (flip cancelShakeSession mempty)
851+
shakeShutDatabase mempty shakeDb
851852
void $ shakeDatabaseProfile shakeDb
852853
progressStop $ progress shakeExtras
853854
progressStop $ indexProgressReporting $ hiedbWriter shakeExtras
@@ -950,33 +951,15 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
950951
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
951952
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
952953
-- Check if there is another restart request pending, if so, we run that one too
953-
-- readAndGo sra >>= finalCheck
954954
return (sra, keys)
955-
-- readAndGo sra = do
956-
-- nextRestartArg <- atomically $ tryReadTaskQueue shakeControlQueue
957-
-- case nextRestartArg of
958-
-- Nothing -> return sra
959-
-- Just (Left dy) -> do
960-
-- res <- prepareRestart $ dynShakeRestart dy
961-
-- return $ sra <> res
962-
-- Just (Right _) -> readAndGo sra
963-
-- finalCheck sra = do
964-
-- -- final check
965-
-- -- sleep 0.2
966-
-- b <- atomically $ isEmptyTaskQueue shakeControlQueue
967-
-- if b
968-
-- then return sra
969-
-- -- there is something new, read and go again
970-
-- else readAndGo sra
971955
withMVar'
972956
shakeSession
973957
( \runner -> do
974-
-- takeShakeLock shakeDb
975958
(restartArgs, newDirtyKeys) <- prepareRestart shakeRestartArgs
976959
reverseMap <- shakeDatabaseReverseDep shakeDb
977-
-- (preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys
978-
let (preservekvs, allRunning2) = ([], [])
979-
logWith recorder Info $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap
960+
(preservekvs, allRunning2) <- shakeComputeToPreserve shakeDb $ fromListKeySet newDirtyKeys
961+
-- let (preservekvs, allRunning2) = ([], [])
962+
logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys allRunning2 reverseMap
980963
(stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner $ S.fromList $ map snd preservekvs
981964

982965
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras

‎hls-graph/src/Development/IDE/Graph/Internal/Database.hs‎

Lines changed: 17 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -144,23 +144,23 @@ interpreBuildContinue (BCContinue ioR) = ioR
144144
-- finally, catch any (async) exception and mark the key as exception
145145

146146
-- submmittBuildInDb :: Database -> IO a -> IO a
147-
submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO ()
148-
submmittBuildInDb db stack id s = do
149-
uninterruptibleMask_ $ do
150-
do
151-
curStep <- readTVarIO $ databaseStep db
152-
startBarrier <- newEmptyTMVarIO
153-
newAsync <-
154-
async
155-
(do
156-
uninterruptibleMask_ $ atomically $ readTMVar startBarrier
157-
void (refresh db stack id s) `catch` \e@(SomeException _) ->
158-
atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db)
159-
)
160-
-- todo should only update if still at stage 1
161-
-- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db)
162-
atomically $ putTMVar startBarrier ()
163-
atomically $ modifyTVar' (databaseThreads db) (newAsync :)
147+
-- submmittBuildInDb :: Database -> Stack -> Key -> Maybe Result -> IO ()
148+
-- submmittBuildInDb db stack id s = do
149+
-- uninterruptibleMask_ $ do
150+
-- do
151+
-- curStep <- readTVarIO $ databaseStep db
152+
-- startBarrier <- newEmptyTMVarIO
153+
-- newAsync <-
154+
-- async
155+
-- (do
156+
-- uninterruptibleMask_ $ atomically $ readTMVar startBarrier
157+
-- void (refresh db stack id s) `catch` \e@(SomeException _) ->
158+
-- atomically $ SMap.focus (updateStatus $ Exception curStep e s) id (databaseValues db)
159+
-- )
160+
-- -- todo should only update if still at stage 1
161+
-- -- atomically $ SMap.focus (updateStatus $ Running curStep s $ RunningStage2 newAsync) id (databaseValues db)
162+
-- atomically $ putTMVar startBarrier ()
163+
-- atomically $ modifyTVar' (databaseThreads db) ((newAsync) :)
164164

165165
builderOneCoroutine :: Key -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue
166166
builderOneCoroutine parentKey isSingletonTask db stack id =
@@ -182,9 +182,6 @@ builderOneCoroutine parentKey isSingletonTask db stack id =
182182
case viewDirty current $ maybe (Dirty Nothing) keyStatus status of
183183
Dirty s -> do
184184
-- we need to run serially to avoid summiting run but killed in the middle
185-
-- we might want it to be able to be killed since we might want to preserve the database
186-
-- traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current)
187-
--
188185
let wait = readMVar barrier
189186
runOneInDataBase (do {
190187
status <- atomically (SMap.lookup id databaseValues)

‎hls-graph/src/Development/IDE/Graph/Internal/Types.hs‎

Lines changed: 69 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -20,18 +20,17 @@ import Data.Foldable (fold)
2020
import qualified Data.HashMap.Strict as Map
2121
import Data.IORef
2222
import Data.List (intercalate)
23-
import Data.Maybe
23+
import Data.Maybe (fromMaybe, isNothing)
2424
import Data.Set (Set)
2525
import qualified Data.Set as S
2626
import Data.Typeable
2727
import Debug.Trace (traceEventIO, traceM)
2828
import Development.IDE.Graph.Classes
2929
import Development.IDE.Graph.Internal.Key
3030
import Development.IDE.WorkerThread (DeliverStatus (..),
31-
TaskQueue,
31+
TaskQueue (..),
3232
awaitRunInThread,
33-
counTaskQueue,
34-
runInThreadStmInNewThreads)
33+
counTaskQueue)
3534
import qualified Focus
3635
import GHC.Conc (TVar, atomically)
3736
import GHC.Generics (Generic)
@@ -40,12 +39,12 @@ import qualified StmContainers.Map as SMap
4039
import StmContainers.Map (Map)
4140
import System.Time.Extra (Seconds, sleep)
4241
import UnliftIO (Async (asyncThreadId),
43-
MonadUnliftIO,
42+
MonadUnliftIO, async,
4443
asyncExceptionFromException,
4544
asyncExceptionToException,
46-
readTVar, readTVarIO,
45+
poll, readTVar, readTVarIO,
4746
throwTo, waitCatch,
48-
withAsync)
47+
withAsync, writeTQueue)
4948
import UnliftIO.Concurrent (ThreadId, myThreadId)
5049
import qualified UnliftIO.Exception as UE
5150

@@ -162,7 +161,7 @@ type DBQue = TaskQueue (Either Dynamic (IO ()))
162161
data Database = Database {
163162
databaseExtra :: Dynamic,
164163

165-
databaseThreads :: TVar [Async ()],
164+
databaseThreads :: TVar [(DeliverStatus, Async ())],
166165

167166
databaseReverseDep :: SMap.Map Key KeySet,
168167
-- For each key, the set of keys that depend on it directly.
@@ -193,23 +192,27 @@ data Database = Database {
193192
-- all non-dirty running need to have an updated step,
194193
-- so it won't be view as dirty when we restart the build
195194
-- computeToPreserve :: Database -> KeySet -> STM [(Key, Async ())]
195+
computeToPreserve :: Database -> KeySet -> STM ([(Key, Async ())], [Key])
196196
computeToPreserve db dirtySet = do
197-
-- All keys that depend (directly or transitively) on any dirty key
198-
affected <- computeTransitiveReverseDeps db dirtySet
199-
-- Running stage-2 keys are eligible to be considered for cleanup
200-
running2 <- getRunningStage2Keys db
201-
allRunings <- getRunningKeys db
202-
forM_ allRunings $ \k -> do
203-
-- if not dirty, bump its step
204-
unless (memberKeySet k dirtySet) $ do
205-
SMap.focus (Focus.alter $ \case
206-
Just kd@KeyDetails {keyStatus=Running {runningStep, runningPrev, runningWait, runningStage}} -> Just (kd{keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage})
207-
_ -> Nothing
208-
) k (databaseValues db)
209-
210-
-- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty
211-
-- Keep only those whose key is NOT affected by the dirty set
212-
pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings)
197+
-- All keys that depend (directly or transitively) on any dirty key
198+
affected <- computeTransitiveReverseDeps db dirtySet
199+
running2 <- getRunningStage2Keys db
200+
allRunings <- getRunningKeys db
201+
forM_ allRunings $ \k -> do
202+
-- if not dirty, bump its step
203+
unless (memberKeySet k affected) $ do
204+
SMap.focus
205+
( Focus.alter $ \case
206+
Just kd@KeyDetails {keyStatus = Running {runningStep, runningPrev, runningWait, runningStage}} ->
207+
Just (kd {keyStatus = Running (runningStep + 1) runningPrev runningWait runningStage})
208+
_ -> Nothing
209+
)
210+
k
211+
(databaseValues db)
212+
213+
-- traceM $ "key: " ++ show k ++ ", isDirty: " ++ show isDirty
214+
-- Keep only those whose key is NOT affected by the dirty set
215+
pure ([kv | kv@(k, _async) <- running2, not (memberKeySet k affected)], allRunings)
213216

214217
getRunningStage2Keys :: Database -> STM [(Key, Async ())]
215218
-- getRunningStage2Keys db = return []
@@ -267,15 +270,35 @@ runInDataBase :: String -> Database -> [(IO result, Either SomeException result
267270
runInDataBase title db acts = do
268271
s <- getDataBaseStepInt db
269272
let actWithEmptyHook = map (\(x, y) -> (const $ return (), x, y)) acts
270-
runInThreadStmInNewThreads (getDataBaseStepInt db) (return $ DeliverStatus s title) (databaseQueue db) (databaseThreads db) actWithEmptyHook
273+
runInThreadStmInNewThreads db (return $ DeliverStatus s title) actWithEmptyHook
274+
275+
runInThreadStmInNewThreads :: Database -> IO DeliverStatus -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM ()
276+
runInThreadStmInNewThreads db mkDeliver acts = do
277+
-- Take an action from TQueue, run it and
278+
-- use barrier to wait for the result
279+
let TaskQueue q = databaseQueue db
280+
let log prefix title = dataBaseLogger db (prefix ++ title)
281+
writeTQueue q $ Right $ do
282+
uninterruptibleMask $ \restore -> do
283+
do
284+
deliver <- mkDeliver
285+
log "runInThreadStmInNewThreads submit begin " (deliverName deliver)
286+
curStep <- atomically $ getDataBaseStepInt db
287+
-- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver)
288+
when (curStep == deliverStep deliver) $ do
289+
syncs <- mapM (\(preHook, act, handler) -> do
290+
a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))
291+
preHook a
292+
return (deliver, a)
293+
) acts
294+
atomically $ modifyTVar' (databaseThreads db) (syncs++)
295+
log "runInThreadStmInNewThreads submit end " (deliverName deliver)
271296

272297
runOneInDataBase :: IO DeliverStatus -> Database -> (Async () -> IO ()) -> IO result -> (SomeException -> IO ()) -> STM ()
273298
runOneInDataBase mkDelivery db registerAsync act handler = do
274299
runInThreadStmInNewThreads
275-
(getDataBaseStepInt db)
300+
db
276301
mkDelivery
277-
(databaseQueue db)
278-
(databaseThreads db)
279302
[ ( registerAsync, warpLog act,
280303
\case
281304
Left e -> handler e
@@ -284,7 +307,7 @@ runOneInDataBase mkDelivery db registerAsync act handler = do
284307
]
285308
where
286309
warpLog a =
287-
UE.bracket
310+
bracket
288311
(do (DeliverStatus _ title) <- mkDelivery; dataBaseLogger db ("Starting async action: " ++ title); return title)
289312
(\title -> dataBaseLogger db $ "Finished async action: " ++ title)
290313
(const a)
@@ -308,19 +331,29 @@ shutDatabase preserve Database{..} = uninterruptibleMask $ \unmask -> do
308331
asyncs <- readTVarIO databaseThreads
309332
step <- readTVarIO databaseStep
310333
tid <- myThreadId
311-
traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step)
312-
let remains = filter (`S.member` preserve) asyncs
313-
let toCancel = filter (`S.notMember` preserve) asyncs
314-
mapM_ (\a -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) toCancel
334+
-- traceEventIO ("shutDatabase: cancelling " ++ show (length asyncs) ++ " asyncs, step " ++ show step)
335+
-- traceEventIO ("shutDatabase: async entries: " ++ show (map (deliverName . fst) asyncs))
336+
let remains = filter (\(_, s) -> s `S.member` preserve) asyncs
337+
let toCancel = filter (\(_, s) -> s `S.notMember` preserve) asyncs
338+
-- traceEventIO ("shutDatabase: remains count: " ++ show (length remains) ++ ", names: " ++ show (map (deliverName . fst) remains))
339+
-- traceEventIO ("shutDatabase: toCancel count: " ++ show (length toCancel) ++ ", names: " ++ show (map (deliverName . fst) toCancel))
340+
mapM_ (\(_, a) -> throwTo (asyncThreadId a) $ AsyncParentKill tid step) toCancel
315341
atomically $ modifyTVar' databaseThreads (const remains)
316342
-- Wait until all the asyncs are done
317343
-- But if it takes more than 10 seconds, log to stderr
318344
unless (null asyncs) $ do
319345
let warnIfTakingTooLong = unmask $ forever $ do
320-
sleep 10
321-
traceEventIO "cleanupAsync: waiting for asyncs to finish"
346+
sleep 5
347+
as <- readTVarIO databaseThreads
348+
-- poll each async: Nothing => still running
349+
statuses <- forM as $ \(d,a) -> do
350+
p <- poll a
351+
return (d, a, p)
352+
let still = [ (deliverName d, show (asyncThreadId a)) | (d,a,p) <- statuses, isNothing p ]
353+
traceEventIO $ "cleanupAsync: waiting for asyncs to finish; total=" ++ show (length as) ++ ", stillRunning=" ++ show (length still)
354+
traceEventIO $ "cleanupAsync: still running (deliverName, threadId) = " ++ show still
322355
withAsync warnIfTakingTooLong $ \_ ->
323-
mapM_ waitCatch asyncs
356+
mapM_ waitCatch $ map snd toCancel
324357

325358
-- waitForDatabaseRunningKeys :: Database -> IO ()
326359
-- waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd)

‎hls-graph/src/Development/IDE/WorkerThread.hs‎

Lines changed: 2 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,6 @@ module Development.IDE.WorkerThread
1717
TaskQueue(..),
1818
writeTaskQueue,
1919
withWorkerQueueSimple,
20-
runInThreadStmInNewThreads,
2120
isEmptyTaskQueue,
2221
counTaskQueue,
2322
submitWork,
@@ -29,17 +28,13 @@ module Development.IDE.WorkerThread
2928
awaitRunInThread
3029
) where
3130

32-
import Control.Concurrent.Async (Async, async, withAsync)
31+
import Control.Concurrent.Async (withAsync)
3332
import Control.Concurrent.STM
34-
import Control.Exception.Safe (MonadMask (..),
35-
SomeException (SomeException),
36-
finally, throw, try)
33+
import Control.Exception.Safe (SomeException, finally, throw, try)
3734
import Control.Monad.Cont (ContT (ContT))
3835
import qualified Data.Text as T
3936

4037
import Control.Concurrent
41-
import Control.Exception (catch)
42-
import Control.Monad (when)
4338
import Data.Dynamic (Dynamic)
4439
import Prettyprinter
4540

@@ -134,23 +129,6 @@ data DeliverStatus = DeliverStatus
134129
, deliverName :: String
135130
} deriving (Show)
136131

137-
runInThreadStmInNewThreads :: STM Int -> IO DeliverStatus -> TaskQueue (Either Dynamic (IO ())) -> TVar [Async ()] -> [(Async () -> IO (), IO result, Either SomeException result -> IO ())] -> STM ()
138-
runInThreadStmInNewThreads getStep mkDeliver (TaskQueue q) tthreads acts = do
139-
-- Take an action from TQueue, run it and
140-
-- use barrier to wait for the result
141-
writeTQueue q $ Right $ do
142-
uninterruptibleMask $ \restore -> do
143-
do
144-
curStep <- atomically getStep
145-
deliver <- mkDeliver
146-
-- traceM ("runInThreadStmInNewThreads: current step: " ++ show curStep ++ " deliver step: " ++ show deliver)
147-
when (curStep == deliverStep deliver) $ do
148-
syncs <- mapM (\(preHook, act, handler) -> do
149-
a <- async (handler =<< (restore $ Right <$> act) `catch` \e@(SomeException _) -> return (Left e))
150-
preHook a
151-
return a
152-
) acts
153-
atomically $ modifyTVar' tthreads (syncs++)
154132

155133
type Worker arg = arg -> IO ()
156134

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Ide.Plugin.SemanticTokens.Types
99
import Ide.Types
1010
import Language.LSP.Protocol.Message
1111

12+
-- I hope that does mean much more sense now, only fire at the point would give a bit more than it should
1213
descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState
1314
descriptor recorder plId =
1415
(defaultPluginDescriptor plId "Provides semantic tokens")

0 commit comments

Comments
 (0)