Skip to content

Commit 8396a37

Browse files
soulomoonsoulomoon
committed
fix insertBlockedKey and insert log
1 parent e12b508 commit 8396a37

File tree

5 files changed

+91
-64
lines changed

5 files changed

+91
-64
lines changed

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

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -131,6 +131,7 @@ import Data.Either (isRight, lefts)
131131
import Data.Int (Int64)
132132
import Data.Set (Set)
133133
import qualified Data.Set as S
134+
import Debug.Trace (traceEventIO)
134135
import Development.IDE.Core.Tracing
135136
import Development.IDE.GHC.Compat (NameCache,
136137
NameCacheUpdater,
@@ -831,6 +832,9 @@ shakeSessionInit recorder IdeState{..} = do
831832

832833
shakeShut :: IdeState -> IO ()
833834
shakeShut IdeState{..} = do
835+
-- let dumpPath = "scheduler.dump"
836+
-- dump <- dumpSchedulerState (shakeGetDatabase shakeDb)
837+
-- writeFile dumpPath dump
834838
runner <- tryReadMVar shakeSession
835839
-- Shake gets unhappy if you try to close when there is a running
836840
-- request so we first abort that.
@@ -933,6 +937,7 @@ runRestartTask recorder ideStateVar shakeRestartArgs = do
933937
withMVar'
934938
shakeSession
935939
( \runner -> do
940+
traceEventIO ("runRestartTask")
936941
newDirtyKeys <- sraBetweenSessions shakeRestartArgs
937942
-- reverseMap <- shakedatabaseRuntimeDep shakeDb
938943
-- logWith recorder Debug $ LogPreserveKeys (map fst preservekvs) newDirtyKeys [] reverseMap

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ shakeRunDatabaseForKeysSep keysChanged (ShakeDatabase _ as1 db) acts isTesting =
9494
liftIO $ atomically $ doneQueue d (databaseActionQueue db)
9595

9696
-- we can to upsweep these keys in order one by one,
97-
preserves <- traceEvent ("upsweep dirties " ++ show keysChanged) $ incDatabase1 db keysChanged
97+
preserves <- incDatabase1 db keysChanged
9898
(_, act) <- instantiateDelayedAction (mkDelayedAction "upsweep" Debug $ upsweepAction)
9999
reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress (databaseActionQueue db)
100100
reenqueuedExceptPreserves <-

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,6 +73,7 @@ newDatabase dataBaseLogger databaseQueue databaseActionQueue databaseExtra datab
7373
schedulerRunningReady <- newTQueueIO
7474
schedulerRunningPending <- atomically SMap.new
7575
schedulerUpsweepQueue <- newTQueueIO
76+
schedulerRunningOrigins <- newTVarIO []
7677
let databaseScheduler = SchedulerState{..}
7778
pure Database{..}
7879

@@ -91,7 +92,7 @@ incDatabase db (Just (kk, preserves)) = do
9192
-- transitiveDirtyKeys <- transitiveDirtyListBottomUp db (toListKeySet $ kk <> transitiveDirtyKeysNew <> upSweepDirties)
9293
transitiveDirtyKeys <- transitiveDirtyListBottomUpDiff db (toListKeySet kk) (toListKeySet oldUpSweepDirties)
9394
-- let transitiveDirtyKeys = toListKeySet transitiveDirtyKeysOld
94-
results <- traceEvent ("upsweep all dirties " ++ show transitiveDirtyKeys) $ for transitiveDirtyKeys $ \k ->
95+
results <- for transitiveDirtyKeys $ \k ->
9596
-- Updating all the keys atomically is not necessary
9697
-- since we assume that no build is mutating the db.
9798
-- Therefore run one transaction per key to minimise contention.

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

Lines changed: 18 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -14,17 +14,19 @@ module Development.IDE.Graph.Internal.Scheduler
1414
, insertBlockedKey
1515
, prepareToRunKeysRealTime
1616
, writeUpsweepQueue
17+
, dumpSchedulerState
1718
) where
1819

1920
import Control.Concurrent.STM (STM, atomically, check,
2021
flushTQueue, modifyTVar,
2122
readTQueue, readTVar,
2223
writeTQueue, writeTVar)
23-
import Control.Monad (forM, forM_)
24+
import Control.Monad (forM_)
2425
import Data.Maybe (fromMaybe)
2526
import qualified ListT
2627
import qualified StmContainers.Map as SMap
2728

29+
import Debug.Trace (traceEvent)
2830
import Development.IDE.Graph.Internal.Key (Key, KeySet,
2931
deleteKeySet,
3032
fromListKeySet,
@@ -36,38 +38,23 @@ import Development.IDE.Graph.Internal.Key (Key, KeySet,
3638
unionKeySet)
3739
import Development.IDE.Graph.Internal.Types (Database (..),
3840
KeyDetails (..),
39-
Result (..),
4041
SchedulerState (..),
41-
Status (..), getResult,
42-
getResultDepsDefault)
42+
dumpSchedulerState,
43+
getBlockedBy)
4344

4445
-- prepare to run a key in databaseDirtyTargets
4546
-- we first peek if all the deps are clean
4647
-- if so, we insert it into databaseRunningReady
4748
-- otherwise, we insert it into databaseRunningPending with the pending count(the number of deps not clean)
4849
-- so when a dep is cleaned, we can decrement the pending count, and when it reaches zero, we can move it to databaseRunningReady
4950
prepareToRunKey :: Key -> Database -> STM ()
50-
prepareToRunKey k Database {..} = do
51-
-- Determine the last known direct dependencies of k from its stored Result
52-
mKd <- SMap.lookup k databaseValues
53-
let deps = case mKd of
54-
Nothing -> mempty
55-
Just KeyDetails {keyStatus = st} ->
56-
let mRes = getResult st
57-
in maybe mempty (getResultDepsDefault mempty . resultDeps) mRes
58-
depList = filter (/= k) (toListKeySet deps)
59-
60-
-- Peek dependency statuses to see how many are not yet clean
61-
depStatuses <- forM depList $ \d -> SMap.lookup d databaseValues
62-
let isCleanDep = \case
63-
Just KeyDetails {keyStatus = Clean _} -> True
64-
_ -> False
65-
pendingCount = length (filter (not . isCleanDep) depStatuses)
66-
51+
prepareToRunKey k db@Database {..} = do
52+
pendingCount <- length <$> getBlockedBy k db
6753
let SchedulerState {..} = databaseScheduler
6854
if pendingCount == 0
6955
then do
70-
writeTQueue schedulerRunningReady k
56+
traceEvent ("prepareToRunKey ready: " ++ show k) $
57+
writeTQueue schedulerRunningReady k
7158
SMap.delete k schedulerRunningPending
7259
else do
7360
SMap.insert pendingCount k schedulerRunningPending
@@ -84,8 +71,12 @@ insertBlockedKey pk k Database {..} = do
8471
then do
8572
blockedSet <- readTVar schedulerRunningBlocked
8673
writeTVar schedulerRunningBlocked $ insertKeySet pk blockedSet
74+
writeTVar schedulerRunningDirties $ deleteKeySet pk runnings
8775
else
88-
return ()
76+
-- if pk `memberKeySet` runnings
77+
-- then traceEvent ("insertBlockedKey: " ++show pk ++ " blocked by already running: " ++ show k) $ return ()
78+
-- else
79+
return ()
8980

9081
-- take out all databaseDirtyTargets and prepare them to run
9182
prepareToRunKeys :: Foldable t => Database -> t Key -> IO ()
@@ -148,6 +139,8 @@ writeUpsweepQueue :: [Key] -> Database -> STM ()
148139
writeUpsweepQueue ks Database{..} = do
149140
let SchedulerState{..} = databaseScheduler
150141
forM_ ks $ \k -> writeTQueue schedulerUpsweepQueue k
142+
writeTVar schedulerRunningOrigins ks
143+
151144

152145
-- gather all dirty keys that is not finished, to reschedule after restart
153146
-- includes keys in databaseDirtyTargets, databaseRunningReady, databaseRunningPending, databaseRunningDirties
@@ -185,7 +178,8 @@ readReadyQueue db@Database{..} = do
185178
blockedOnThreadLimit db 16
186179
let SchedulerState{..} = databaseScheduler
187180
r <- readTQueue schedulerRunningReady
188-
modifyTVar schedulerRunningDirties $ insertKeySet r
181+
traceEvent ("readReadyQueue: " ++ show r) $
182+
modifyTVar schedulerRunningDirties $ insertKeySet r
189183
return r
190184

191185

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

Lines changed: 65 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -252,6 +252,11 @@ dbNotLocked db = do
252252
check =<< readTVar (databaseValuesLock db)
253253

254254

255+
shakeGetDatabase :: ShakeDatabase -> Database
256+
shakeGetDatabase (ShakeDatabase _ _ db) = db
257+
258+
shakeGetScheduler :: ShakeDatabase -> SchedulerState
259+
shakeGetScheduler (ShakeDatabase _ _ db) = databaseScheduler db
255260

256261
getShakeQueue :: ShakeDatabase -> DBQue
257262
getShakeQueue (ShakeDatabase _ _ db) = databaseQueue db
@@ -292,43 +297,9 @@ data SchedulerState = SchedulerState
292297
-- ^ Keys that are ready to run
293298
, schedulerRunningPending :: SMap.Map Key Int
294299
-- ^ Keys that are pending because they are waiting for dependencies to complete
300+
, schedulerRunningOrigins :: TVar [Key]
295301
}
296302

297-
-- dump scheduler state
298-
dumpSchedulerState :: SchedulerState -> IO String
299-
dumpSchedulerState SchedulerState{..} = atomically $ do
300-
-- Snapshot queues (drain then restore) to avoid side effects
301-
ups <- flushTQueue schedulerUpsweepQueue
302-
mapM_ (writeTQueue schedulerUpsweepQueue) ups
303-
304-
ready <- flushTQueue schedulerRunningReady
305-
mapM_ (writeTQueue schedulerRunningReady) ready
306-
307-
-- Snapshot sets and pending map
308-
dirties <- readTVar schedulerRunningDirties
309-
blocked <- readTVar schedulerRunningBlocked
310-
pendingPairs <- ListT.toList (SMap.listT schedulerRunningPending)
311-
312-
let ppKey k = PP.pretty k
313-
ppKeys ks = if null ks then PP.brackets mempty else PP.vsep (map (\k -> PP.hsep [PP.pretty ("-" :: String), ppKey k]) ks)
314-
ppPairs xs = if null xs then PP.brackets mempty else PP.vsep (map (\(k,c) -> PP.hsep [PP.pretty ("-" :: String), ppKey k, PP.pretty (":" :: String), PP.pretty c]) xs)
315-
316-
doc = PP.vsep
317-
[ PP.pretty ("SchedulerState" :: String)
318-
, PP.indent 2 $ PP.vsep
319-
[ PP.pretty ("upsweep:" :: String) <> PP.pretty (length ups)
320-
, PP.indent 2 (ppKeys ups)
321-
, PP.pretty ("ready:" :: String) <> PP.pretty (length ready)
322-
, PP.indent 2 (ppKeys ready)
323-
, PP.pretty ("pending:" :: String) <> PP.pretty (length pendingPairs)
324-
, PP.indent 2 (ppPairs pendingPairs)
325-
, PP.pretty ("running:" :: String) <> PP.pretty (length (toListKeySet dirties))
326-
, PP.indent 2 (ppKeys (toListKeySet dirties))
327-
, PP.pretty ("blocked:" :: String) <> PP.pretty (length (toListKeySet blocked))
328-
, PP.indent 2 (ppKeys (toListKeySet blocked))
329-
]
330-
]
331-
pure $ renderString (PP.layoutPretty PP.defaultLayoutOptions doc)
332303

333304

334305

@@ -487,12 +458,68 @@ instance Exception AsyncParentKill where
487458
toException = asyncExceptionToException
488459
fromException = asyncExceptionFromException
489460

461+
462+
getBlockedBy :: Key -> Database -> STM [Key]
463+
getBlockedBy k Database{..} = do
464+
-- Determine the last known direct dependencies of k from its stored Result
465+
mKd <- SMap.lookup k databaseValues
466+
let deps = case mKd of
467+
Nothing -> mempty
468+
Just KeyDetails {keyStatus = st} ->
469+
let mRes = getResult st
470+
in maybe mempty (getResultDepsDefault mempty . resultDeps) mRes
471+
depList = filter (/= k) (toListKeySet deps)
472+
depStatuses <- forM depList $ \d -> SMap.lookup d databaseValues
473+
let isCleanDep = \case
474+
Just KeyDetails {keyStatus = Clean _} -> True
475+
_ -> False
476+
blocked = (filter (not . isCleanDep . snd) $ zip depList depStatuses)
477+
return $ fst <$> blocked
478+
479+
-- dump scheduler state
480+
dumpSchedulerState :: Database -> IO String
481+
dumpSchedulerState db@Database{..} = atomically $ do
482+
let SchedulerState{..} = databaseScheduler
483+
-- Snapshot queues (drain then restore) to avoid side effects
484+
ups <- flushTQueue schedulerUpsweepQueue
485+
ready <- flushTQueue schedulerRunningReady
486+
-- Snapshot sets and pending map
487+
dirties <- readTVar schedulerRunningDirties
488+
blocked <- readTVar schedulerRunningBlocked
489+
pendingPairs <- ListT.toList (SMap.listT schedulerRunningPending)
490+
origins <- readTVar schedulerRunningOrigins
491+
runningUnblocked <- mapM (\x ->
492+
do
493+
b <- getBlockedBy x db
494+
return (x, b)) $ toListKeySet $ dirties `differenceKeySet` blocked
495+
496+
let ppKey k = PP.pretty k
497+
ppKeys ks = if null ks then PP.brackets mempty else PP.vsep (map (\k -> PP.hsep [PP.pretty ("-" :: String), ppKey k]) ks)
498+
ppKeysWithDeps ks = if null ks then PP.brackets mempty else PP.vsep (map (\(k,bs) -> PP.hsep [PP.pretty ("-" :: String), ppKey k, PP.pretty ("blocked by:" :: String), PP.pretty (bs)]) ks)
499+
ppPairs xs = if null xs then PP.brackets mempty else PP.vsep (map (\(k,c) -> PP.hsep [PP.pretty ("-" :: String), ppKey k, PP.pretty (":" :: String), PP.pretty c]) xs)
500+
501+
doc = PP.vsep
502+
[ PP.pretty ("SchedulerState" :: String)
503+
, PP.indent 2 $ PP.vsep
504+
[ PP.pretty ("upsweep:" :: String) <> PP.pretty (length ups)
505+
, PP.indent 2 (ppKeys ups)
506+
, PP.pretty ("ready:" :: String) <> PP.pretty (length ready)
507+
, PP.indent 2 (ppKeys ready)
508+
, PP.pretty ("pending:" :: String) <> PP.pretty (length pendingPairs)
509+
, PP.indent 2 (ppPairs pendingPairs)
510+
, PP.pretty ("running:" :: String) <> PP.pretty (length runningUnblocked)
511+
, PP.indent 2 (ppKeysWithDeps (runningUnblocked))
512+
, PP.pretty ("blocked:" :: String) <> PP.pretty (length (toListKeySet blocked))
513+
, PP.indent 2 (ppKeys (toListKeySet $ blocked))
514+
, PP.pretty ("origins:" :: String) <> PP.pretty (length origins)
515+
, PP.indent 2 (ppKeys origins)
516+
]
517+
]
518+
pure $ renderString (PP.layoutPretty PP.defaultLayoutOptions doc)
519+
490520
shutDatabase ::Set (Async ()) -> Database -> IO ()
491521
shutDatabase preserve db@Database{..} = uninterruptibleMask $ \unmask -> do
492522
-- Dump scheduler state on shutdown for diagnostics
493-
let dumpPath = "scheduler.dump"
494-
dump <- dumpSchedulerState databaseScheduler
495-
writeFile dumpPath dump
496523
-- wait for all threads to finish
497524
asyncs <- readTVarIO databaseThreads
498525
step <- readTVarIO databaseStep

0 commit comments

Comments
 (0)