Skip to content

Commit 700171c

Browse files
pepeiborrapepeiborra
committed
Introduce strict versions of modifyVar
These strict versions enforce a new pattern: evaluate outside the lock This minimizes the time the lock is held and should help with contention
1 parent 05f25c9 commit 700171c

File tree

12 files changed

+95
-66
lines changed

12 files changed

+95
-66
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,6 +136,7 @@ library
136136
include-dirs:
137137
include
138138
exposed-modules:
139+
Control.Concurrent.Strict
139140
Development.IDE
140141
Development.IDE.Main
141142
Development.IDE.Core.Debouncer

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

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ module Development.IDE.Session
2020
-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!
2121

2222
import Control.Concurrent.Async
23-
import Control.Concurrent.Extra
23+
import Control.Concurrent.Strict
2424
import Control.Exception.Safe
2525
import Control.Monad
2626
import Control.Monad.Extra
@@ -213,7 +213,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
213213
version <- newVar 0
214214
let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
215215
let invalidateShakeCache = do
216-
modifyVar_ version (return . succ)
216+
void $ modifyVar' version succ
217217
-- This caches the mapping from Mod.hs -> hie.yaml
218218
cradleLoc <- liftIO $ memoIO $ \v -> do
219219
res <- findCradle v
@@ -246,12 +246,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
246246
TargetModule _ -> do
247247
found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
248248
return (targetTarget, found)
249-
modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
249+
modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do
250250
let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
251251
when (known /= known') $
252252
logDebug logger $ "Known files updated: " <>
253253
T.pack(show $ (HM.map . map) fromNormalizedFilePath known')
254-
evaluate known'
254+
pure known'
255255

256256
-- Create a new HscEnv from a hieYaml root and a set of options
257257
-- If the hieYaml file already has an HscEnv, the new component is
@@ -364,12 +364,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
364364

365365
let all_targets = cs ++ cached_targets
366366

367-
modifyVar_ fileToFlags $ \var -> do
368-
pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var
369-
modifyVar_ filesMap $ \var -> do
370-
evaluate $ HM.union var (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
367+
void $ modifyVar' fileToFlags $
368+
Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets))
369+
void $ modifyVar' filesMap $
370+
flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
371371

372-
extendKnownTargets all_targets
372+
void $ extendKnownTargets all_targets
373373

374374
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
375375
invalidateShakeCache
@@ -427,10 +427,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
427427
dep_info <- getDependencyInfo (maybeToList hieYaml)
428428
let ncfp = toNormalizedFilePath' cfp
429429
let res = (map (renderCradleError ncfp) err, Nothing)
430-
modifyVar_ fileToFlags $ \var -> do
431-
pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
432-
modifyVar_ filesMap $ \var -> do
433-
evaluate $ HM.insert ncfp hieYaml var
430+
void $ modifyVar' fileToFlags $
431+
Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))
432+
void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
434433
return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
435434

436435
-- This caches the mapping from hie.yaml + Mod.hs -> [String]

‎ghcide/src/Control/Concurrent/Strict.hs

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
module Control.Concurrent.Strict
2+
(modifyVar', modifyVarIO'
3+
,modifyVar, modifyVar_
4+
,module Control.Concurrent.Extra
5+
) where
6+
7+
import Control.Concurrent.Extra hiding (modifyVar, modifyVar_)
8+
import qualified Control.Concurrent.Extra as Extra
9+
import Control.Exception (evaluate)
10+
import Data.Tuple.Extra (dupe)
11+
import Control.Monad (void)
12+
13+
-- | Strict modification that returns the new value
14+
modifyVar' :: Var a -> (a -> a) -> IO a
15+
modifyVar' var upd = modifyVarIO' var (pure . upd)
16+
17+
-- | Strict modification that returns the new value
18+
modifyVarIO' :: Var a -> (a -> IO a) -> IO a
19+
modifyVarIO' var upd = do
20+
res <- Extra.modifyVar var $ \v -> do
21+
v' <- upd v
22+
pure $ dupe v'
23+
evaluate res
24+
25+
modifyVar :: Var a -> (a -> IO (a, b)) -> IO b
26+
modifyVar var upd = do
27+
(new, res) <- Extra.modifyVar var $ \old -> do
28+
(new,res) <- upd old
29+
return (new, (new, res))
30+
void $ evaluate new
31+
return res
32+
33+
modifyVar_ :: Var a -> (a -> IO a) -> IO ()
34+
modifyVar_ var upd = void $ modifyVarIO' var upd

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

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,12 @@ module Development.IDE.Core.Debouncer
99
) where
1010

1111
import Control.Concurrent.Async
12-
import Control.Concurrent.Extra
12+
import Control.Concurrent.Strict
1313
import Control.Exception
1414
import Control.Monad.Extra
15-
import Data.HashMap.Strict (HashMap)
16-
import qualified Data.HashMap.Strict as Map
15+
import Data.Foldable (traverse_)
16+
import Data.HashMap.Strict (HashMap)
17+
import qualified Data.HashMap.Strict as Map
1718
import Data.Hashable
1819
import System.Time.Extra
1920

@@ -40,17 +41,14 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
4041
-- to mask if required.
4142
asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
4243
asyncRegisterEvent d 0 k fire = do
43-
modifyVar_ d $ \m -> mask_ $ do
44-
whenJust (Map.lookup k m) cancel
45-
pure $ Map.delete k m
44+
void $ modifyVarIO' d $ mask_ . Map.alterF (\prev -> traverse_ cancel prev >> pure Nothing) k
4645
fire
47-
asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
48-
whenJust (Map.lookup k m) cancel
46+
asyncRegisterEvent d delay k fire = mask_ $ do
4947
a <- asyncWithUnmask $ \unmask -> unmask $ do
5048
sleep delay
5149
fire
52-
modifyVar_ d (pure . Map.delete k)
53-
pure $ Map.insert k a m
50+
void $ modifyVar' d (Map.delete k)
51+
void $ modifyVarIO' d $ Map.alterF (\prev -> traverse_ cancel prev >> pure (Just a)) k
5452

5553
-- | Debouncer used in the DAML CLI compiler that emits events immediately.
5654
noopDebouncer :: Debouncer k

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ module Development.IDE.Core.FileExists
1010
)
1111
where
1212

13-
import Control.Concurrent.Extra
13+
import Control.Concurrent.Strict
1414
import Control.Exception
1515
import Control.Monad.Extra
1616
import qualified Data.ByteString as BS
@@ -98,7 +98,7 @@ modifyFileExists state changes = do
9898
-- Masked to ensure that the previous values are flushed together with the map update
9999
mask $ \_ -> do
100100
-- update the map
101-
modifyVar_ var $ evaluate . HashMap.union changesMap
101+
void $ modifyVar' var $ HashMap.union changesMap
102102
-- See Note [Invalidating file existence results]
103103
-- flush previous values
104104
mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap)

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -22,9 +22,9 @@ module Development.IDE.Core.FileStore(
2222
getFileContentsImpl
2323
) where
2424

25-
import Control.Concurrent.Extra
2625
import Control.Concurrent.STM (atomically)
2726
import Control.Concurrent.STM.TQueue (writeTQueue)
27+
import Control.Concurrent.Strict
2828
import Control.Exception
2929
import Control.Monad.Extra
3030
import qualified Data.ByteString as BS
@@ -85,7 +85,7 @@ makeVFSHandle = do
8585
(_nextVersion, vfs) <- readVar vfsVar
8686
pure $ Map.lookup uri vfs
8787
, setVirtualFileContents = Just $ \uri content ->
88-
modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
88+
void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $
8989
case content of
9090
Nothing -> Map.delete uri vfs
9191
-- The second version number is only used in persistFileVFS which we do not use so we set it to 0.

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ module Development.IDE.Core.IdeConfiguration
1212
)
1313
where
1414

15-
import Control.Concurrent.Extra
15+
import Control.Concurrent.Strict
1616
import Control.Monad
1717
import Data.Aeson.Types (Value)
1818
import Data.HashSet (HashSet, singleton)
@@ -73,7 +73,7 @@ modifyIdeConfiguration
7373
:: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
7474
modifyIdeConfiguration ide f = do
7575
IdeConfigurationVar var <- getIdeGlobalState ide
76-
modifyVar_ var (pure . f)
76+
void $ modifyVar' var f
7777

7878
isWorkspaceFile :: NormalizedFilePath -> Action Bool
7979
isWorkspaceFile file =

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

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ module Development.IDE.Core.OfInterest(
1313
OfInterestVar(..)
1414
) where
1515

16-
import Control.Concurrent.Extra
16+
import Control.Concurrent.Strict
1717
import Control.DeepSeq
1818
import Control.Exception
1919
import Control.Monad
@@ -22,7 +22,6 @@ import Data.HashMap.Strict (HashMap)
2222
import qualified Data.HashMap.Strict as HashMap
2323
import Data.Hashable
2424
import qualified Data.Text as T
25-
import Data.Tuple.Extra
2625
import Data.Typeable
2726
import Development.Shake
2827
import GHC.Generics
@@ -87,7 +86,7 @@ modifyFilesOfInterest
8786
-> IO ()
8887
modifyFilesOfInterest state f = do
8988
OfInterestVar var <- getIdeGlobalState state
90-
files <- modifyVar var $ pure . dupe . f
89+
files <- modifyVar' var f
9190
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)
9291

9392
-- | Typecheck all the files of interest.
@@ -114,7 +113,7 @@ kick = do
114113
let mguts = catMaybes results
115114
!exportsMap' = createExportsMapMg mguts
116115
!exportsMap'' = maybe mempty createExportsMap ifaces
117-
liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap'' <>) . (exportsMap' <>)
116+
void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>)
118117

119118
liftIO $ progressUpdate KickCompleted
120119

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint
133133
import Development.IDE.Types.HscEnvEq
134134
import Development.Shake.Classes hiding (get, put)
135135

136-
import Control.Concurrent.Extra
136+
import Control.Concurrent.Strict
137137
import Control.Monad.State
138138
import Data.ByteString.Encoding as T
139139
import Data.Coerce
@@ -947,7 +947,7 @@ getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do
947947
-- Record the linkable so we know not to unload it
948948
whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do
949949
compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
950-
liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time
950+
liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
951951
pure res
952952

953953
getModIfaceWithoutLinkableRule :: Rules ()

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

Lines changed: 27 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -77,8 +77,8 @@ module Development.IDE.Core.Shake(
7777
) where
7878

7979
import Control.Concurrent.Async
80-
import Control.Concurrent.Extra
8180
import Control.Concurrent.STM
81+
import Control.Concurrent.Strict
8282
import Control.DeepSeq
8383
import Control.Monad.Extra
8484
import Control.Monad.IO.Class
@@ -247,9 +247,7 @@ getPluginConfig extras plugin = do
247247
addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
248248
addPersistentRule k getVal = do
249249
ShakeExtras{persistentKeys} <- getShakeExtrasRules
250-
liftIO $ modifyVar_ persistentKeys $ \hm -> do
251-
pure $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) hm
252-
return ()
250+
void $ liftIO $ modifyVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
253251

254252
class Typeable a => IsIdeGlobal a where
255253

@@ -273,7 +271,7 @@ addIdeGlobal x = do
273271

274272
addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
275273
addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
276-
liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
274+
void $ liftIO $ modifyVarIO' globals $ \mp -> case HMap.lookup ty mp of
277275
Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
278276
Nothing -> return $! HMap.insert ty (toDyn x) mp
279277

@@ -325,10 +323,13 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
325323
f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
326324
(dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
327325
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
328-
modifyVar state $ \hm -> pure $ case mv of
329-
Nothing -> (HMap.alter (alterValue $ Failed True) (file,Key k) hm,Nothing)
330-
Just (v,del,ver) -> (HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) hm
331-
,Just (v,addDelta del $ mappingForVersion allMappings file ver))
326+
case mv of
327+
Nothing -> do
328+
void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k)
329+
return Nothing
330+
Just (v,del,ver) -> do
331+
void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k)
332+
return $ Just (v,addDelta del $ mappingForVersion allMappings file ver)
332333

333334
-- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
334335
alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics
@@ -416,9 +417,9 @@ setValues :: IdeRule k v
416417
-> Value v
417418
-> Vector FileDiagnostic
418419
-> IO ()
419-
setValues state key file val diags = modifyVar_ state $ \vals -> do
420-
-- Force to make sure the old HashMap is not retained
421-
evaluate $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) vals
420+
setValues state key file val diags =
421+
void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags)
422+
422423

423424
-- | Delete the value stored for a given ide build key
424425
deleteValue
@@ -427,8 +428,7 @@ deleteValue
427428
-> k
428429
-> NormalizedFilePath
429430
-> IO ()
430-
deleteValue ShakeExtras{state} key file = modifyVar_ state $ \vals ->
431-
evaluate $ HMap.delete (file, Key key) vals
431+
deleteValue ShakeExtras{state} key file = void $ modifyVar' state $ HMap.delete (file, Key key)
432432

433433
-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
434434
getValues ::
@@ -783,17 +783,15 @@ garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
783783
garbageCollect keep = do
784784
ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
785785
liftIO $
786-
do newState <- modifyVar state $ \values -> do
787-
values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
788-
return $! dupe values
789-
modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
790-
modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
791-
modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
786+
do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file)
787+
void $ modifyVar' diagnostics $ filterDiagnostics keep
788+
void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep
789+
void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri))
792790
let versionsForFile =
793791
HMap.fromListWith Set.union $
794792
mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
795793
HMap.toList newState
796-
modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
794+
void $ modifyVar' positionMapping $ filterVersionMap versionsForFile
797795

798796
-- | Define a new Rule without early cutoff
799797
define
@@ -994,7 +992,7 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do
994992
-- This functions are deliberately eta-expanded to avoid space leaks.
995993
-- Do not remove the eta-expansion without profiling a session with at
996994
-- least 1000 modifications.
997-
where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x
995+
where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0)
998996

999997
isSuccess :: RunResult (A v) -> Bool
1000998
isSuccess (RunResult _ _ (A Failed{})) = False
@@ -1086,17 +1084,17 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p
10861084
let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
10871085
uri = filePathToUri' fp
10881086
ver = vfsVersion =<< modTime
1089-
updateDiagnosticsWithForcing new store = do
1090-
store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store
1091-
new' <- evaluate $ getUriDiagnostics uri store'
1092-
return (store', new')
1087+
update new store =
1088+
let store' = setStageDiagnostics uri ver (T.pack $ show k) new store
1089+
new' = getUriDiagnostics uri store'
1090+
in (store', new')
10931091
mask_ $ do
10941092
-- Mask async exceptions to ensure that updated diagnostics are always
10951093
-- published. Otherwise, we might never publish certain diagnostics if
10961094
-- an exception strikes between modifyVar but before
10971095
-- publishDiagnosticsNotification.
1098-
newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown
1099-
_ <- modifyVar hiddenDiagnostics $ updateDiagnosticsWithForcing $ map snd currentHidden
1096+
newDiags <- modifyVar diagnostics $ pure . update (map snd currentShown)
1097+
_ <- modifyVar hiddenDiagnostics $ pure . update (map snd currentHidden)
11001098
let uri = filePathToUri' fp
11011099
let delay = if null newDiags then 0.1 else 0
11021100
registerEvent debouncer delay uri $ do
@@ -1181,6 +1179,6 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi
11811179
Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
11821180
zeroMapping
11831181
(Map.insert _version (shared_change, zeroMapping) mappingForUri)
1184-
pure $! HMap.insert uri updatedMapping allMappings
1182+
pure $ HMap.insert uri updatedMapping allMappings
11851183
where
11861184
shared_change = mkDelta changes

‎ghcide/src/Development/IDE/GHC/Warnings.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import Data.List
88
import ErrUtils
99
import GhcPlugins as GHC hiding (Var, (<>))
1010

11-
import Control.Concurrent.Extra
11+
import Control.Concurrent.Strict
1212
import qualified Data.Text as T
1313

1414
import Development.IDE.GHC.Error

0 commit comments

Comments
 (0)