Label consensus threads (#1366)

Author: jasagredo

ouroboros-consensus-diffusion/changelog.d/jasagredo-label-thread.md

@@ -0,0 +1,3 @@
+### Patch
+
+- Label the DbLock acquisition thread.

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/DbLock.hs

@@ -12,6 +12,7 @@ module Ouroboros.Consensus.Node.DbLock (
   , withLockDB_
   ) where
 
+import           Control.Monad.Class.MonadFork
 import           Control.Monad.Class.MonadTimer.SI
 import qualified Data.Time.Clock as Time
 import           Ouroboros.Consensus.Util.FileLock
@@ -70,7 +71,9 @@ withLockDB_ fileLock mountPoint lockFsPath lockTimeout action =
     -- lock, the whole process will soon die.
     acquireLock :: m (m ())
     acquireLock = do
-      lockFileAsync <- async (lockFile fileLock lockFilePath)
+      lockFileAsync <- async (do
+                                 labelThisThread "ChainDB lock"
+                                 lockFile fileLock lockFilePath)
       timeout lockTimeout (wait lockFileAsync) >>= \case
         -- We timed out while waiting on the lock. The db is still locked.
         Nothing     -> throwIO $ DbLocked lockFilePath

ouroboros-consensus/changelog.d/jasagedo-label-thread.md

@@ -0,0 +1,3 @@
+### Patch
+
+- Label the leaky bucket thread.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/LeakyBucket.hs

@@ -222,7 +222,9 @@ runAgainstBucket config action = do
   leakingPeriodVersionTMVar <- atomically newEmptyTMVar -- see note [Leaky bucket design].
   tid <- myThreadId
   bucket <- init config
-  withAsync (leak (readTMVar leakingPeriodVersionTMVar) tid bucket) $ \_ -> do
+  withAsync (do
+    labelThisThread "Leaky bucket (ouroboros-consensus)"
+    leak (readTMVar leakingPeriodVersionTMVar) tid bucket) $ \_ -> do
     atomicallyWithMonotonicTime $ maybeStartThread Nothing leakingPeriodVersionTMVar bucket
     result <-
       action $