debug deadlock

Author: evgeny-simplex

src/Simplex/Messaging/Agent/Client.hs

@@ -195,7 +195,8 @@ module Simplex.Messaging.Agent.Client
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent (ThreadId, killThread)
+import Control.Concurrent (ThreadId, killThread, myThreadId)
+import Debug.Trace (traceIO)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (retry)
 import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
@@ -1096,9 +1097,12 @@ getOrCreateConnWorker c@AgentClient {connWorkers, connWorkerSeq} connId = do
 
 connWorkerLoop :: AgentClient -> TBQueue ATransmission -> IO ()
 connWorkerLoop AgentClient {processEvent} q = forever $ do
-  t <- atomically $ readTBQueue q
+  t@(_, connId, _) <- atomically $ readTBQueue q
+  tid <- myThreadId
+  traceIO $ "CALLBACK fire connId=" <> show connId <> " tid=" <> show tid
   processEvent t `E.catchAny` \e ->
     logError $ "connWorkerLoop error: " <> tshow e
+  traceIO $ "CALLBACK done connId=" <> show connId <> " tid=" <> show tid
 
 withInvLock :: AgentClient -> ByteString -> Text -> AM a -> AM a
 withInvLock c key name = ExceptT . withInvLock' c key name . runExceptT

src/Simplex/Messaging/Agent/Lock.hs

@@ -10,13 +10,16 @@ module Simplex.Messaging.Agent.Lock
   )
 where
 
+import Control.Concurrent (myThreadId)
 import Control.Monad (void)
 import Control.Monad.Except (ExceptT (..), runExceptT)
 import Control.Monad.IO.Unlift
 import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
+import qualified Data.Text as T
+import Debug.Trace (traceIO)
 import UnliftIO.Async (forConcurrently)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
@@ -44,15 +47,30 @@ withLock' lock name =
 withGetLock :: MonadUnliftIO m => (k -> STM Lock) -> k -> Text -> m a -> m a
 withGetLock getLock key name a =
   E.bracket
-    (atomically $ getPutLock getLock key name)
-    (atomically . takeTMVar)
+    (do liftIO $ do
+          tid <- myThreadId
+          traceIO $ "LOCK acquire " <> T.unpack name <> " tid=" <> show tid
+        atomically $ getPutLock getLock key name)
+    (\l -> do
+        atomically $ takeTMVar l
+        liftIO $ do
+          tid <- myThreadId
+          traceIO $ "LOCK release " <> T.unpack name <> " tid=" <> show tid)
     (const a)
 
 withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> Text -> m a -> m a
 withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
   where
-    holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
-    releaseLocks = mapM_ (atomically . takeTMVar)
+    holdLocks = do
+      liftIO $ do
+        tid <- myThreadId
+        traceIO $ "LOCKS acquire " <> T.unpack name <> " (" <> show (S.size keys) <> " keys) tid=" <> show tid
+      forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
+    releaseLocks ls = do
+      mapM_ (atomically . takeTMVar) ls
+      liftIO $ do
+        tid <- myThreadId
+        traceIO $ "LOCKS release " <> T.unpack name <> " (" <> show (S.size keys) <> " keys) tid=" <> show tid
 
 -- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
 -- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.