base: Share finalization thread label

For efficiency's sake we float the thread label assigned to the
finalization thread to the top-level, ensuring that we only need to
encode the label once.

2 files changed, 12 insertions, 4 deletions

diff --git a/libraries/base/GHC/Conc/Sync.hs-boot b/libraries/base/GHC/Conc/Sync.hs-boot
index 16c734ef9f..dbb2eda5ad 100644
--- a/libraries/base/GHC/Conc/Sync.hs-boot
+++ b/libraries/base/GHC/Conc/Sync.hs-boot
@@ -24,7 +24,7 @@ module GHC.Conc.Sync
           ThreadStatus(..),
           threadStatus,
           sharedCAF,
-          labelThread
+          labelThreadByteArray#
         ) where
 
 import GHC.Base
@@ -69,4 +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 ()
+labelThreadByteArray# :: ThreadId -> ByteArray# -> IO ()
diff --git a/libraries/base/GHC/Weak/Finalize.hs b/libraries/base/GHC/Weak/Finalize.hs
index 8503f9ddb7..9a0aec9db6 100644
--- a/libraries/base/GHC/Weak/Finalize.hs
+++ b/libraries/base/GHC/Weak/Finalize.hs
@@ -18,8 +18,16 @@ module GHC.Weak.Finalize
 import GHC.Base
 import GHC.Exception
 import GHC.IORef
-import {-# SOURCE #-} GHC.Conc (labelThread, myThreadId)
+import {-# SOURCE #-} GHC.Conc.Sync (labelThreadByteArray#, myThreadId)
 import GHC.IO (catchException, unsafePerformIO)
+import GHC.Encoding.UTF8 (utf8EncodeByteArray#)
+
+data ByteArray = ByteArray ByteArray#
+
+-- | The label we use for finalization threads. We manually float this to the
+-- top-level to ensure that the ByteArray# can be shared.
+label :: ByteArray
+label = ByteArray (utf8EncodeByteArray# "weak finalizer thread")
 
 -- | Run a batch of finalizers from the garbage collector.  We're given
 -- an array of finalizers and the length of the array, and we just
@@ -29,7 +37,7 @@ runFinalizerBatch :: Int
                   -> IO ()
 runFinalizerBatch (I# n) arr = do
     tid <- myThreadId
-    labelThread tid "weak finalizer thread"
+    case label of ByteArray ba# -> labelThreadByteArray# tid ba#
     go n
   where
     getFinalizer :: Int# -> IO ()