lock-free Values

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/Shake.hs

@@ -161,10 +161,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 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 +191,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])
@@ -319,7 +322,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
@@ -334,10 +336,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
@@ -348,7 +350,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))
@@ -413,14 +415,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
@@ -431,7 +433,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
@@ -449,13 +451,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
@@ -500,7 +501,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
@@ -559,7 +560,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
 
@@ -779,8 +780,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
@@ -794,13 +796,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 =

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

@@ -16,53 +16,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 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 +177,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 +196,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 +214,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 +245,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 +279,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