Skip to content

Commit e306f9d

Browse files
soulomoonsoulomoon
committed
Refactor Shake database handling and introduce locking mechanism for thread safety
1 parent 7bf6fde commit e306f9d

File tree

6 files changed

+158
-88
lines changed

6 files changed

+158
-88
lines changed

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

Lines changed: 40 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -154,7 +154,8 @@ import Development.IDE.Graph.Database (ShakeDatabase,
154154
import Development.IDE.Graph.Internal.Action (runActionInDbCb)
155155
import Development.IDE.Graph.Internal.Database (AsyncParentKill (AsyncParentKill))
156156
import Development.IDE.Graph.Internal.Types (DBQue, Step (..),
157-
getShakeStep)
157+
getShakeStep,
158+
withLockInShakeDatabase)
158159
import Development.IDE.Graph.Rule
159160
import Development.IDE.Types.Action
160161
import Development.IDE.Types.Diagnostics
@@ -615,7 +616,6 @@ data IdeState = IdeState
615616
}
616617

617618

618-
619619
-- This is debugging code that generates a series of profiles, if the Boolean is true
620620
shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath))
621621
shakeDatabaseProfileIO mbProfileDir = do
@@ -754,7 +754,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
754754
pure ShakeExtras{shakeRecorder = recorder, ..}
755755
shakeDb <-
756756
shakeNewDatabase
757-
shakeControlQueue
758757
opts { shakeExtra = newShakeExtra shakeExtras }
759758
rules
760759
shakeSession <- newEmptyMVar
@@ -912,43 +911,44 @@ runRestartTaskDyn recorder ideStateVar dy = runRestartTask recorder ideStateVar
912911
runRestartTask :: Recorder (WithPriority Log) -> MVar IdeState -> ShakeRestartArgs -> IO ()
913912
runRestartTask recorder ideStateVar shakeRestartArgs = do
914913
IdeState {shakeDb, shakeSession, shakeExtras, shakeDatabaseProfile} <- readMVar ideStateVar
915-
let prepareRestart sra@ShakeRestartArgs {..} = do
916-
keys <- sraBetweenSessions
917-
-- it is every important to update the dirty keys after we enter the critical section
918-
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
919-
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
920-
-- Check if there is another restart request pending, if so, we run that one too
921-
readAndGo sra sraShakeControlQueue
922-
readAndGo sra sraShakeControlQueue = do
923-
nextRestartArg <- atomically $ tryReadTaskQueue sraShakeControlQueue
924-
case nextRestartArg of
925-
Nothing -> return sra
926-
Just (Left dy) -> do
927-
res <- prepareRestart $ dynShakeRestart dy
928-
return $ sra <> res
929-
Just (Right _) -> readAndGo sra sraShakeControlQueue
930-
withMVar'
931-
shakeSession
932-
( \runner -> do
933-
-- takeShakeLock shakeDb
934-
(stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
935-
restartArgs <- prepareRestart shakeRestartArgs
936-
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
937-
res <- shakeDatabaseProfile shakeDb
938-
backlog <- readTVarIO $ dirtyKeys shakeExtras
939-
-- this log is required by tests
940-
step <- shakeGetBuildStep shakeDb
941-
logWith recorder Info $ LogBuildSessionRestart restartArgs queue backlog stopTime res step
942-
return restartArgs
943-
)
944-
-- It is crucial to be masked here, otherwise we can get killed
945-
-- between spawning the new thread and updating shakeSession.
946-
-- See https://github.com/haskell/ghcide/issues/79
947-
( \(ShakeRestartArgs {..}) ->
948-
do
949-
(,()) <$> newSession recorder shakeExtras sraVfs shakeDb sraActions sraReason
950-
`finally` for_ sraWaitMVars (`putMVar` ())
951-
)
914+
withLockInShakeDatabase shakeDb $ do
915+
let prepareRestart sra@ShakeRestartArgs {..} = do
916+
keys <- sraBetweenSessions
917+
-- it is every important to update the dirty keys after we enter the critical section
918+
-- see Note [Housekeeping rule cache and dirty key outside of hls-graph]
919+
atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys
920+
-- Check if there is another restart request pending, if so, we run that one too
921+
readAndGo sra sraShakeControlQueue
922+
readAndGo sra sraShakeControlQueue = do
923+
nextRestartArg <- atomically $ tryReadTaskQueue sraShakeControlQueue
924+
case nextRestartArg of
925+
Nothing -> return sra
926+
Just (Left dy) -> do
927+
res <- prepareRestart $ dynShakeRestart dy
928+
return $ sra <> res
929+
Just (Right _) -> readAndGo sra sraShakeControlQueue
930+
withMVar'
931+
shakeSession
932+
( \runner -> do
933+
-- takeShakeLock shakeDb
934+
(stopTime, ()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
935+
restartArgs <- prepareRestart shakeRestartArgs
936+
queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras
937+
res <- shakeDatabaseProfile shakeDb
938+
backlog <- readTVarIO $ dirtyKeys shakeExtras
939+
-- this log is required by tests
940+
step <- shakeGetBuildStep shakeDb
941+
logWith recorder Info $ LogBuildSessionRestart restartArgs queue backlog stopTime res step
942+
return restartArgs
943+
)
944+
-- It is crucial to be masked here, otherwise we can get killed
945+
-- between spawning the new thread and updating shakeSession.
946+
-- See https://github.com/haskell/ghcide/issues/79
947+
( \(ShakeRestartArgs {..}) ->
948+
do
949+
(,()) <$> newSession recorder shakeExtras sraVfs shakeDb sraActions sraReason
950+
`finally` for_ sraWaitMVars (`putMVar` ())
951+
)
952952
where
953953
logErrorAfter :: Seconds -> IO () -> IO ()
954954
logErrorAfter seconds action = flip withAsync (const action) $ do

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -35,11 +35,11 @@ data NonExportedType = NonExportedType
3535
shakeShutDatabase :: ShakeDatabase -> IO ()
3636
shakeShutDatabase (ShakeDatabase _ _ db) = shutDatabase db
3737

38-
shakeNewDatabase :: DBQue -> ShakeOptions -> Rules () -> IO ShakeDatabase
39-
shakeNewDatabase que opts rules = do
38+
shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase
39+
shakeNewDatabase opts rules = do
4040
let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts
4141
(theRules, actions) <- runRules extra rules
42-
db <- newDatabase que extra theRules
42+
db <- newDatabase extra theRules
4343
pure $ ShakeDatabase (length actions) actions db
4444

4545
shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [Either SomeException a]

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -59,22 +59,24 @@ parallel xs = do
5959
-- return ()
6060

6161
-- non-blocking version of runActionInDb
62+
-- inline
63+
{-# INLINE runActionInDbCb #-}
6264
runActionInDbCb :: (a -> String) -> (a -> Action result) -> STM a -> (Either SomeException result -> IO ()) -> Action a
6365
runActionInDbCb getTitle work getAct handler = do
6466
a <- Action ask
65-
liftIO $ atomicallyNamed "action queue - pop" $ do
66-
act <- getAct
67-
runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)]
68-
return act
67+
act <- liftIO $ atomicallyNamed "action queue - pop" getAct
68+
liftIO $ runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)]
69+
return act
6970

71+
-- inline
72+
{-# INLINE runActionInDb #-}
7073
runActionInDb :: String -> [Action a] -> Action [Either SomeException a]
7174
runActionInDb title acts = do
7275
a <- Action ask
7376
xs <- mapM (\x -> do
7477
barrier <- newEmptyTMVarIO
7578
return (x, barrier)) acts
76-
liftIO $ atomically $ runInDataBase title (actionDatabase a)
77-
(map (\(x, b) -> (ignoreState a x, atomically . putTMVar b)) xs)
79+
liftIO $ runInDataBase title (actionDatabase a) (map (\(x, b) -> (ignoreState a x, atomically . putTMVar b)) xs)
7880
results <- liftIO $ mapM (atomically . readTMVar) $ fmap snd xs
7981
return results
8082

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

Lines changed: 21 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import Development.IDE.Graph.Classes
3434
import Development.IDE.Graph.Internal.Key
3535
import Development.IDE.Graph.Internal.Rules
3636
import Development.IDE.Graph.Internal.Types
37+
import Development.IDE.WorkerThread (newDbLock)
3738
import qualified Focus
3839
import qualified ListT
3940
import qualified StmContainers.Map as SMap
@@ -46,11 +47,12 @@ import Data.List.NonEmpty (unzip)
4647
#endif
4748

4849

49-
newDatabase :: DBQue -> Dynamic -> TheRules -> IO Database
50-
newDatabase databaseQueue databaseExtra databaseRules = do
50+
newDatabase :: Dynamic -> TheRules -> IO Database
51+
newDatabase databaseExtra databaseRules = do
5152
databaseStep <- newTVarIO $ Step 0
5253
databaseThreads <- newTVarIO []
5354
databaseValues <- atomically SMap.new
55+
databaseLock <- newDbLock
5456
pure Database{..}
5557

5658
-- | Increment the step and mark dirty.
@@ -116,11 +118,11 @@ builder db stack keys = do
116118
data IsSingletonTask = IsSingleton | NotSingleton
117119
-- the first run should not block
118120
data RunFirst = RunFirst | RunLater deriving stock (Eq, Show)
119-
data BuildContinue = BCContinue (IO BuildContinue) | BCStop Key Result
121+
data BuildContinue = BCContinue (Maybe (IO ())) (IO BuildContinue) | BCStop Key Result
120122

121123
interpreBuildContinue :: BuildContinue -> IO (Key, Result)
122-
interpreBuildContinue (BCStop k v) = return (k, v)
123-
interpreBuildContinue (BCContinue ioR) = ioR >>= interpreBuildContinue
124+
interpreBuildContinue (BCStop k v) = return (k, v)
125+
interpreBuildContinue (BCContinue _ ioR) = ioR >>= interpreBuildContinue
124126

125127
builderOneCoroutine :: IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue
126128
builderOneCoroutine isSingletonTask db stack id =
@@ -129,7 +131,7 @@ builderOneCoroutine isSingletonTask db stack id =
129131
builderOneCoroutine' :: RunFirst -> IsSingletonTask -> Database -> Stack -> Key -> IO BuildContinue
130132
builderOneCoroutine' rf isSingletonTask db@Database {..} stack id = mask $ \restore -> do
131133
traceEvent ("builderOne: " ++ show id) return ()
132-
liftIO $ atomicallyNamed "builder" $ do
134+
r <- liftIO $ atomicallyNamed "builder" $ do
133135
-- Spawn the id if needed
134136
status <- SMap.lookup id databaseValues
135137
current <- readTVar databaseStep
@@ -139,23 +141,30 @@ builderOneCoroutine isSingletonTask db stack id =
139141
case isSingletonTask of
140142
IsSingleton ->
141143
return $
142-
BCContinue $ fmap (BCStop id) $
144+
BCContinue Nothing $ fmap (BCStop id) $
143145
restore (refresh db stack id s) `catch` \e@(SomeException _) -> do
144146
atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues
145147
throw e
146148
NotSingleton -> do
147-
traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) $
148-
runOneInDataBase (show id) db (refresh db stack id s) $
149-
\e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues
150-
return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id
149+
return $ BCContinue
150+
(Just $ traceEvent ("Starting build of key: " ++ show id ++ ", step " ++ show current) $
151+
runOneInDataBase (show id) db (refresh db stack id s) $
152+
\e -> atomically $ SMap.focus (updateStatus $ Exception current e s) id databaseValues)
153+
$ builderOneCoroutine' RunLater isSingletonTask db stack id
151154
Clean r -> return $ BCStop id r
152155
-- force here might contains async exceptions from previous runs
153156
Running _step _s
154157
| memberStack id stack -> throw $ StackException stack
155158
| otherwise -> if rf == RunFirst
156-
then return $ BCContinue $ builderOneCoroutine' RunLater isSingletonTask db stack id
159+
then return $ BCContinue Nothing $ builderOneCoroutine' RunLater isSingletonTask db stack id
157160
else retry
158161
Exception _ e _s -> throw e
162+
case r of
163+
BCContinue (Just mbAct) ioR -> do
164+
mbAct
165+
return $ BCContinue Nothing ioR
166+
_ -> return r
167+
159168

160169
-- | isDirty
161170
-- only dirty when it's build time is older than the changed time of one of its dependencies

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

Lines changed: 27 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -24,10 +24,11 @@ import Data.Typeable
2424
import Debug.Trace (traceEventIO, traceM)
2525
import Development.IDE.Graph.Classes
2626
import Development.IDE.Graph.Internal.Key
27-
import Development.IDE.WorkerThread (DeliverStatus (..),
28-
TaskQueue, counTaskQueue,
29-
runInThreadStmInNewThreads)
30-
import GHC.Conc (TVar, atomically)
27+
import Development.IDE.WorkerThread (DbLock, DeliverStatus (..),
28+
TaskQueue,
29+
runInThreadStmInNewThreads,
30+
withDbLocked)
31+
import GHC.Conc (TVar)
3132
import GHC.Generics (Generic)
3233
import qualified ListT
3334
import qualified StmContainers.Map as SMap
@@ -37,9 +38,9 @@ import UnliftIO (Async (asyncThreadId),
3738
MonadUnliftIO,
3839
asyncExceptionFromException,
3940
asyncExceptionToException,
40-
readTVar, readTVarIO,
41-
throwTo, waitCatch,
42-
withAsync)
41+
atomically, readTVar,
42+
readTVarIO, throwTo,
43+
waitCatch, withAsync)
4344
import UnliftIO.Concurrent (ThreadId, myThreadId)
4445

4546
#if !MIN_VERSION_base(4,18,0)
@@ -100,6 +101,11 @@ getDatabase = Action $ asks actionDatabase
100101

101102
data ShakeDatabase = ShakeDatabase !Int [Action ()] Database
102103

104+
withLockInShakeDatabase :: ShakeDatabase -> IO a -> IO a
105+
withLockInShakeDatabase (ShakeDatabase _ _ db) io =
106+
withDbLocked (databaseLock db) io
107+
108+
103109
newtype Step = Step Int
104110
deriving newtype (Eq,Ord,Hashable,Show)
105111

@@ -123,12 +129,14 @@ onKeyReverseDeps f it@KeyDetails{..} =
123129
it{keyReverseDeps = f keyReverseDeps}
124130

125131

132+
126133
type DBQue = TaskQueue (Either Dynamic (IO ()))
127134
data Database = Database {
128135
databaseExtra :: Dynamic,
129136

130137
databaseThreads :: TVar [Async ()],
131-
databaseQueue :: DBQue,
138+
-- databaseQueue :: DBQue,
139+
databaseLock :: DbLock,
132140

133141
databaseRules :: TheRules,
134142
databaseStep :: !(TVar Step),
@@ -138,20 +146,24 @@ data Database = Database {
138146

139147
databaseGetActionQueueLength :: Database -> STM Int
140148
databaseGetActionQueueLength db = do
141-
counTaskQueue (databaseQueue db)
149+
length <$> readTVar (databaseThreads db)
142150

143-
runInDataBase :: String -> Database -> [(IO result, Either SomeException result -> IO ())] -> STM ()
151+
-- inline
152+
{-# INLINE runInDataBase #-}
153+
runInDataBase :: String -> Database -> [(IO result, Either SomeException result -> IO ())] -> IO ()
144154
runInDataBase title db acts = do
145-
s <- getDataBaseStepInt db
146-
runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseQueue db) (databaseThreads db) acts
155+
s <- atomically $ getDataBaseStepInt db
156+
runInThreadStmInNewThreads (getDataBaseStepInt db) (DeliverStatus s title) (databaseLock db) (databaseThreads db) acts
147157

148-
runOneInDataBase :: String -> Database -> IO result -> (SomeException -> IO ()) -> STM ()
158+
-- inline
159+
{-# INLINE runOneInDataBase #-}
160+
runOneInDataBase :: String -> Database -> IO result -> (SomeException -> IO ()) -> IO ()
149161
runOneInDataBase title db act handler = do
150-
s <- getDataBaseStepInt db
162+
s <- atomically $ getDataBaseStepInt db
151163
runInThreadStmInNewThreads
152164
(getDataBaseStepInt db)
153165
(DeliverStatus s title)
154-
(databaseQueue db)
166+
(databaseLock db)
155167
(databaseThreads db)
156168
[ ( act,
157169
\case

0 commit comments

Comments
 (0)