move deleteValue and recordDirtyKeys to STM

Author: pepeiborra

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

@@ -247,7 +247,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
                       } <- getShakeExtras
     let invalidateShakeCache = do
             void $ modifyVar' version succ
-            recordDirtyKeys extras GhcSessionIO [emptyFilePath]
+            atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath]
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject
@@ -264,7 +264,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
                 return (targetTarget, found)
-          recordDirtyKeys extras GetKnownTargets  [emptyFilePath]
+          atomically $ recordDirtyKeys extras GetKnownTargets  [emptyFilePath]
           modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do
             let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets
             when (known /= known') $

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

@@ -10,6 +10,7 @@ module Development.IDE.Core.FileExists
   )
 where
 
+import           Control.Concurrent.STM.Stats
 import           Control.Concurrent.Strict
 import           Control.Exception
 import           Control.Monad.Extra
@@ -100,9 +101,11 @@ modifyFileExists state changes = do
     -- flush previous values
     let (fileModifChanges, fileExistChanges) =
             partition ((== FcChanged) . snd) (HashMap.toList changesMap)
-    mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
-    recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
-    recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
+    join $ atomically $ do
+        mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
+        io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
+        io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
+        return (io1 <> io2)
 
 fromChange :: FileChangeType -> Maybe Bool
 fromChange FcCreated = Just True

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

@@ -24,7 +24,7 @@ module Development.IDE.Core.FileStore(
     registerFileWatches
     ) where
 
-import           Control.Concurrent.STM                       (atomically,
+import           Control.Concurrent.STM.Stats                 (STM, atomically,
                                                                modifyTVar')
 import           Control.Concurrent.STM.TQueue                (writeTQueue)
 import           Control.Concurrent.Strict
@@ -160,7 +160,7 @@ isInterface :: NormalizedFilePath -> Bool
 isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"]
 
 -- | Reset the GetModificationTime state of interface files
-resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO ()
+resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
 resetInterfaceStore state f = do
     deleteValue state GetModificationTime f
 
@@ -175,7 +175,8 @@ resetFileStore ideState changes = mask $ \_ -> do
         case c of
             FcChanged
             --  already checked elsewhere |  not $ HM.member nfp fois
-              -> deleteValue (shakeExtras ideState) GetModificationTime nfp
+              -> atomically $
+               deleteValue (shakeExtras ideState) GetModificationTime nfp
             _ -> pure ()
 
 
@@ -262,7 +263,7 @@ setFileModified state saved nfp = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setFileModified can't be called on this type of VFSHandle"
-    recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
+    atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
     restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") []
     when checkParents $
       typecheckParents state nfp

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

@@ -25,6 +25,7 @@ import qualified Data.HashMap.Strict                    as HashMap
 import qualified Data.Text                              as T
 import           Development.IDE.Graph
 
+import           Control.Concurrent.STM.Stats           (atomically)
 import qualified Data.ByteString                        as BS
 import           Data.Maybe                             (catMaybes)
 import           Development.IDE.Core.ProgressReporting
@@ -86,15 +87,15 @@ addFileOfInterest state f v = do
         let (prev, new) = HashMap.alterF (, Just v) f dict
         pure (new, (prev, new))
     when (prev /= Just v) $
-        recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
+        join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
     logDebug (ideLogger state) $
         "Set files of interest to: " <> T.pack (show files)
 
 deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO ()
 deleteFileOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar' var $ HashMap.delete f
-    recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
+    join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)
 
 scheduleGarbageCollection :: IdeState -> IO ()

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

@@ -148,6 +148,7 @@ import           Ide.Plugin.Properties                        (HasProperty,
 import           Ide.PluginUtils                              (configForPlugin)
 import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
                                                                PluginId)
+import Control.Concurrent.STM.Stats (atomically)
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -1061,7 +1062,7 @@ writeHiFileAction hsc hiFile = do
     extras <- getShakeExtras
     let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile
     liftIO $ do
-        resetInterfaceStore extras $ toNormalizedFilePath' targetPath
+        atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath
         writeHiFile hsc hiFile
 
 data RulesConfig = RulesConfig

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

@@ -437,8 +437,8 @@ deleteValue
   => ShakeExtras
   -> k
   -> NormalizedFilePath
-  -> IO ()
-deleteValue ShakeExtras{dirtyKeys, state} key file = atomically $ do
+  -> STM ()
+deleteValue ShakeExtras{dirtyKeys, state} key file = do
     STM.delete (toKey key file) state
     modifyTVar' dirtyKeys $ HSet.insert (toKey key file)
 
@@ -447,10 +447,11 @@ recordDirtyKeys
   => ShakeExtras
   -> k
   -> [NormalizedFilePath]
-  -> IO ()
-recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do
-    atomically $ modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
-    addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file)
+  -> STM (IO ())
+recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
+    modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
+    return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
+        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.