improve contention in hls-graph

STM stats are not yet reported in the benchmark suite, so we need to run the
benchmarks manually in verbose mode to observ them (and build hls-graph with the
stm-stats Cabal flag).

  cabal build exe:ghcide ghcide-bench && cabal exec cabal run ghcide-bench -- -- -s "edit" --samples 10 --no-clean --example-module Distribution/Simple.hs --example-module Distribution/Types/Module.hs  -v

Lots of contention in `builder` and esp. `updateReverseDeps`.
`incDatabase` should not have any retries, could be a bug.
```
STM transaction statistics (2021-11-30 16:51:48.260905 UTC):
Transaction               Commits    Retries      Ratio
_anonymous_                     5          0       0.00
builder                     80886       6000       0.07
compute                     19175        141       0.01
incDatabase                    27        100       3.70
updateReverseDeps            3827        765       0.20
```
```
STM transaction statistics (2021-11-30 19:45:30.904126927 UTC):
Transaction               Commits    Retries      Ratio
_anonymous_                     1          0       0.00
builder                    606254      22569       0.04
compute                    324708      10428       0.03
incDatabase                    15          0       0.00
updateReverseDeps          259755     489285       1.88
```

```
STM transaction statistics (2021-11-30 20:21:57.968789 UTC):
Transaction               Commits    Retries      Ratio
_anonymous_                 48318          2       0.00
builder                   1108126       1276       0.00
compute                     22423        144       0.01
updateReverseDeps           65225        377       0.01
```
```
STM transaction statistics (2021-11-30 19:57:27.979412261 UTC):
Transaction               Commits    Retries      Ratio
_anonymous_                   294          0       0.00
builder                    861431       2914       0.00
compute                    324708       1573       0.00
updateReverseDeps          858100      17816       0.02
```

Author: pepeiborra

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -12,8 +12,7 @@ module Development.IDE.Graph.Database(
     shakeGetDirtySet,
     shakeGetCleanKeys
     ,shakeGetBuildEdges) where
-import           Control.Concurrent.STM.Stats            (atomicallyNamed,
-                                                          readTVarIO)
+import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
 import           Development.IDE.Graph.Classes           ()
@@ -64,7 +63,7 @@ shakeRunDatabaseForKeys
     -> [Action a]
     -> IO ([a], [IO ()])
 shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
-    atomicallyNamed "incDatabase" $ incDatabase db keysChanged
+    incDatabase db keysChanged
     as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
     return (as, [])
 

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -51,19 +51,19 @@ newDatabase databaseExtra databaseRules = do
     pure Database{..}
 
 -- | Increment the step and mark dirty
-incDatabase :: Database -> Maybe [Key] -> STM ()
+incDatabase :: Database -> Maybe [Key] -> IO ()
 -- only some keys are dirty
 incDatabase db (Just kk) = do
-    modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
+    atomically $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
     transitiveDirtyKeys <- transitiveDirtySet db kk
-    for_ transitiveDirtyKeys $ \k ->
+    for_ transitiveDirtyKeys $ \k -> atomically $
         SMap.focus updateDirty k (databaseValues db)
 
 -- all keys are dirty
 incDatabase db Nothing = do
-    modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
+    atomically $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
     let list = SMap.listT (databaseValues db)
-    flip ListT.traverse_ list $ \(k,_) -> do
+    atomicallyNamed "incDatabase" $ flip ListT.traverse_ list $ \(k,_) ->
         SMap.focus updateDirty k (databaseValues db)
 
 updateDirty :: Monad m => Focus.Focus KeyDetails m ()
@@ -94,7 +94,7 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do
     -- Things that I need to force before my results are ready
     toForce <- liftIO $ newTVarIO []
     current <- liftIO $ readTVarIO databaseStep
-    results <- liftIO $ atomicallyNamed "builder" $ for keys $ \id -> do
+    results <- liftIO $ for keys $ \id -> atomicallyNamed "builder" $ do
             -- Spawn the id if needed
             status <- SMap.lookup id databaseValues
             val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of
@@ -215,7 +215,7 @@ updateReverseDeps
     -> [Key] -- ^ Previous direct dependencies of Id
     -> HashSet Key -- ^ Current direct dependencies of Id
     -> IO ()
-updateReverseDeps myId db prev new = uninterruptibleMask_ $ atomicallyNamed "updateReverseDeps" $ do
+updateReverseDeps myId db prev new = uninterruptibleMask_ $ do
     forM_ prev $ \d ->
         unless (d `HSet.member` new) $
             doOne (HSet.delete myId) d
@@ -224,20 +224,20 @@ updateReverseDeps myId db prev new = uninterruptibleMask_ $ atomicallyNamed "upd
     where
         alterRDeps f =
             Focus.adjust (onKeyReverseDeps f)
-        doOne f id =
+        doOne f id = atomicallyNamed "updateReverseDeps" $
             SMap.focus (alterRDeps f) id (databaseValues db)
 
 getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key))
 getReverseDependencies db = (fmap.fmap) keyReverseDeps  . flip SMap.lookup (databaseValues db)
 
-transitiveDirtySet :: Foldable t => Database -> t Key -> STM (HashSet Key)
+transitiveDirtySet :: Foldable t => Database -> t Key -> IO (HashSet Key)
 transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop
   where
     loop x = do
         seen <- State.get
         if x `HSet.member` seen then pure () else do
             State.put (HSet.insert x seen)
-            next <- lift $ getReverseDependencies database x
+            next <- lift $ atomically $ getReverseDependencies database x
             traverse_ loop (maybe mempty HSet.toList next)
 
 -- | IO extended to track created asyncs to clean them up when the thread is killed,