5 files changed, 33 insertions, 14 deletions
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index bb8d6592b6..d2fd02de69 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -39,6 +39,7 @@ module GHC.Conc.Sync
         , throwTo
         , yield
         , labelThread
+        , labelThreadByteArray#
         , mkWeakThreadId
         , listThreads
         , ThreadStatus(..), BlockReason(..)
@@ -109,15 +110,13 @@ import Data.Maybe
 import GHC.Base
 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
 import {-# SOURCE #-} GHC.IO.StdHandles ( stdout )
+import GHC.Encoding.UTF8
 import GHC.Int
 import GHC.IO
-import GHC.IO.Encoding.UTF8
 import GHC.IO.Exception
 import GHC.Exception
-import qualified GHC.Foreign
 import GHC.IORef
 import GHC.MVar
-import GHC.Ptr
 import GHC.Real         ( fromIntegral )
 import GHC.Show         ( Show(..), showParen, showString )
 import GHC.Stable       ( StablePtr(..) )
@@ -497,17 +496,18 @@ yield = IO $ \s ->
 identifier will be used in the debugging output to make distinction of
 different threads easier (otherwise you only have the thread state object\'s
 address in the heap). It also emits an event to the RTS eventlog.
-
-Other applications like the graphical Concurrent Haskell Debugger
-(<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
-'labelThread' for their purposes as well.
 -}
-
 labelThread :: ThreadId -> String -> IO ()
-labelThread (ThreadId t) str =
-    GHC.Foreign.withCString utf8 str $ \(Ptr p) ->
-    IO $ \ s ->
-     case labelThread# t p s of s1 -> (# s1, () #)
+labelThread t str =
+    labelThreadByteArray# t (utf8EncodeByteArray# str)
+
+-- | 'labelThreadByteArray#' sets the label of a thread to the given UTF-8
+--  encoded string contained in a `ByteArray#`.
+--
+--  @since 4.18
+labelThreadByteArray# :: ThreadId -> ByteArray# -> IO ()
+labelThreadByteArray# (ThreadId t) str =
+    IO $ \s -> case labelThread# t str s of s1 -> (# s1, () #)
 
 --      Nota Bene: 'pseq' used to be 'seq'
 --                 but 'seq' is now defined in GHC.Prim
diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot
index 4a8e4192c2..16c734ef9f 100644
--- a/libraries/base/GHC/Conc/Sync.hs-boot
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -23,7 +23,8 @@ module GHC.Conc.Sync
           showThreadId,
           ThreadStatus(..),
           threadStatus,
-          sharedCAF
+          sharedCAF,
+          labelThread
         ) where
 
 import GHC.Base
@@ -68,3 +69,4 @@ myThreadId :: IO ThreadId
 showThreadId :: ThreadId -> String
 threadStatus :: ThreadId -> IO ThreadStatus
 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
+labelThread :: ThreadId -> String -> IO ()
diff --git a/libraries/base/GHC/Weak/Finalize.hs b/libraries/base/GHC/Weak/Finalize.hs
index d16277248b..8503f9ddb7 100644
--- a/libraries/base/GHC/Weak/Finalize.hs
+++ b/libraries/base/GHC/Weak/Finalize.hs
@@ -18,6 +18,7 @@ module GHC.Weak.Finalize
 import GHC.Base
 import GHC.Exception
 import GHC.IORef
+import {-# SOURCE #-} GHC.Conc (labelThread, myThreadId)
 import GHC.IO (catchException, unsafePerformIO)
 
 -- | Run a batch of finalizers from the garbage collector.  We're given
@@ -26,7 +27,9 @@ import GHC.IO (catchException, unsafePerformIO)
 runFinalizerBatch :: Int
                   -> Array# (State# RealWorld -> State# RealWorld)
                   -> IO ()
-runFinalizerBatch (I# n) arr =
+runFinalizerBatch (I# n) arr = do
+    tid <- myThreadId
+    labelThread tid "weak finalizer thread"
     go n
   where
     getFinalizer :: Int# -> IO ()
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 8991915db9..01981a0f82 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -15,6 +15,10 @@
     terms of `mconcat`.
   * `GHC.Conc.Sync.listThreads` was added, allowing the user to list the threads
     (both running and blocked) of the program.
+  * `GHC.Conc.Sync.labelThreadByteArray#` was added, allowing the user to specify
+    a thread label by way of a `ByteArray#` containing a UTF-8-encoded string.
+    The old `GHC.Conc.Sync.labelThread` is now implemented in terms of this
+    function.
 
 ## 4.17.0.0 *TBA*
 
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 2c991a4a1e..0648050834 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -8,6 +8,16 @@
   listThreads# :: State# RealWorld -> (# State# RealWorld, Array# ThreadId# #)
   ```
 
+- The type of the `labelThread#` primop was changed from:
+  ```haskell
+  labelThread# :: ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld
+  ```
+  to
+  ```haskell
+  labelThread# :: ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld
+  ```
+  Where the `ByteArray#` must contain a UTF-8-encoded string.
+
 ## 0.9.0
 
 - Shipped with GHC 9.4.1