From 747734524d538a5fa8d1ea50f773ff0eda0c9e9d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 11 Mar 2021 08:33:36 +0000 Subject: [PATCH] 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 --- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 25 ++++----- ghcide/src/Control/Concurrent/Strict.hs | 34 +++++++++++ ghcide/src/Development/IDE/Core/Debouncer.hs | 2 +- ghcide/src/Development/IDE/Core/FileExists.hs | 4 +- ghcide/src/Development/IDE/Core/FileStore.hs | 4 +- .../Development/IDE/Core/IdeConfiguration.hs | 4 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 7 +-- ghcide/src/Development/IDE/Core/Rules.hs | 4 +- ghcide/src/Development/IDE/Core/Shake.hs | 56 +++++++++---------- ghcide/src/Development/IDE/GHC/Warnings.hs | 2 +- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 2 +- 12 files changed, 88 insertions(+), 57 deletions(-) create mode 100644 ghcide/src/Control/Concurrent/Strict.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index c5996d558b..5a3112417b 100644 --- a/ghcide/ghcide.cabal +++ b/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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 1461a70b17..9f023bb947 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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] diff --git a/ghcide/src/Control/Concurrent/Strict.hs b/ghcide/src/Control/Concurrent/Strict.hs new file mode 100644 index 0000000000..e5c4a7ab78 --- /dev/null +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index d7df9bad49..1670784ce2 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/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_) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index e37e4603b9..3357c8753b 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/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) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 8b63a0a7f6..0c0c8ca23f 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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. diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index 0aa5d34f99..dd9e0a0d3e 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/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 = diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ecdae7d77a..fdba86dd8e 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6b48cc0245..1ec74c0018 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/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 () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 17f82caad2..85c3dd1406 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 8152dd52c6..f6838ce51c 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 3283ec9e67..2395fc08e6 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/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)