Skip to content

Commit aeb3190

Browse files
pepeiborrapepeiborra
committed
switch to TVar
1 parent 955f63d commit aeb3190

File tree

5 files changed

+32
-30
lines changed

5 files changed

+32
-30
lines changed

‎ghcide/session-loader/Development/IDE/Session.hs

+11-9
Original file line numberDiff line numberDiff line change
@@ -75,12 +75,11 @@ import System.Info
7575
import Control.Applicative (Alternative ((<|>)))
7676
import Data.Void
7777

78-
import Control.Concurrent.STM (atomically)
78+
import Control.Concurrent.STM.Stats (atomically, modifyTVar',
79+
readTVar, writeTVar)
7980
import Control.Concurrent.STM.TQueue
8081
import Data.Foldable (for_)
8182
import qualified Data.HashSet as Set
82-
import Data.IORef.Extra (atomicModifyIORef'_)
83-
import Data.Tuple (swap)
8483
import Database.SQLite.Simple
8584
import Development.IDE.Core.Tracing (withTrace)
8685
import HieDb.Create
@@ -266,11 +265,14 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
266265
TargetModule _ -> do
267266
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
268267
return (targetTarget, found)
269-
atomically $ recordDirtyKeys extras GetKnownTargets [emptyFilePath]
270-
hasUpdate <- atomicModifyIORef' knownTargetsVar $ (swap .) $ traverseHashed $ \known -> do
271-
let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets
272-
hasUpdate = if known /= known' then Just known' else Nothing
273-
(hasUpdate, known')
268+
hasUpdate <- join $ atomically $ do
269+
known <- readTVar knownTargetsVar
270+
let known' = flip mapHashed known $ \k ->
271+
HM.unionWith (<>) k $ HM.fromList $ map (second Set.fromList) knownTargets
272+
hasUpdate = if known /= known' then Just (unhashed known') else Nothing
273+
writeTVar knownTargetsVar known'
274+
logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]
275+
return (logDirtyKeys >> pure hasUpdate)
274276
for_ hasUpdate $ \x ->
275277
logDebug logger $ "Known files updated: " <>
276278
T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x)
@@ -407,7 +409,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
407409
-- update exports map
408410
extras <- getShakeExtras
409411
let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
410-
liftIO $ atomicModifyIORef'_ (exportsMap extras) $ (exportsMap' <>)
412+
liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>)
411413

412414
return (second Map.keys res)
413415

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

+3-3
Original file line numberDiff line numberDiff line change
@@ -25,9 +25,9 @@ import qualified Data.HashMap.Strict as HashMap
2525
import qualified Data.Text as T
2626
import Development.IDE.Graph
2727

28-
import Control.Concurrent.STM.Stats (atomically)
28+
import Control.Concurrent.STM.Stats (atomically,
29+
modifyTVar')
2930
import qualified Data.ByteString as BS
30-
import Data.IORef.Extra (atomicModifyIORef'_)
3131
import Data.Maybe (catMaybes)
3232
import Development.IDE.Core.ProgressReporting
3333
import Development.IDE.Core.RuleTypes
@@ -115,7 +115,7 @@ kick = do
115115
-- Update the exports map
116116
results <- uses GenerateCore files <* uses GetHieAst files
117117
let mguts = catMaybes results
118-
void $ liftIO $ atomicModifyIORef'_ exportsMap (updateExportsMapMg mguts)
118+
void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts)
119119

120120
liftIO $ progressUpdate progress KickCompleted
121121

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

+14-15
Original file line numberDiff line numberDiff line change
@@ -156,7 +156,6 @@ import Data.Default
156156
import Data.Foldable (toList)
157157
import Data.HashSet (HashSet)
158158
import qualified Data.HashSet as HSet
159-
import Data.IORef.Extra (atomicModifyIORef'_)
160159
import Data.String (fromString)
161160
import Data.Text (pack)
162161
import Debug.Trace.Flags (userTracingEnabled)
@@ -190,7 +189,7 @@ data ShakeExtras = ShakeExtras
190189
lspEnv :: Maybe (LSP.LanguageContextEnv Config)
191190
,debouncer :: Debouncer NormalizedUri
192191
,logger :: Logger
193-
,globals :: IORef (HMap.HashMap TypeRep Dynamic)
192+
,globals :: TVar (HMap.HashMap TypeRep Dynamic)
194193
,state :: Values
195194
,diagnostics :: STMDiagnosticStore
196195
,hiddenDiagnostics :: STMDiagnosticStore
@@ -211,15 +210,15 @@ data ShakeExtras = ShakeExtras
211210
-> IO ()
212211
,ideNc :: IORef NameCache
213212
-- | A mapping of module name to known target (or candidate targets, if missing)
214-
,knownTargetsVar :: IORef (Hashed KnownTargets)
213+
,knownTargetsVar :: TVar (Hashed KnownTargets)
215214
-- | A mapping of exported identifiers for local modules. Updated on kick
216-
,exportsMap :: IORef ExportsMap
215+
,exportsMap :: TVar ExportsMap
217216
-- | A work queue for actions added via 'runInShakeSession'
218217
,actionQueue :: ActionQueue
219218
,clientCapabilities :: ClientCapabilities
220219
, hiedb :: HieDb -- ^ Use only to read.
221220
, hiedbWriter :: HieDbWriter -- ^ use to write
222-
, persistentKeys :: IORef (HMap.HashMap Key GetStalePersistent)
221+
, persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)
223222
-- ^ Registery for functions that compute/get "stale" results for the rule
224223
-- (possibly from disk)
225224
, vfs :: VFSHandle
@@ -259,7 +258,7 @@ getPluginConfig plugin = do
259258
addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
260259
addPersistentRule k getVal = do
261260
ShakeExtras{persistentKeys} <- getShakeExtrasRules
262-
void $ liftIO $ atomicModifyIORef'_ persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
261+
void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
263262

264263
class Typeable a => IsIdeGlobal a where
265264

@@ -283,15 +282,15 @@ addIdeGlobal x = do
283282

284283
addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
285284
addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
286-
void $ liftIO $ atomicModifyIORef'_ globals $ \mp -> case HMap.lookup ty mp of
285+
void $ liftIO $ atomically $ modifyTVar' globals $ \mp -> case HMap.lookup ty mp of
287286
Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
288287
Nothing -> HMap.insert ty (toDyn x) mp
289288

290289

291290
getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
292291
getIdeGlobalExtras ShakeExtras{globals} = do
293292
let typ = typeRep (Proxy :: Proxy a)
294-
x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readIORef globals
293+
x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals
295294
case x of
296295
Just x
297296
| Just x <- fromDynamic x -> pure x
@@ -334,7 +333,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
334333
| IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests
335334
, testing = pure Nothing
336335
| otherwise = do
337-
pmap <- readIORef persistentKeys
336+
pmap <- readTVarIO persistentKeys
338337
mv <- runMaybeT $ do
339338
liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k
340339
f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
@@ -478,7 +477,7 @@ getValues state key file = do
478477
knownTargets :: Action (Hashed KnownTargets)
479478
knownTargets = do
480479
ShakeExtras{knownTargetsVar} <- getShakeExtras
481-
liftIO $ readIORef knownTargetsVar
480+
liftIO $ readTVarIO knownTargetsVar
482481

483482
-- | Seq the result stored in the Shake value. This only
484483
-- evaluates the value to WHNF not NF. We take care of the latter
@@ -509,25 +508,25 @@ shakeOpen lspEnv defaultConfig logger debouncer
509508
us <- mkSplitUniqSupply 'r'
510509
ideNc <- newIORef (initNameCache us knownKeyNames)
511510
shakeExtras <- do
512-
globals <- newIORef HMap.empty
511+
globals <- newTVarIO HMap.empty
513512
state <- STM.newIO
514513
diagnostics <- STM.newIO
515514
hiddenDiagnostics <- STM.newIO
516515
publishedDiagnostics <- STM.newIO
517516
positionMapping <- STM.newIO
518-
knownTargetsVar <- newIORef $ hashed HMap.empty
517+
knownTargetsVar <- newTVarIO $ hashed HMap.empty
519518
let restartShakeSession = shakeRestart ideState
520-
persistentKeys <- newIORef HMap.empty
519+
persistentKeys <- newTVarIO HMap.empty
521520
indexPending <- newTVarIO HMap.empty
522521
indexCompleted <- newTVarIO 0
523522
indexProgressToken <- newVar Nothing
524523
let hiedbWriter = HieDbWriter{..}
525-
exportsMap <- newIORef mempty
524+
exportsMap <- newTVarIO mempty
526525
-- lazily initialize the exports map with the contents of the hiedb
527526
_ <- async $ do
528527
logDebug logger "Initializing exports map from hiedb"
529528
em <- createExportsMapHieDb hiedb
530-
atomicModifyIORef'_ exportsMap (<> em)
529+
atomically $ modifyTVar' exportsMap (<> em)
531530
logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"
532531

533532
progress <- do

‎ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Development.IDE.Plugin.CodeAction.Args
1414
)
1515
where
1616

17+
import Control.Concurrent.STM.Stats (readTVarIO)
1718
import Control.Monad.Reader
1819
import Control.Monad.Trans.Maybe
1920
import Data.Either (fromRight)
@@ -58,7 +59,7 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
5859
runRule GhcSession >>= \case
5960
Just env -> do
6061
pkgExports <- envPackageExports env
61-
localExports <- readIORef (exportsMap $ shakeExtras state)
62+
localExports <- readTVarIO (exportsMap $ shakeExtras state)
6263
pure $ localExports <> pkgExports
6364
_ -> pure mempty
6465
caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions

‎ghcide/src/Development/IDE/Plugin/Completions.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -8,13 +8,13 @@ module Development.IDE.Plugin.Completions
88
) where
99

1010
import Control.Concurrent.Async (concurrently)
11+
import Control.Concurrent.STM.Stats (readTVarIO)
1112
import Control.Monad.Extra
1213
import Control.Monad.IO.Class
1314
import Control.Monad.Trans.Maybe
1415
import Data.Aeson
1516
import qualified Data.HashMap.Strict as Map
1617
import qualified Data.HashSet as Set
17-
import Data.IORef (readIORef)
1818
import Data.List (find)
1919
import Data.Maybe
2020
import qualified Data.Text as T
@@ -138,7 +138,7 @@ getCompletionsLSP ide plId
138138
-- set up the exports map including both package and project-level identifiers
139139
packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath
140140
packageExportsMap <- mapM liftIO packageExportsMapIO
141-
projectExportsMap <- liftIO $ readIORef (exportsMap $ shakeExtras ide)
141+
projectExportsMap <- liftIO $ readTVarIO (exportsMap $ shakeExtras ide)
142142
let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap
143143

144144
let moduleExports = getModuleExportsMap exportsMap

0 commit comments

Comments
 (0)