lock-less exportsMap

Author: pepeiborra

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

@@ -73,13 +73,13 @@ import           System.IO
 import           System.Info
 
 import           Control.Applicative                  (Alternative ((<|>)))
-import           Control.Exception                    (evaluate)
 import           Data.Void
 
 import           Control.Concurrent.STM               (atomically)
 import           Control.Concurrent.STM.TQueue
 import           Data.Foldable                        (for_)
 import qualified Data.HashSet                         as Set
+import           Data.IORef.Extra                     (atomicModifyIORef'_)
 import           Data.Tuple                           (swap)
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing         (withTrace)
@@ -407,7 +407,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
                     -- update exports map
                     extras <- getShakeExtras
                     let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
-                    liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)
+                    liftIO $ atomicModifyIORef'_ (exportsMap extras) $ (exportsMap' <>)
 
           return (second Map.keys res)
 

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

@@ -27,6 +27,7 @@ import           Development.IDE.Graph
 
 import           Control.Concurrent.STM.Stats           (atomically)
 import qualified Data.ByteString                        as BS
+import           Data.IORef.Extra                       (atomicModifyIORef'_)
 import           Data.Maybe                             (catMaybes)
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
@@ -114,7 +115,7 @@ kick = do
     -- Update the exports map
     results <- uses GenerateCore files <* uses GetHieAst files
     let mguts = catMaybes results
-    void $ liftIO $ modifyVar' exportsMap (updateExportsMapMg mguts)
+    void $ liftIO $ atomicModifyIORef'_ exportsMap (updateExportsMapMg mguts)
 
     liftIO $ progressUpdate progress KickCompleted
 

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

@@ -156,6 +156,7 @@ import           Data.Default
 import           Data.Foldable                          (toList)
 import           Data.HashSet                           (HashSet)
 import qualified Data.HashSet                           as HSet
+import           Data.IORef.Extra                       (atomicModifyIORef'_)
 import           Data.String                            (fromString)
 import           Data.Text                              (pack)
 import           Debug.Trace.Flags                      (userTracingEnabled)
@@ -212,7 +213,7 @@ data ShakeExtras = ShakeExtras
     -- | A mapping of module name to known target (or candidate targets, if missing)
     ,knownTargetsVar :: IORef (Hashed KnownTargets)
     -- | A mapping of exported identifiers for local modules. Updated on kick
-    ,exportsMap :: Var ExportsMap
+    ,exportsMap :: IORef ExportsMap
     -- | A work queue for actions added via 'runInShakeSession'
     ,actionQueue :: ActionQueue
     ,clientCapabilities :: ClientCapabilities
@@ -521,12 +522,12 @@ shakeOpen lspEnv defaultConfig logger debouncer
         indexCompleted <- newTVarIO 0
         indexProgressToken <- newVar Nothing
         let hiedbWriter = HieDbWriter{..}
-        exportsMap <- newVar mempty
+        exportsMap <- newIORef mempty
         -- lazily initialize the exports map with the contents of the hiedb
         _ <- async $ do
             logDebug logger "Initializing exports map from hiedb"
             em <- createExportsMapHieDb hiedb
-            modifyVar' exportsMap (<> em)
+            atomicModifyIORef'_ exportsMap (<> em)
             logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"
 
         progress <- do

ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs

@@ -14,7 +14,6 @@ module Development.IDE.Plugin.CodeAction.Args
   )
 where
 
-import           Control.Concurrent.Extra
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Maybe
 import           Data.Either                                  (fromRight)
@@ -59,7 +58,7 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra
       runRule GhcSession >>= \case
         Just env -> do
           pkgExports <- envPackageExports env
-          localExports <- readVar (exportsMap $ shakeExtras state)
+          localExports <- readIORef (exportsMap $ shakeExtras state)
           pure $ localExports <> pkgExports
         _ -> pure mempty
   caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -8,13 +8,13 @@ module Development.IDE.Plugin.Completions
     ) where
 
 import           Control.Concurrent.Async                     (concurrently)
-import           Control.Concurrent.Extra
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
 import qualified Data.HashMap.Strict                          as Map
 import qualified Data.HashSet                                 as Set
+import           Data.IORef                                   (readIORef)
 import           Data.List                                    (find)
 import           Data.Maybe
 import qualified Data.Text                                    as T
@@ -138,7 +138,7 @@ getCompletionsLSP ide plId
             -- set up the exports map including both package and project-level identifiers
             packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath
             packageExportsMap <- mapM liftIO packageExportsMapIO
-            projectExportsMap <- liftIO $ readVar (exportsMap $ shakeExtras ide)
+            projectExportsMap <- liftIO $ readIORef (exportsMap $ shakeExtras ide)
             let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap
 
             let moduleExports = getModuleExportsMap exportsMap