Introduce strict versions of modifyVar to improve contention

ghcide/ghcide.cabal

@@ -136,6 +136,7 @@ library
     include-dirs:
         include
     exposed-modules:
+        Control.Concurrent.Strict
         Development.IDE
         Development.IDE.Main
         Development.IDE.Core.Debouncer

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

@@ -20,7 +20,7 @@ module Development.IDE.Session
 -- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!
 
 import           Control.Concurrent.Async
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.Extra
@@ -213,7 +213,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
   version <- newVar 0
   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
   let invalidateShakeCache = do
-        modifyVar_ version (return . succ)
+        void $ modifyVar' version succ
   -- This caches the mapping from Mod.hs -> hie.yaml
   cradleLoc <- liftIO $ memoIO $ \v -> do
       res <- findCradle v
@@ -246,12 +246,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
                 return (targetTarget, found)
-          modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
+          modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do
             let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
             when (known /= known') $
                 logDebug logger $ "Known files updated: " <>
                     T.pack(show $ (HM.map . map) fromNormalizedFilePath known')
-            evaluate known'
+            pure known'
 
     -- Create a new HscEnv from a hieYaml root and a set of options
     -- If the hieYaml file already has an HscEnv, the new component is
@@ -364,12 +364,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 
           let all_targets = cs ++ cached_targets
 
-          modifyVar_ fileToFlags $ \var -> do
-              pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var
-          modifyVar_ filesMap $ \var -> do
-              evaluate $ HM.union var (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
+          void $ modifyVar' fileToFlags $
+              Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets))
+          void $ modifyVar' filesMap $
+              flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
 
-          extendKnownTargets all_targets
+          void $ extendKnownTargets all_targets
 
           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
           invalidateShakeCache
@@ -427,10 +427,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
                dep_info <- getDependencyInfo (maybeToList hieYaml)
                let ncfp = toNormalizedFilePath' cfp
                let res = (map (renderCradleError ncfp) err, Nothing)
-               modifyVar_ fileToFlags $ \var -> do
-                 pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
-               modifyVar_ filesMap $ \var -> do
-                 evaluate $ HM.insert ncfp hieYaml var
+               void $ modifyVar' fileToFlags $
+                    Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info))
+               void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
                return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
 
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]

ghcide/src/Control/Concurrent/Strict.hs

@@ -0,0 +1,34 @@
+module Control.Concurrent.Strict
+    (modifyVar', modifyVarIO'
+    ,modifyVar, modifyVar_
+    ,module Control.Concurrent.Extra
+    ) where
+
+import Control.Concurrent.Extra hiding (modifyVar, modifyVar_)
+import qualified Control.Concurrent.Extra as Extra
+import Control.Exception (evaluate)
+import Data.Tuple.Extra (dupe)
+import Control.Monad (void)
+
+-- | Strict modification that returns the new value
+modifyVar' :: Var a -> (a -> a) -> IO a
+modifyVar' var upd = modifyVarIO' var (pure . upd)
+
+-- | Strict modification that returns the new value
+modifyVarIO' :: Var a -> (a -> IO a) -> IO a
+modifyVarIO' var upd = do
+    res <- Extra.modifyVar var $ \v -> do
+        v' <- upd v
+        pure $ dupe v'
+    evaluate res
+
+modifyVar :: Var a -> (a -> IO (a, b)) -> IO b
+modifyVar var upd = do
+    (new, res) <- Extra.modifyVar var $ \old -> do
+        (new,res) <- upd old
+        return (new, (new, res))
+    void $ evaluate new
+    return res
+
+modifyVar_ :: Var a -> (a -> IO a) -> IO ()
+modifyVar_ var upd = void $ modifyVarIO' var upd

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

@@ -9,7 +9,7 @@ module Development.IDE.Core.Debouncer
     ) where
 
 import           Control.Concurrent.Async
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.Exception
 import           Control.Monad            (join)
 import           Data.Foldable            (traverse_)

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

@@ -10,7 +10,7 @@ module Development.IDE.Core.FileExists
   )
 where
 
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.Exception
 import           Control.Monad.Extra
 import qualified Data.ByteString                       as BS
@@ -98,7 +98,7 @@ modifyFileExists state changes = do
   -- Masked to ensure that the previous values are flushed together with the map update
   mask $ \_ -> do
     -- update the map
-    modifyVar_ var $ evaluate . HashMap.union changesMap
+    void $ modifyVar' var $ HashMap.union changesMap
     -- See Note [Invalidating file existence results]
     -- flush previous values
     mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap)

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

@@ -22,9 +22,9 @@ module Development.IDE.Core.FileStore(
     getFileContentsImpl
     ) where
 
-import           Control.Concurrent.Extra
 import           Control.Concurrent.STM                       (atomically)
 import           Control.Concurrent.STM.TQueue                (writeTQueue)
+import           Control.Concurrent.Strict
 import           Control.Exception
 import           Control.Monad.Extra
 import qualified Data.ByteString                              as BS
@@ -85,7 +85,7 @@ makeVFSHandle = do
               (_nextVersion, vfs) <- readVar vfsVar
               pure $ Map.lookup uri vfs
         , setVirtualFileContents = Just $ \uri content ->
-              modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
+              void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $
                   case content of
                     Nothing -> Map.delete uri vfs
                     -- 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

@@ -12,7 +12,7 @@ module Development.IDE.Core.IdeConfiguration
   )
 where
 
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.Monad
 import           Data.Aeson.Types               (Value)
 import           Data.HashSet                   (HashSet, singleton)
@@ -73,7 +73,7 @@ modifyIdeConfiguration
   :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
 modifyIdeConfiguration ide f = do
   IdeConfigurationVar var <- getIdeGlobalState ide
-  modifyVar_ var (pure . f)
+  void $ modifyVar' var f
 
 isWorkspaceFile :: NormalizedFilePath -> Action Bool
 isWorkspaceFile file =

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

@@ -13,7 +13,7 @@ module Development.IDE.Core.OfInterest(
     OfInterestVar(..)
     ) where
 
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Exception
 import           Control.Monad
@@ -22,7 +22,6 @@ import           Data.HashMap.Strict                          (HashMap)
 import qualified Data.HashMap.Strict                          as HashMap
 import           Data.Hashable
 import qualified Data.Text                                    as T
-import           Data.Tuple.Extra
 import           Data.Typeable
 import           Development.Shake
 import           GHC.Generics
@@ -87,7 +86,7 @@ modifyFilesOfInterest
   -> IO ()
 modifyFilesOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
-    files <- modifyVar var $ pure . dupe . f
+    files <- modifyVar' var f
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)
 
 -- | Typecheck all the files of interest.
@@ -114,7 +113,7 @@ kick = do
     let mguts = catMaybes results
         !exportsMap' = createExportsMapMg mguts
         !exportsMap'' = maybe mempty createExportsMap ifaces
-    liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap'' <>) . (exportsMap' <>)
+    void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>)
 
     liftIO $ progressUpdate KickCompleted
 

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

@@ -133,7 +133,7 @@ import qualified Development.IDE.Spans.AtPoint                as AtPoint
 import           Development.IDE.Types.HscEnvEq
 import           Development.Shake.Classes                    hiding (get, put)
 
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import           Control.Monad.State
 import           Data.ByteString.Encoding                     as T
 import           Data.Coerce
@@ -947,7 +947,7 @@ getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do
   -- Record the linkable so we know not to unload it
   whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do
       compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-      liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time
+      liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
   pure res
 
 getModIfaceWithoutLinkableRule :: Rules ()

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

@@ -77,8 +77,8 @@ module Development.IDE.Core.Shake(
     ) where
 
 import           Control.Concurrent.Async
-import           Control.Concurrent.Extra
 import           Control.Concurrent.STM
+import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
@@ -247,9 +247,7 @@ getPluginConfig extras plugin = do
 addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
 addPersistentRule k getVal = do
   ShakeExtras{persistentKeys} <- getShakeExtrasRules
-  liftIO $ modifyVar_ persistentKeys $ \hm -> do
-    pure $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) hm
-  return ()
+  void $ liftIO $ modifyVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
 
 class Typeable a => IsIdeGlobal a where
 
@@ -273,7 +271,7 @@ addIdeGlobal x = do
 
 addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
 addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
-    liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
+    void $ liftIO $ modifyVarIO' globals $ \mp -> case HMap.lookup ty mp of
         Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
         Nothing -> return $! HMap.insert ty (toDyn x) mp
 
@@ -325,10 +323,13 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
             f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
-          modifyVar state $ \hm -> pure $ case mv of
-            Nothing -> (HMap.alter (alterValue $ Failed True) (file,Key k) hm,Nothing)
-            Just (v,del,ver) -> (HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) hm
-                                ,Just (v,addDelta del $ mappingForVersion allMappings file ver))
+          case mv of
+            Nothing -> do
+                void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k)
+                return Nothing
+            Just (v,del,ver) -> do
+                void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k)
+                return $ Just (v,addDelta del $ mappingForVersion allMappings file ver)
 
         -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
         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
           -> Value v
           -> Vector FileDiagnostic
           -> IO ()
-setValues state key file val diags = modifyVar_ state $ \vals -> do
-    -- Force to make sure the old HashMap is not retained
-    evaluate $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) vals
+setValues state key file val diags =
+    void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags)
+
 
 -- | Delete the value stored for a given ide build key
 deleteValue
@@ -427,8 +428,7 @@ deleteValue
   -> k
   -> NormalizedFilePath
   -> IO ()
-deleteValue ShakeExtras{state} key file = modifyVar_ state $ \vals ->
-    evaluate $ HMap.delete (file, Key key) vals
+deleteValue ShakeExtras{state} key file = void $ modifyVar' state $ HMap.delete (file, Key key)
 
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues ::
@@ -783,17 +783,15 @@ garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
 garbageCollect keep = do
     ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
     liftIO $
-        do newState <- modifyVar state $ \values -> do
-               values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
-               return $! dupe values
-           modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
-           modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
-           modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
+        do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file)
+           void $ modifyVar' diagnostics $ filterDiagnostics keep
+           void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep
+           void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri))
            let versionsForFile =
                    HMap.fromListWith Set.union $
                    mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
                    HMap.toList newState
-           modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
+           void $ modifyVar' positionMapping $ filterVersionMap versionsForFile
 
 -- | Define a new Rule without early cutoff
 define
@@ -994,7 +992,7 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do
             -- This functions are deliberately eta-expanded to avoid space leaks.
             -- Do not remove the eta-expansion without profiling a session with at
             -- least 1000 modifications.
-            where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x
+            where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0)
 
 isSuccess :: RunResult (A v) -> Bool
 isSuccess (RunResult _ _ (A Failed{})) = False
@@ -1086,17 +1084,17 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
         uri = filePathToUri' fp
         ver = vfsVersion =<< modTime
-        updateDiagnosticsWithForcing new store = do
-            store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store
-            new' <- evaluate $ getUriDiagnostics uri store'
-            return (store', new')
+        update new store =
+            let store' = setStageDiagnostics uri ver (T.pack $ show k) new store
+                new' = getUriDiagnostics uri store'
+            in (store', new')
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
-        newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown
-        _ <- modifyVar hiddenDiagnostics $  updateDiagnosticsWithForcing $ map snd currentHidden
+        newDiags <- modifyVar diagnostics $ pure . update (map snd currentShown)
+        _ <- modifyVar hiddenDiagnostics $  pure . update (map snd currentHidden)
         let uri = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri $ do
@@ -1182,6 +1180,6 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi
                 Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
                   zeroMapping
                   (Map.insert _version (shared_change, zeroMapping) mappingForUri)
-        pure $! HMap.insert uri updatedMapping allMappings
+        pure $ HMap.insert uri updatedMapping allMappings
   where
     shared_change = mkDelta changes

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

@@ -8,7 +8,7 @@ import           Data.List
 import           ErrUtils
 import           GhcPlugins                        as GHC hiding (Var, (<>))
 
-import           Control.Concurrent.Extra
+import           Control.Concurrent.Strict
 import qualified Data.Text                         as T
 
 import           Development.IDE.GHC.Error

ghcide/src/Development/IDE/Types/HscEnvEq.hs

@@ -12,7 +12,7 @@ module Development.IDE.Types.HscEnvEq
 
 
 import           Control.Concurrent.Async      (Async, async, waitCatch)
-import           Control.Concurrent.Extra      (modifyVar, newVar)
+import           Control.Concurrent.Strict     (modifyVar, newVar)
 import           Control.DeepSeq               (force)
 import           Control.Exception             (evaluate, mask, throwIO)
 import           Control.Monad.Extra           (eitherM, join, mapMaybeM)