lock-less Values state (#2429)

Author: pepeiborra

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,

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

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               #-}
@@ -155,16 +156,17 @@ 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)
 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 +190,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])
@@ -222,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
     }
 
@@ -326,7 +328,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 +342,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 +356,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 +421,14 @@ shakeDatabaseProfileIO mbProfileDir = do
                 return (dir </> file)
 
 setValues :: IdeRule k v
-          => Var Values
+          => Values
           -> k
           -> NormalizedFilePath
           -> Value v
           -> Vector FileDiagnostic
-          -> IO ()
+          -> STM ()
 setValues state key file val diags =
-    void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags)
+    STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state
 
 
 -- | Delete the value stored for a given ide build key
@@ -437,9 +438,9 @@ deleteValue
   -> k
   -> NormalizedFilePath
   -> IO ()
-deleteValue ShakeExtras{dirtyKeys, state} key file = do
-    void $ modifyVar' state $ HMap.delete (toKey key file)
-    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
@@ -448,28 +449,28 @@ 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)
 
 
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues ::
   forall k v.
   IdeRule k v =>
-  Var Values ->
+  Values ->
   k ->
   NormalizedFilePath ->
-  IO (Maybe (Value v, Vector FileDiagnostic))
+  STM (Maybe (Value v, Vector FileDiagnostic))
 getValues state key file = do
-    vs <- readVar state
-    case HMap.lookup (toKey key file) vs of
+    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)
@@ -507,7 +508,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
@@ -536,7 +537,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
 
         let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv
 
-        dirtyKeys <- newIORef mempty
+        dirtyKeys <- newTVarIO mempty
         pure ShakeExtras{..}
     (shakeDbM, shakeClose) <-
         shakeOpenDatabase
@@ -566,8 +567,8 @@ startTelemetry db extras@ShakeExtras{..}
     IdeOptions{optCheckParents} <- getIdeOptionsIO extras
     checkParents <- optCheckParents
     regularly 1 $ do
-        readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys
-        readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList
+        observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state
+        readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList
         shakeGetBuildStep db >>= observe countBuilds
 
   | otherwise = async (pure ())
@@ -624,7 +625,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
@@ -685,7 +686,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
@@ -785,29 +786,30 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
 garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
 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
-    liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->
-        foldl' (flip HSet.insert) x garbage
+    ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras
+    (n::Int, garbage) <- liftIO $
+        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 st@(vmap,(!counter, keys)) (k, age)
+        removeDirtyKey dk values 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
+            = 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
 countRelevantKeys checkParents =
@@ -906,7 +908,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 +1017,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 +1036,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 +1050,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
@@ -1060,7 +1062,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
@@ -1148,7 +1150,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