[Git][ghc/ghc][wip/T25452] 4 commits: base: Label threads forked by System.Timeout

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/T25452 at Glasgow Haskell Compiler / GHC


Commits:
cd055f94 by Ben Gamari at 2024-11-08T12:50:28-05:00
base: Label threads forked by System.Timeout

Addresses part of #25452.

- - - - -
891b560b by Ben Gamari at 2024-11-08T12:50:28-05:00
base: Label signal handling threads

Addresses part of #25452.

- - - - -
1cc5b0f5 by Ben Gamari at 2024-11-08T12:50:28-05:00
base: Label Windows console event handling threads

Addresses part of #25452.

- - - - -
34460bbc by Ben Gamari at 2024-11-08T12:50:28-05:00
ghci: Label evaluation sandbox thread

Addresses part of #25452.

- - - - -


4 changed files:

- libraries/base/src/System/Timeout.hs
- libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
- libraries/ghci/GHCi/Run.hs


Changes:

=====================================
libraries/base/src/System/Timeout.hs
=====================================
@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 
 -------------------------------------------------------------------------------
 -- |
@@ -29,6 +29,7 @@ import GHC.Internal.Control.Exception   (Exception(..), handleJust, bracket,
                             asyncExceptionToException,
                             asyncExceptionFromException)
 import GHC.Internal.Data.Unique         (Unique, newUnique)
+import GHC.Conc (labelThread)
 import Prelude
 
 -- $setup
@@ -119,7 +120,9 @@ timeout n f
         let handleTimeout = do
                 v <- isEmptyMVar lock
                 when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
-                    v2 <- tryPutMVar lock =<< myThreadId
+                    tid <- myThreadId
+                    labelThread tid "timeout worker"
+                    v2 <- tryPutMVar lock tid
                     when v2 $ throwTo pid ex
             cleanupTimeout key = uninterruptibleMask_ $ do
                 v <- tryPutMVar lock undefined
@@ -136,7 +139,9 @@ timeout n f
         ex  <- fmap Timeout newUnique
         handleJust (\e -> if e == ex then Just () else Nothing)
                    (\_ -> return Nothing)
-                   (bracket (forkIOWithUnmask $ \unmask ->
+                   (bracket (forkIOWithUnmask $ \unmask -> do
+                                 tid <- myThreadId
+                                 labelThread tid "timeout worker"
                                  unmask $ threadDelay n >> throwTo pid ex)
                             (uninterruptibleMask_ . killThread)
                             (\_ -> fmap Just f))


=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Signal.hs
=====================================
@@ -19,7 +19,7 @@ import GHC.Internal.Foreign.Ptr (Ptr, castPtr)
 import GHC.Internal.Foreign.Marshal.Alloc (finalizerFree)
 import GHC.Internal.Arr (inRange)
 import GHC.Internal.Base
-import GHC.Internal.Conc.Sync (forkIO)
+import GHC.Internal.Conc.Sync (myThreadId, labelThread, forkIO)
 import GHC.Internal.IO (mask_, unsafePerformIO)
 import GHC.Internal.IOArray (IOArray, boundsIOArray, newIOArray,
                     unsafeReadIOArray, unsafeWriteIOArray)
@@ -69,7 +69,10 @@ runHandlers p_info sig = do
       else do handler <- unsafeReadIOArray arr int
               case handler of
                 Nothing -> return ()
-                Just (f,_)  -> do _ <- forkIO (f p_info)
+                Just (f,_)  -> do _ <- forkIO $ do
+                                    tid <- myThreadId
+                                    labelThread tid "signal handler"
+                                    f p_info
                                   return ()
 
 -- It is our responsibility to free the memory buffer, so we create a


=====================================
libraries/ghc-internal/src/GHC/Internal/Event/Windows/ConsoleEvent.hsc
=====================================
@@ -53,7 +53,10 @@ start_console_handler :: Word32 -> IO ()
 start_console_handler r =
   case toWin32ConsoleEvent r of
     Just x  -> withMVar win32ConsoleHandler $ \handler -> do
-                 _ <- forkIO (handler x)
+                 _ <- forkIO $ do
+                     tid <- myThreadId
+                     labelThread tid "console event handler"
+                     handler x
                  return ()
     Nothing -> return ()
 


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -226,7 +226,10 @@ sandboxIO opts io = do
     let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io
     if useSandboxThread opts
        then do
-         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
+         tid <- forkIO $ do
+           tid <- myThreadId
+           labelThread tid "GHCi sandbox"
+           unsafeUnmask runIt >>= putMVar statusMVar
                                 -- empty: can't block
          redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar
        else



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6e7ac796bca2de169272bb761f862622151480b...34460bbc772d5c8c20e5775e884f0cac525ee5b4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6e7ac796bca2de169272bb761f862622151480b...34460bbc772d5c8c20e5775e884f0cac525ee5b4
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241108/b03a44df/attachment-0001.html>