Skip to content

Commit 7d3a283

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 7d3a283

File tree

12 files changed

+106
-65
lines changed

12 files changed

+106
-65
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: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,6 +65,7 @@ import qualified System.Posix.Error as Posix
6565

6666
import qualified Development.IDE.Types.Logger as L
6767

68+
<<<<<<< HEAD
6869
import qualified Data.Binary as B
6970
import qualified Data.ByteString.Lazy as LBS
7071
import Language.LSP.Server hiding
@@ -76,6 +77,17 @@ import Language.LSP.Types (FileChangeType (F
7677
uriToFilePath)
7778
import Language.LSP.VFS
7879
import System.FilePath
80+
=======
81+
import Language.LSP.Server hiding (getVirtualFile)
82+
import qualified Language.LSP.Server as LSP
83+
import Language.LSP.VFS
84+
import Language.LSP.Types (FileEvent(FileEvent), FileChangeType (FcChanged), uriToFilePath, toNormalizedFilePath)
85+
import System.FilePath
86+
import Data.Bifunctor
87+
import Data.Binary (encode)
88+
import qualified Data.ByteString.Lazy as LBS
89+
import Control.Concurrent.Strict (modifyVar')
90+
>>>>>>> bece1891... Consistently evaluate outside the lock
7991

8092
makeVFSHandle :: IO VFSHandle
8193
makeVFSHandle = do
@@ -85,7 +97,7 @@ makeVFSHandle = do
8597
(_nextVersion, vfs) <- readVar vfsVar
8698
pure $ Map.lookup uri vfs
8799
, setVirtualFileContents = Just $ \uri content ->
88-
modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
100+
void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $
89101
case content of
90102
Nothing -> Map.delete uri vfs
91103
-- 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 ()

0 commit comments

Comments
 (0)