From 057c5c9241e0afae3ee26ec571e7b5ffb2fbda88 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 19 Nov 2021 05:27:27 +0000 Subject: [PATCH 1/4] lock-less Values --- ghcide/ghcide.cabal | 3 + ghcide/src/Development/IDE/Core/Shake.hs | 41 ++++--- ghcide/src/Development/IDE/Core/Tracing.hs | 127 +++++++++++---------- ghcide/src/Development/IDE/Main.hs | 18 +-- ghcide/src/Development/IDE/Plugin/Test.hs | 6 +- ghcide/src/Development/IDE/Types/Shake.hs | 4 +- 6 files changed, 106 insertions(+), 93 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 5ae04274c3..60552e80be 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -54,6 +54,7 @@ library fuzzy, filepath, fingertree, + focus, ghc-exactprint, ghc-trace-events, Glob, @@ -62,6 +63,7 @@ library hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.2.0.2, lens, + list-t, hiedb == 0.4.1.*, lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, @@ -81,6 +83,7 @@ library sorted-list, sqlite-simple, stm, + stm-containers, syb, text, time, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 24281a5cae..41659fb8f1 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} @@ -161,10 +162,13 @@ import Data.String (fromString) import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) import qualified Development.IDE.Types.Exports as ExportsMap +import qualified Focus import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) +import qualified "list-t" ListT +import qualified StmContainers.Map as STM -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -188,7 +192,7 @@ data ShakeExtras = ShakeExtras ,debouncer :: Debouncer NormalizedUri ,logger :: Logger ,globals :: Var (HMap.HashMap TypeRep Dynamic) - ,state :: Var Values + ,state :: Values ,diagnostics :: Var DiagnosticStore ,hiddenDiagnostics :: Var DiagnosticStore ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) @@ -326,7 +330,6 @@ getIdeOptionsIO ide = do -- for the version of that value. lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do - hm <- readVar state allMappings <- readVar positionMapping let readPersistent @@ -341,10 +344,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) + void $ atomically $ STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing Just (v,del,ver) -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) + void $ atomically $ STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state 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 @@ -355,7 +358,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (toKey k file) hm of + atomically (STM.lookup (toKey k file) state) >>= \case Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) @@ -420,14 +423,14 @@ shakeDatabaseProfileIO mbProfileDir = do return (dir file) setValues :: IdeRule k v - => Var Values + => Values -> k -> NormalizedFilePath -> Value v -> Vector FileDiagnostic -> IO () setValues state key file val diags = - void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) + atomically $ STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state -- | Delete the value stored for a given ide build key @@ -438,7 +441,7 @@ deleteValue -> NormalizedFilePath -> IO () deleteValue ShakeExtras{dirtyKeys, state} key file = do - void $ modifyVar' state $ HMap.delete (toKey key file) + atomically $ STM.delete (toKey key file) state atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys @@ -456,13 +459,12 @@ recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKey getValues :: forall k v. IdeRule k v => - Var Values -> + Values -> k -> NormalizedFilePath -> IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do - vs <- readVar state - case HMap.lookup (toKey key file) vs of + atomically (STM.lookup (toKey key file) state) >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v @@ -507,7 +509,7 @@ shakeOpen lspEnv defaultConfig logger debouncer ideNc <- newIORef (initNameCache us knownKeyNames) shakeExtras <- do globals <- newVar HMap.empty - state <- newVar HMap.empty + state <- STM.newIO diagnostics <- newVar mempty hiddenDiagnostics <- newVar mempty publishedDiagnostics <- newVar mempty @@ -566,7 +568,7 @@ startTelemetry db extras@ShakeExtras{..} IdeOptions{optCheckParents} <- getIdeOptionsIO extras checkParents <- optCheckParents regularly 1 $ do - readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys + observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList shakeGetBuildStep db >>= observe countBuilds @@ -786,8 +788,9 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [K garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime extras <- getShakeExtras - (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> - evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys + let values = state extras + (n::Int, garbage) <- liftIO $ atomically $ + foldM (removeDirtyKey values) (0,[]) agedKeys liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> foldl' (flip HSet.insert) x garbage t <- liftIO start @@ -801,13 +804,13 @@ garbageCollectKeys label maxAge checkParents agedKeys = do where showKey = show . Q - removeDirtyKey st@(vmap,(!counter, keys)) (k, age) + removeDirtyKey m st@(!counter, keys) (k, age) | age > maxAge , Just (kt,_) <- fromKeyType k , not(kt `HSet.member` preservedKeys checkParents) - , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap - = (vmap', (counter+1, k:keys)) - | otherwise = st + = do gotIt <- STM.focus (Focus.member <* Focus.delete) k m + return $ if gotIt then (counter+1, k:keys) else st + | otherwise = pure st countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index b00f4d7931..39fde44191 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoApplicativeDo #-} +{-# LANGUAGE PackageImports #-} {-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler @@ -16,53 +17,56 @@ module Development.IDE.Core.Tracing ) where -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (Var, modifyVar_, newVar, - readVar, threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (SomeException, catch, - generalBracket) -import Control.Monad (forM_, forever, void, when, - (>=>)) -import Control.Monad.Catch (ExitCase (..), MonadMask) -import Control.Monad.Extra (whenJust) +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (modifyVar_, newVar, readVar, + threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (SomeException, catch, + generalBracket) +import Control.Monad (forM_, forever, void, when, + (>=>)) +import Control.Monad.Catch (ExitCase (..), MonadMask) +import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift -import Control.Seq (r0, seqList, seqTuple2, using) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (TypeRep, typeOf) -import Data.Word (Word16) -import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) -import Development.IDE.Graph (Action) +import Control.Monad.STM (atomically) +import Control.Seq (r0, seqList, seqTuple2, + using) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) +import Data.Word (Word16) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + GhcSessionIO (GhcSessionIO)) +import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule -import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) -import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger), logDebug, - logInfo) -import Development.IDE.Types.Shake (Value, - ValueWithDiagnostics (..), - Values, fromKeyType) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Ide.PluginUtils (installSigUsr1Handler) -import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, - fromNormalizedFilePath) -import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, - beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) +import Development.IDE.Types.Diagnostics (FileDiagnostic, + showDiagnostics) +import Development.IDE.Types.Location (Uri (..)) +import Development.IDE.Types.Logger (Logger (Logger), logDebug, + logInfo) +import Development.IDE.Types.Shake (ValueWithDiagnostics (..), + Values, fromKeyType) +import Foreign.Storable (Storable (sizeOf)) +import HeapSize (recursiveSize, runHeapsize) +import Ide.PluginUtils (installSigUsr1Handler) +import Ide.Types (PluginId (..)) +import Language.LSP.Types (NormalizedFilePath, + fromNormalizedFilePath) +import qualified "list-t" ListT +import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, + mkValueObserver, observe, + setTag, withSpan, withSpan_) +import qualified StmContainers.Map as STM #if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a @@ -174,16 +178,16 @@ otTracedProvider (PluginId pluginName) provider act | otherwise = act -startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO () -startProfilingTelemetry allTheTime logger stateRef = do +startProfilingTelemetry :: Bool -> Logger -> Values -> IO () +startProfilingTelemetry allTheTime logger state = do instrumentFor <- getInstrumentCached installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor + performMeasurement logger state instrumentFor when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor + performMeasurement logger state instrumentFor where seconds = 1000000 @@ -193,17 +197,16 @@ startProfilingTelemetry allTheTime logger stateRef = do performMeasurement :: Logger -> - Var Values -> + Values -> (Maybe String -> IO OurValueObserver) -> IO () -performMeasurement logger stateRef instrumentFor = do - - values <- readVar stateRef +performMeasurement logger values instrumentFor = do + contents <- atomically $ ListT.toList $ STM.listT values let keys = typeOf GhcSession : typeOf GhcSessionDeps -- TODO restore : [ kty - | k <- HMap.keys values + | (k,_) <- contents , Just (kty,_) <- [fromKeyType k] -- do GhcSessionIO last since it closes over stateRef itself , kty /= typeOf GhcSession @@ -212,7 +215,7 @@ performMeasurement logger stateRef instrumentFor = do ] ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) - measureMemory logger [groupedForSharing] instrumentFor stateRef + measureMemory logger [groupedForSharing] instrumentFor values `catch` \(e::SomeException) -> logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) @@ -243,12 +246,12 @@ measureMemory :: Logger -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis -> (Maybe String -> IO OurValueObserver) - -> Var Values + -> Values -> IO () -measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do - values <- readVar stateRef +measureMemory logger groups instrumentFor values = withSpan_ "Measure Memory" $ do + contents <- atomically $ ListT.toList $ STM.listT values valuesSizeRef <- newIORef $ Just 0 - let !groupsOfGroupedValues = groupValues values + let !groupsOfGroupedValues = groupValues contents logDebug logger "STARTING MEMORY PROFILING" forM_ groupsOfGroupedValues $ \groupedValues -> do keepGoing <- readIORef valuesSizeRef @@ -277,12 +280,12 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where - groupValues :: Values -> [ [(String, [Value Dynamic])] ] - groupValues values = + -- groupValues :: Values -> [ [(String, [Value Dynamic])] ] + groupValues contents = let !groupedValues = [ [ (show ty, vv) | ty <- groupKeys - , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values + , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- contents , kty == ty] ] | groupKeys <- groups diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3eed0d5ff9..a533767a95 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..) @@ -8,10 +9,9 @@ module Development.IDE.Main ,commandP ,defaultMain ,testing) where -import Control.Concurrent.Extra (newLock, readVar, - withLock, +import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) -import Control.Concurrent.STM.Stats (dumpSTMStats) +import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, @@ -99,8 +99,10 @@ import Ide.Types (IdeCommand (IdeCommand), PluginId (PluginId), ipMap) import qualified Language.LSP.Server as LSP +import qualified "list-t" ListT import Numeric.Natural (Natural) import Options.Applicative hiding (action) +import qualified StmContainers.Map as STM import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) @@ -359,19 +361,19 @@ defaultMain Arguments{..} = do putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" when argsOTMemoryProfiling $ do - let valuesRef = state $ shakeExtras ide - values <- readVar valuesRef + let values = state $ shakeExtras ide let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) - printf "# Shake value store contents(%d):\n" (length values) + stateContents <- atomically $ ListT.toList $ STM.listT values + printf "# Shake value store contents(%d):\n" (length stateContents) let keys = nub $ typeOf GhcSession : typeOf GhcSessionDeps : - [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [kty | (fromKeyType -> Just (kty,_), _) <- stateContents, kty /= typeOf GhcSessionIO] ++ [typeOf GhcSessionIO] - measureMemory logger [keys] consoleObserver valuesRef + measureMemory logger [keys] consoleObserver values unless (null failed) (exitWith $ ExitFailure (length failed)) Db dir opts cmd -> do diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 14e861f38b..0df73d87d5 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test @@ -12,7 +13,6 @@ module Development.IDE.Plugin.Test ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM @@ -46,6 +46,8 @@ import Ide.Plugin.Config (CheckParents) import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types +import qualified "list-t" ListT +import qualified StmContainers.Map as STM import System.Time.Extra type Age = Int @@ -124,7 +126,7 @@ testRequestHandler s (GarbageCollectDirtyKeys parents age) = do res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do - keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) + keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ state $ shakeExtras s) return $ Right $ toJSON $ map show keys testRequestHandler s GetFilesOfInterest = do ff <- liftIO $ getFilesOfInterest s diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 8d30b59801..5df0de9a76 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -20,7 +20,6 @@ import Control.DeepSeq import Control.Exception import qualified Data.ByteString.Char8 as BS import Data.Dynamic -import Data.HashMap.Strict import Data.Hashable import Data.Typeable (cast) import Data.Vector (Vector) @@ -31,6 +30,7 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Types +import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), pattern App, pattern Con, typeOf, typeRep, @@ -56,7 +56,7 @@ data ValueWithDiagnostics = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics -type Values = HashMap Key ValueWithDiagnostics +type Values = STM.Map Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action From 007d67b42770dde1dfc361c4410e1802ce911c2b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 2 Dec 2021 17:57:25 +0000 Subject: [PATCH 2/4] STM dirty keys --- ghcide/src/Development/IDE/Core/FileStore.hs | 11 +++--- ghcide/src/Development/IDE/Core/Shake.hs | 39 +++++++++----------- 2 files changed, 24 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index fe52b65975..2f8dee396e 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -24,7 +24,8 @@ module Development.IDE.Core.FileStore( registerFileWatches ) where -import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM (atomically, + modifyTVar') import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Concurrent.Strict import Control.Exception @@ -63,7 +64,6 @@ import qualified Development.IDE.Types.Logger as L import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS import qualified Data.HashSet as HSet -import Data.IORef.Extra (atomicModifyIORef_) import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) @@ -292,9 +292,10 @@ setSomethingModified state keys reason = do when (isJust setVirtualFileContents) $ fail "setSomethingModified can't be called on this type of VFSHandle" -- Update database to remove any files that might have been renamed/deleted - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles - atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip HSet.insert) x keys + atomically $ do + writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles + modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> + foldl' (flip HSet.insert) x keys void $ restartShakeSession (shakeExtras state) reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 41659fb8f1..eb5df83cb2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -156,8 +156,6 @@ import Data.Default import Data.Foldable (toList) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.IORef.Extra (atomicModifyIORef'_, - atomicModifyIORef_) import Data.String (fromString) import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) @@ -226,7 +224,7 @@ data ShakeExtras = ShakeExtras , vfs :: VFSHandle , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , dirtyKeys :: IORef (HashSet Key) + , dirtyKeys :: TVar (HashSet Key) -- ^ Set of dirty rule keys since the last Shake run } @@ -440,9 +438,9 @@ deleteValue -> k -> NormalizedFilePath -> IO () -deleteValue ShakeExtras{dirtyKeys, state} key file = do - atomically $ STM.delete (toKey key file) state - atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) +deleteValue ShakeExtras{dirtyKeys, state} key file = atomically $ do + STM.delete (toKey key file) state + modifyTVar' dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys :: Shake.ShakeValue k @@ -451,7 +449,7 @@ recordDirtyKeys -> [NormalizedFilePath] -> IO () recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do - atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) + atomically $ modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file) @@ -538,7 +536,7 @@ shakeOpen lspEnv defaultConfig logger debouncer let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newIORef mempty + dirtyKeys <- newTVarIO mempty pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -569,7 +567,7 @@ startTelemetry db extras@ShakeExtras{..} checkParents <- optCheckParents regularly 1 $ do observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state - readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList + readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList shakeGetBuildStep db >>= observe countBuilds | otherwise = async (pure ()) @@ -626,7 +624,7 @@ shakeRestart IdeState{..} reason acts = (\runner -> do (stopTime,()) <- duration (cancelShakeSession runner) res <- shakeDatabaseProfile shakeDb - backlog <- readIORef $ dirtyKeys shakeExtras + backlog <- readTVarIO (dirtyKeys shakeExtras) queue <- atomically $ peekInProgress $ actionQueue shakeExtras let profile = case res of Just fp -> ", profile saved at " <> fp @@ -687,7 +685,7 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do reenqueued <- atomically $ peekInProgress actionQueue allPendingKeys <- if optRunSubset - then Just <$> readIORef dirtyKeys + then Just <$> readTVarIO dirtyKeys else return Nothing let -- A daemon-like action used to inject additional work @@ -787,28 +785,27 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime - extras <- getShakeExtras - let values = state extras + ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras (n::Int, garbage) <- liftIO $ atomically $ - foldM (removeDirtyKey values) (0,[]) agedKeys - liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> - foldl' (flip HSet.insert) x garbage + foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys t <- liftIO start when (n>0) $ liftIO $ do - logDebug (logger extras) $ T.pack $ + logDebug logger $ T.pack $ label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" - when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $ + when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (SCustomMethod "ghcide/GC") (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage where showKey = show . Q - removeDirtyKey m st@(!counter, keys) (k, age) + removeDirtyKey dk values st@(!counter, keys) (k, age) | age > maxAge , Just (kt,_) <- fromKeyType k , not(kt `HSet.member` preservedKeys checkParents) - = do gotIt <- STM.focus (Focus.member <* Focus.delete) k m + = do gotIt <- STM.focus (Focus.member <* Focus.delete) k values + when gotIt $ + modifyTVar' dk (HSet.insert k) return $ if gotIt then (counter+1, k:keys) else st | otherwise = pure st @@ -1063,7 +1060,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - liftIO $ atomicModifyIORef'_ dirtyKeys (HSet.delete $ toKey key file) + liftIO $ atomically $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file) return res traceA :: A v -> String From 2cc0111a5e35d0752093d6171242ad84d966b57c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 2 Dec 2021 18:03:00 +0000 Subject: [PATCH 3/4] Extract atomically to call sites --- ghcide/src/Development/IDE/Core/Shake.hs | 35 ++++++++++++------------ 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index eb5df83cb2..1c1bbdc256 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -426,9 +426,9 @@ setValues :: IdeRule k v -> NormalizedFilePath -> Value v -> Vector FileDiagnostic - -> IO () + -> STM () setValues state key file val diags = - atomically $ STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state + STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state -- | Delete the value stored for a given ide build key @@ -460,16 +460,17 @@ getValues :: Values -> k -> NormalizedFilePath -> - IO (Maybe (Value v, Vector FileDiagnostic)) + STM (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do - atomically (STM.lookup (toKey key file) state) >>= \case + STM.lookup (toKey key file) state >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do - let r = fmap (fromJust . fromDynamic @v) v + let !r = seqValue $ fmap (fromJust . fromDynamic @v) v + !res = (r,diagsV) -- Force to make sure we do not retain a reference to the HashMap -- and we blow up immediately if the fromJust should fail -- (which would be an internal error). - evaluate (r `seqValue` Just (r, diagsV)) + return $ Just res -- | Get all the files in the project knownTargets :: Action (Hashed KnownTargets) @@ -480,11 +481,11 @@ knownTargets = do -- | Seq the result stored in the Shake value. This only -- evaluates the value to WHNF not NF. We take care of the latter -- elsewhere and doing it twice is expensive. -seqValue :: Value v -> b -> b -seqValue v b = case v of - Succeeded ver v -> rnf ver `seq` v `seq` b - Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` b - Failed _ -> b +seqValue :: Value v -> Value v +seqValue val = case val of + Succeeded ver v -> rnf ver `seq` v `seq` val + Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` val + Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: Maybe (LSP.LanguageContextEnv Config) @@ -906,7 +907,7 @@ useWithStaleFast' key file = do wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake - r <- liftIO $ getValues state key file + r <- liftIO $ atomically $ getValues state key file liftIO $ case r of -- block for the result if we haven't computed before Nothing -> do @@ -1015,7 +1016,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do - v <- liftIO $ getValues state key file + v <- liftIO $ atomically $ getValues state key file case v of -- No changes in the dependencies and we have -- an existing successful result. @@ -1034,10 +1035,10 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (do v <- action; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file + modTime <- liftIO $ (currentValue . fst =<<) <$> atomically (getValues state GetModificationTime file) (bs, res) <- case res of Nothing -> do - staleV <- liftIO $ getValues state key file + staleV <- liftIO $ atomically $ getValues state key file pure $ case staleV of Nothing -> (toShakeValue ShakeResult bs, Failed False) Just v -> case v of @@ -1048,7 +1049,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (Failed b, _) -> (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) - liftIO $ setValues state key file res (Vector.fromList diags) + liftIO $ atomically $ setValues state key file res (Vector.fromList diags) doDiagnostics diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b @@ -1148,7 +1149,7 @@ updateFileDiagnostics :: MonadIO m -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do - modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp + modTime <- (currentValue . fst =<<) <$> atomically (getValues state GetModificationTime fp) let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp ver = vfsVersion =<< modTime From 3effdd4925d37f1587327a02ad35404d440b4cff Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 2 Dec 2021 18:09:32 +0000 Subject: [PATCH 4/4] Split transaction into iteration --- ghcide/src/Development/IDE/Core/Shake.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1c1bbdc256..17af58a836 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -787,7 +787,7 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [K garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras - (n::Int, garbage) <- liftIO $ atomically $ + (n::Int, garbage) <- liftIO $ foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys t <- liftIO start when (n>0) $ liftIO $ do @@ -804,10 +804,11 @@ garbageCollectKeys label maxAge checkParents agedKeys = do | age > maxAge , Just (kt,_) <- fromKeyType k , not(kt `HSet.member` preservedKeys checkParents) - = do gotIt <- STM.focus (Focus.member <* Focus.delete) k values - when gotIt $ - modifyTVar' dk (HSet.insert k) - return $ if gotIt then (counter+1, k:keys) else st + = atomically $ do + gotIt <- STM.focus (Focus.member <* Focus.delete) k values + when gotIt $ + modifyTVar' dk (HSet.insert k) + return $ if gotIt then (counter+1, k:keys) else st | otherwise = pure st countRelevantKeys :: CheckParents -> [Key] -> Int