labeling threads

auto-update/Control/AutoUpdate.hs

@@ -65,6 +65,7 @@ import Control.Exception (
 import Control.Monad (void)
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.Maybe (fromMaybe)
+import GHC.Conc.Sync (labelThread)
 
 -- | Default value for creating an 'UpdateSettings'.
 --
@@ -172,7 +173,7 @@ mkAutoUpdateHelper us updateActionModify = do
     -- Note that since we throw away the ThreadId of this new thread and never
     -- calls myThreadId, normal async exceptions can never be thrown to it,
     -- only RTS exceptions.
-    mask_ $ void $ forkIO $ fillRefOnExit $ do
+    tid <- mask_ $ forkIO $ fillRefOnExit $ do
         -- This infinite loop makes up out worker thread. It takes an a
         -- responseVar value where the next value should be putMVar'ed to for
         -- the benefit of any requesters currently blocked on it.
@@ -200,7 +201,7 @@ mkAutoUpdateHelper us updateActionModify = do
 
         -- Kick off the loop, with the initial responseVar0 variable.
         loop responseVar0 Nothing
-
+    labelThread tid "AutoUpdate"
     return $ do
         mval <- readIORef currRef
         case mval of

auto-update/Control/Debounce/Internal.hs

@@ -18,6 +18,7 @@ import Control.Concurrent.MVar (
  )
 import Control.Exception (SomeException, handle, mask_)
 import Control.Monad (forever, void)
+import GHC.Conc.Sync (labelThread)
 
 -- | Settings to control how debouncing should work.
 --
@@ -85,7 +86,7 @@ trailingEdge = Trailing
 mkDebounceInternal
     :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
 mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do
-    mask_ $ void $ forkIO $ forever $ do
+    tid <- mask_ $ forkIO $ forever $ do
         takeMVar baton
         case edge of
             Leading -> do
@@ -96,7 +97,7 @@ mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do
                 -- Empty the baton of any other activations during the interval
                 void $ tryTakeMVar baton
                 ignoreExc action
-
+    labelThread tid "Denounce"
     return $ void $ tryPutMVar baton ()
 
 ignoreExc :: IO () -> IO ()

auto-update/Control/Reaper.hs

@@ -46,6 +46,7 @@ import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
 import Control.Exception (mask_)
 import Control.Reaper.Internal
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import GHC.Conc.Sync (labelThread)
 
 -- | Settings for creating a reaper. This type has two parameters:
 -- @workload@ gives the entire workload, whereas @item@ gives an
@@ -181,6 +182,7 @@ spawn
     -> IO ()
 spawn settings stateRef tidRef = do
     tid <- forkIO $ reaper settings stateRef tidRef
+    labelThread tid "Reaper"
     writeIORef tidRef $ Just tid
 
 reaper