Label the internal thread spawned in linkOnly

Author: jasagredo

Control/Concurrent/Async/Internal.hs

@@ -55,7 +55,7 @@ import Data.IORef
 
 import GHC.Exts
 import GHC.IO hiding (finally, onException)
-import GHC.Conc (ThreadId(..))
+import GHC.Conc (ThreadId(..), labelThread)
 
 -- -----------------------------------------------------------------------------
 -- STM Async API
@@ -504,6 +504,7 @@ linkOnly
 linkOnly shouldThrow a = do
   me <- myThreadId
   void $ forkRepeat $ do
+    myThreadId >>= flip labelThread ("linkOnly " ++ show (asyncThreadId a) ++ " -> " ++ show me)
     r <- waitCatch a
     case r of
       Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)
@@ -684,6 +685,7 @@ concurrently' left right collect = do
                   -- putMVar.
                   when (count' > 0) $
                     void $ forkIO $ do
+                      myThreadId >>= flip labelThread "concurrent stop"
                       throwTo rid AsyncCancelled
                       throwTo lid AsyncCancelled
                   -- ensure the children are really dead