From 7d0d5b226819c07d55e167683df797a5f35f5905 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Fri, 5 Jul 2024 11:29:29 +0900
Subject: [PATCH] labeling threads

---
 auto-update/Control/AutoUpdate.hs        | 5 +++--
 auto-update/Control/Debounce/Internal.hs | 5 +++--
 auto-update/Control/Reaper.hs            | 2 ++
 3 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/auto-update/Control/AutoUpdate.hs b/auto-update/Control/AutoUpdate.hs
index a5b3daf3b..50dd9eb03 100644
--- a/auto-update/Control/AutoUpdate.hs
+++ b/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
diff --git a/auto-update/Control/Debounce/Internal.hs b/auto-update/Control/Debounce/Internal.hs
index 1426a97b8..a502efe24 100644
--- a/auto-update/Control/Debounce/Internal.hs
+++ b/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 ()
diff --git a/auto-update/Control/Reaper.hs b/auto-update/Control/Reaper.hs
index 0dde11f8b..2a7f3f39b 100644
--- a/auto-update/Control/Reaper.hs
+++ b/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