rts: Move thread labels into TSO

This eliminates the thread label HashTable and instead tracks this
information in the TSO, allowing us to use proper StgArrBytes arrays for
backing the label and greatly simplifying management of object lifetimes
when we expose them to the user with the coming `threadLabel#` primop.

27 files changed, 154 insertions, 155 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index d59e68626f..13c53b493b 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2919,7 +2919,9 @@ primop  MyThreadIdOp "myThreadId#" GenPrimOp
    has_side_effects = True
 
 primop LabelThreadOp "labelThread#" GenPrimOp
-   ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld
+   ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld
+   {Set the label of the given thread. The @ByteArray#@ should contain
+    a UTF-8-encoded string.}
    with
    has_side_effects = True
    out_of_line      = True
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
diff --git a/rts/Heap.c b/rts/Heap.c
index 0594a46b0b..516f27ba6d 100644
--- a/rts/Heap.c
+++ b/rts/Heap.c
@@ -223,6 +223,10 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) {
             ASSERT((StgClosure *)((StgTSO *)closure)->bq != NULL);
             ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->bq;
 
+            if ((StgClosure *)((StgTSO *)closure)->label != NULL) {
+                ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->label;
+            }
+
             break;
         case WEAK: {
             StgWeak *w = (StgWeak *)closure;
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 491d745668..5a2c616a73 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -25,7 +25,6 @@
 #include "StgRun.h"
 #include "Prelude.h"            /* fixupRTStoPreludeRefs */
 #include "Adjustor.h"           /* initAdjustors */
-#include "ThreadLabels.h"
 #include "sm/BlockAlloc.h"
 #include "Trace.h"
 #include "StableName.h"
@@ -384,9 +383,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     /* initialise file locking, if necessary */
     initFileLocking();
 
-    /* initialise thread label table (tso->char*) */
-    initThreadLabelTable();
-
 #if defined(PROFILING)
     initProfiling();
 #endif
@@ -558,9 +554,6 @@ hs_exit_(bool wait_foreign)
     /* free the stable name table */
     exitStableNameTable();
 
-    /* free the thread label table */
-    freeThreadLabelTable();
-
 #if defined(PROFILING)
     reportCCSProfiling();
 #endif
diff --git a/rts/Schedule.c b/rts/Schedule.c
index fa0fc8c63e..bc0e7d3acf 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -21,7 +21,6 @@
 #include "Stats.h"
 #include "STM.h"
 #include "Prelude.h"
-#include "ThreadLabels.h"
 #include "Updates.h"
 #include "Proftimer.h"
 #include "ProfHeap.h"
@@ -1335,8 +1334,6 @@ scheduleHandleThreadFinished (Capability *cap, Task *task, StgTSO *t)
               }
           }
 
-          removeThreadLabel(task->incall->tso->id);
-
           // We no longer consider this thread and task to be bound to
           // each other.  The TSO lives on until it is GC'd, but the
           // task is about to be released by the caller, and we don't
diff --git a/rts/Sparks.c b/rts/Sparks.c
index 65e598f669..6e2c0f9fb6 100644
--- a/rts/Sparks.c
+++ b/rts/Sparks.c
@@ -45,7 +45,7 @@ createSparkThread (Capability *cap)
 
     tso = createIOThread (cap, RtsFlags.GcFlags.initialStkSize,
                           (StgClosure *)runSparks_closure);
-    labelThread(cap, tso, "spark evaluator");
+    setThreadLabel(cap, tso, "spark evaluator");
     traceEventCreateSparkThread(cap, tso->id);
 
     appendToRunQueue(cap,tso);
diff --git a/rts/ThreadLabels.c b/rts/ThreadLabels.c
index 5b3362a2b8..87130eeabb 100644
--- a/rts/ThreadLabels.c
+++ b/rts/ThreadLabels.c
@@ -18,91 +18,52 @@
 #include <stdlib.h>
 #include <string.h>
 
-#if defined(THREADED_RTS)
-static Mutex threadLabels_mutex;
-#endif /* THREADED_RTS */
-
-static HashTable * threadLabels = NULL;
-
-void
-initThreadLabelTable(void)
-{
-#if defined(THREADED_RTS)
-  initMutex(&threadLabels_mutex);
-#endif /* THREADED_RTS */
-
-  if (threadLabels == NULL) {
-    threadLabels = allocHashTable();
-  }
-}
-
-void
-freeThreadLabelTable(void)
-{
-    ACQUIRE_LOCK(&threadLabels_mutex);
-
-    if (threadLabels != NULL) {
-        freeHashTable(threadLabels, stgFree);
-        threadLabels = NULL;
-    }
-
-    RELEASE_LOCK(&threadLabels_mutex);
-}
-
-static void
-updateThreadLabel(StgThreadID key, void *data)
-{
-  removeThreadLabel(key);
-
-  ACQUIRE_LOCK(&threadLabels_mutex);
-
-  insertHashTable(threadLabels,key,data);
-
-  RELEASE_LOCK(&threadLabels_mutex);
-}
+/*
+ * Note [Thread Labels]
+ * ~~~~~~~~~~~~~~~~~~~~
+ * The user may assign a textual label to a thread using the labelThread#
+ * primop to help identify the thread. This label is represented by StgTSO's
+ * label field which contains a pointer to a ByteArray# containing a
+ * UTF-8 string.
+ *
+ * Note that this string isn't necessary NULL terminated; rather, its length is
+ * determined by the ByteArray# length.
+ */
 
-void *
-lookupThreadLabel(StgThreadID key)
+static StgArrBytes *
+allocateArrBytes(Capability *cap, size_t size_in_bytes)
 {
-  void * result;
-  ACQUIRE_LOCK(&threadLabels_mutex);
-
-  result = lookupHashTable(threadLabels,key);
+    /* round up to a whole number of words */
+    uint32_t data_size_in_words  = ROUNDUP_BYTES_TO_WDS(size_in_bytes);
+    uint32_t total_size_in_words = sizeofW(StgArrBytes) + data_size_in_words;
 
-  RELEASE_LOCK(&threadLabels_mutex);
-
-  return result;
+    StgArrBytes *arr = (StgArrBytes *) allocate(cap, total_size_in_words);
+    SET_ARR_HDR(arr, &stg_ARR_WORDS_info, cap->r.rCCCS, size_in_bytes);
+    return arr;
 }
 
 void
-removeThreadLabel(StgThreadID key)
+setThreadLabel(Capability  *cap,
+               StgTSO      *tso,
+               char *label)
 {
-  ACQUIRE_LOCK(&threadLabels_mutex);
-
-  void * old = NULL;
-  if ((old = lookupHashTable(threadLabels,key))) {
-    removeHashTable(threadLabels,key,old);
-    stgFree(old);
-  }
-
-  RELEASE_LOCK(&threadLabels_mutex);
+    int len = strlen(label);
+    StgArrBytes *arr = allocateArrBytes(cap, len);
+    memcpy(&arr->payload, label, len);
+    labelThread(cap, tso, arr);
 }
 
 void
-labelThread(Capability *cap   STG_UNUSED,
-            StgTSO     *tso   STG_UNUSED,
-            char       *label STG_UNUSED)
+labelThread(Capability  *cap,
+            StgTSO      *tso,
+            StgArrBytes *label)
 {
-  int len;
-  void *buf;
-
-  /* Caveat: Once set, you can only set the thread name to "" */
-  len = strlen(label)+1;
-  buf = stgMallocBytes(len * sizeof(char), "ThreadLabels.c:labelThread()");
-  strncpy(buf,label,len);
-
-  /* Update will free the old memory for us */
-  updateThreadLabel(tso->id,buf);
-
-  traceThreadLabel(cap, tso, label);
+    if (tso->label) {
+        IF_NONMOVING_WRITE_BARRIER_ENABLED {
+            updateRemembSetPushClosure(cap, (StgClosure *) tso->label);
+        }
+    }
+    recordClosureMutated(cap, (StgClosure*)tso);
+    tso->label = label;
+    traceThreadLabel(cap, tso, (char *) label->payload, label->bytes);
 }
diff --git a/rts/ThreadLabels.h b/rts/ThreadLabels.h
index 2ca75d0bac..dfdd8e2de6 100644
--- a/rts/ThreadLabels.h
+++ b/rts/ThreadLabels.h
@@ -11,12 +11,11 @@
 
 #include "BeginPrivate.h"
 
-void    initThreadLabelTable (void);
-void    freeThreadLabelTable (void);
-void *  lookupThreadLabel    (StgThreadID key);
-void    removeThreadLabel    (StgThreadID key);
-void    labelThread          (Capability *cap,
-                              StgTSO     *tso,
-                              char       *label);
+void    labelThread          (Capability  *cap,
+                              StgTSO      *tso,
+                              StgArrBytes *label);
+void    setThreadLabel       (Capability  *cap,
+                              StgTSO      *tso,
+                              char        *label);
 
 #include "EndPrivate.h"
diff --git a/rts/Threads.c b/rts/Threads.c
index 6b478d046f..07d0d0a180 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -112,6 +112,7 @@ createThread(Capability *cap, W_ size)
     ASSIGN_Int64((W_*)&(tso->alloc_limit), 0);
 
     tso->trec = NO_TREC;
+    tso->label = NULL;
 
 #if defined(PROFILING)
     tso->prof.cccs = CCS_MAIN;
@@ -957,10 +958,9 @@ printThreadBlockage(StgTSO *tso)
 void
 printThreadStatus(StgTSO *t)
 {
-  debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
-    {
-      void *label = lookupThreadLabel(t->id);
-      if (label) debugBelch("[\"%s\"] ",(char *)label);
+    debugBelch("\tthread %4lu @ %p ", (unsigned long)t->id, (void *)t);
+    if (t->label) {
+        debugBelch("[\"%.*s\"] ", (int)t->label->bytes, (char *)t->label->payload);
     }
     switch (t->what_next) {
     case ThreadKilled:
diff --git a/rts/Trace.c b/rts/Trace.c
index 9f47147935..ab9effd522 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -199,50 +199,52 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
     ACQUIRE_LOCK(&trace_utx);
 
     tracePreface();
-    char *threadLabel = (char *)lookupThreadLabel(tso->id);
-    if(!threadLabel)
-    {
-        threadLabel = "";
+    int threadLabelLen = 0;
+    char *threadLabel = "";
+    if (tso->label) {
+        threadLabelLen = (int) tso->label->bytes;
+        threadLabel = (char *) tso->label->payload;
     }
+
     switch (tag) {
     case EVENT_CREATE_THREAD:   // (cap, thread)
-        debugBelch("cap %d: created thread %" FMT_Word "[\"%s\"]" "\n",
-                   cap->no, (W_)tso->id, threadLabel);
+        debugBelch("cap %d: created thread %" FMT_Word "[\"%.*s\"]" "\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel);
         break;
     case EVENT_RUN_THREAD:      //  (cap, thread)
-        debugBelch("cap %d: running thread %" FMT_Word "[\"%s\"]"" (%s)\n",
-                   cap->no, (W_)tso->id, threadLabel, what_next_strs[tso->what_next]);
+        debugBelch("cap %d: running thread %" FMT_Word "[\"%.*s\"]"" (%s)\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel, what_next_strs[tso->what_next]);
         break;
     case EVENT_THREAD_RUNNABLE: // (cap, thread)
-        debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]"" appended to run queue\n",
-                   cap->no, (W_)tso->id, threadLabel);
+        debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]"" appended to run queue\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel);
         break;
     case EVENT_MIGRATE_THREAD:  // (cap, thread, new_cap)
-        debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " migrating to cap %d\n",
-                   cap->no, (W_)tso->id, threadLabel, (int)info1);
+        debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]" " migrating to cap %d\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel, (int)info1);
         break;
     case EVENT_THREAD_WAKEUP:   // (cap, thread, info1_cap)
-        debugBelch("cap %d: waking up thread %" FMT_Word "[\"%s\"]" " on cap %d\n",
-                   cap->no, (W_)tso->id, threadLabel, (int)info1);
+        debugBelch("cap %d: waking up thread %" FMT_Word "[\"%.*s\"]" " on cap %d\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel, (int)info1);
         break;
 
     case EVENT_STOP_THREAD:     // (cap, thread, status)
         if (info1 == 6 + BlockedOnBlackHole) {
-            debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " stopped (blocked on black hole owned by thread %lu)\n",
-                       cap->no, (W_)tso->id, threadLabel, (long)info2);
+            debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]" " stopped (blocked on black hole owned by thread %lu)\n",
+                       cap->no, (W_)tso->id, threadLabelLen, threadLabel, (long)info2);
         } else if (info1 == StackOverflow) {
-            debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]"
+            debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]"
                        " stopped (stack overflow, size %lu)\n",
-                      cap->no, (W_)tso->id, threadLabel, (long)info2);
+                      cap->no, (W_)tso->id, threadLabelLen, threadLabel, (long)info2);
 
         } else {
-            debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" " stopped (%s)\n",
-                       cap->no, (W_)tso->id, threadLabel, thread_stop_reasons[info1]);
+            debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]" " stopped (%s)\n",
+                       cap->no, (W_)tso->id, threadLabelLen, threadLabel, thread_stop_reasons[info1]);
         }
         break;
     default:
-        debugBelch("cap %d: thread %" FMT_Word "[\"%s\"]" ": event %d\n\n",
-                   cap->no, (W_)tso->id, threadLabel, tag);
+        debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]" ": event %d\n\n",
+                   cap->no, (W_)tso->id, threadLabelLen, threadLabel, tag);
         break;
     }
 
@@ -855,19 +857,20 @@ void traceUserMarker(Capability *cap, char *markername)
 
 void traceThreadLabel_(Capability *cap,
                        StgTSO     *tso,
-                       char       *label)
+                       char       *label,
+                       size_t      len)
 {
 #if defined(DEBUG)
     if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
         ACQUIRE_LOCK(&trace_utx);
         tracePreface();
-        debugBelch("cap %d: thread %" FMT_Word " has label %s\n",
-                   cap->no, (W_)tso->id, label);
+        debugBelch("cap %d: thread %" FMT_Word " has label %.*s\n",
+                   cap->no, (W_)tso->id, (int) len, label);
         RELEASE_LOCK(&trace_utx);
     } else
 #endif
     {
-        postThreadLabel(cap, tso->id, label);
+        postThreadLabel(cap, tso->id, label, len);
     }
 }
 
diff --git a/rts/Trace.h b/rts/Trace.h
index a4fa166594..8c65972954 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -229,7 +229,8 @@ void traceUserBinaryMsg(Capability *cap, uint8_t *msg, size_t size);
  */
 void traceThreadLabel_(Capability *cap,
                        StgTSO     *tso,
-                       char       *label);
+                       char       *label,
+                       size_t      len);
 
 /*
  * Emit a debug message (only when DEBUG is defined)
@@ -361,7 +362,7 @@ void flushTrace(void);
 #define debugTrace(class, str, ...) /* nothing */
 #define debugTraceCap(class, cap, str, ...) /* nothing */
 #define traceThreadStatus(class, tso) /* nothing */
-#define traceThreadLabel_(cap, tso, label) /* nothing */
+#define traceThreadLabel_(cap, tso, label, len) /* nothing */
 #define traceCapEvent(cap, tag) /* nothing */
 #define traceCapsetEvent(tag, capset, info) /* nothing */
 #define traceWallClockTime_() /* nothing */
@@ -430,8 +431,8 @@ void dtraceUserMarkerWrapper(Capability *cap, char *msg);
     HASKELLEVENT_REQUEST_PAR_GC(cap)
 #define dtraceCreateSparkThread(cap, spark_tid)         \
     HASKELLEVENT_CREATE_SPARK_THREAD(cap, spark_tid)
-#define dtraceThreadLabel(cap, tso, label)              \
-    HASKELLEVENT_THREAD_LABEL(cap, tso, label)
+#define dtraceThreadLabel(cap, tso, label, len)         \
+    HASKELLEVENT_THREAD_LABEL(cap, tso, label, len)
 #define dtraceCapCreate(cap)                            \
     HASKELLEVENT_CAP_CREATE(cap)
 #define dtraceCapDelete(cap)                            \
@@ -526,7 +527,7 @@ void dtraceUserMarkerWrapper(Capability *cap, char *msg);
 #define dtraceRequestSeqGc(cap)                         /* nothing */
 #define dtraceRequestParGc(cap)                         /* nothing */
 #define dtraceCreateSparkThread(cap, spark_tid)         /* nothing */
-#define dtraceThreadLabel(cap, tso, label)              /* nothing */
+#define dtraceThreadLabel(cap, tso, label, len)         /* nothing */
 #define dtraceUserMsg(cap, msg)                         /* nothing */
 #define dtraceUserMarker(cap, msg)                      /* nothing */
 #define dtraceGcIdle(cap)                               /* nothing */
@@ -667,12 +668,13 @@ INLINE_HEADER void traceEventThreadWakeup(Capability *cap       STG_UNUSED,
 
 INLINE_HEADER void traceThreadLabel(Capability *cap   STG_UNUSED,
                                     StgTSO     *tso   STG_UNUSED,
-                                    char       *label STG_UNUSED)
+                                    char       *label STG_UNUSED,
+                                    size_t      len   STG_UNUSED)
 {
     if (RTS_UNLIKELY(TRACE_sched)) {
-        traceThreadLabel_(cap, tso, label);
+        traceThreadLabel_(cap, tso, label, len);
     }
-    dtraceThreadLabel((EventCapNo)cap->no, (EventThreadID)tso->id, label);
+    dtraceThreadLabel((EventCapNo)cap->no, (EventThreadID)tso->id, label, len);
 }
 
 INLINE_HEADER void traceEventGcStart(Capability *cap STG_UNUSED)
diff --git a/rts/Weak.c b/rts/Weak.c
index ef588a14b7..89096878e7 100644
--- a/rts/Weak.c
+++ b/rts/Weak.c
@@ -176,7 +176,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
         );
 
     scheduleThread(cap,t);
-    labelThread(cap, t, "weak finalizer thread");
 }
 
 /* -----------------------------------------------------------------------------
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index bd65b6e642..e576a77a28 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -1076,9 +1076,10 @@ void postUserBinaryEvent(Capability   *cap,
 
 void postThreadLabel(Capability    *cap,
                      EventThreadID  id,
-                     char          *label)
+                     char          *label,
+                     size_t         len)
 {
-    const int strsize = strlen(label);
+    const int strsize = (int) len;
     const int size = strsize + sizeof(EventThreadID);
     if (size > EVENT_PAYLOAD_SIZE_MAX) {
         errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out");
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index 1c9744a501..39be13674e 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -117,7 +117,8 @@ void postSparkCountersEvent (Capability *cap,
  */
 void postThreadLabel(Capability    *cap,
                      EventThreadID  id,
-                     char          *label);
+                     char          *label,
+                     size_t         len);
 
 /*
  * Various GC and heap events
diff --git a/rts/include/rts/storage/TSO.h b/rts/include/rts/storage/TSO.h
index db56a8128b..93c077d36a 100644
--- a/rts/include/rts/storage/TSO.h
+++ b/rts/include/rts/storage/TSO.h
@@ -135,7 +135,8 @@ typedef struct StgTSO_ {
     struct InCall_*         bound;
     struct Capability_*     cap;
 
-    struct StgTRecHeader_ * trec;       /* STM transaction record */
+    struct StgTRecHeader_ * trec;           /* STM transaction record */
+    StgArrBytes*            label;          /* Thread label */
 
     /*
      * A list of threads blocked on this TSO waiting to throw exceptions.
diff --git a/rts/posix/Signals.c b/rts/posix/Signals.c
index 5fab4e8984..95a7853e37 100644
--- a/rts/posix/Signals.c
+++ b/rts/posix/Signals.c
@@ -489,7 +489,7 @@ startSignalHandlers(Capability *cap)
                                            rts_mkPtr(cap, info)),
                                  rts_mkInt(cap, info->si_signo)));
     scheduleThread(cap, t);
-    labelThread(cap, t, "signal handler thread");
+    setThreadLabel(cap, t, "signal handler thread");
   }
 
   unblockUserSignals();
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index 3e71c30d35..53d27a8e68 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -470,6 +470,10 @@ thread_TSO (StgTSO *tso)
 
     thread_(&tso->trec);
 
+    if (tso->label != NULL) {
+        thread_((StgClosure **)&tso->label);
+    }
+
     thread_(&tso->stackobj);
     return (P_)tso + sizeofW(StgTSO);
 }
diff --git a/rts/sm/NonMovingMark.c b/rts/sm/NonMovingMark.c
index 3b227bb805..75fe88b03b 100644
--- a/rts/sm/NonMovingMark.c
+++ b/rts/sm/NonMovingMark.c
@@ -990,6 +990,9 @@ trace_tso (MarkQueue *queue, StgTSO *tso)
     trace_trec_header(queue, tso->trec);
     markQueuePushClosure_(queue, (StgClosure *) tso->stackobj);
     markQueuePushClosure_(queue, (StgClosure *) tso->_link);
+    if (tso->label != NULL) {
+        markQueuePushClosure_(queue, (StgClosure *) tso->label);
+    }
     if (   tso->why_blocked == BlockedOnMVar
         || tso->why_blocked == BlockedOnMVarRead
         || tso->why_blocked == BlockedOnBlackHole
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index ba381bfc2c..e5dabaa54d 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -740,6 +740,10 @@ checkTSO(StgTSO *tso)
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) &&
             (tso->global_link == END_TSO_QUEUE ||
              get_itbl((StgClosure*)tso->global_link)->type == TSO));
+
+    if (tso->label) {
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label));
+    }
 }
 
 /*
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 3ebcc22d44..2b9ace36a4 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -131,6 +131,11 @@ scavengeTSO (StgTSO *tso)
     evacuate((StgClosure **)&tso->stackobj);
 
     evacuate((StgClosure **)&tso->_link);
+
+    if (tso->label != NULL) {
+        evacuate((StgClosure **)&tso->label);
+    }
+
     if (   tso->why_blocked == BlockedOnMVar
         || tso->why_blocked == BlockedOnMVarRead
         || tso->why_blocked == BlockedOnBlackHole
diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c
index 2c15dbad5a..2c97ab5635 100644
--- a/rts/win32/AsyncWinIO.c
+++ b/rts/win32/AsyncWinIO.c
@@ -448,7 +448,7 @@ bool queueIOThread()
       Capability *cap = &MainCapability;
       StgTSO * tso = createStrictIOThread (cap, RtsFlags.GcFlags.initialStkSize,
                                           processRemoteCompletion_closure);
-      labelThread(cap, tso, "ProcessIOThread");
+      setThreadLabel(cap, tso, "ProcessIOThread");
 
       ASSERT(tso);
       scheduleThreadNow (cap, tso);
diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c
index 4af897bc54..194a659a8d 100644
--- a/rts/win32/ConsoleHandler.c
+++ b/rts/win32/ConsoleHandler.c
@@ -192,7 +192,7 @@ void startSignalHandlers(Capability *cap)
                                      rts_mkInt(cap,
                                                stg_pending_buf[stg_pending_events])));
         scheduleThread(cap, t);
-        labelThread(cap, t, "signal handler thread");
+        setThreadLabel(cap, t, "signal handler thread");
     }
 
     RELEASE_LOCK(&sched_mutex);
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index ca17b061e4..4dd187cd52 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -448,6 +448,7 @@ wanteds os = concat
           ,closureField  C    "StgTSO"      "flags"
           ,closureField  C    "StgTSO"      "dirty"
           ,closureField  C    "StgTSO"      "bq"
+          ,closureField  C    "StgTSO"      "label"
           ,closureField  Both "StgTSO"      "alloc_limit"
           ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs"
           ,closureField  Both "StgTSO"      "stackobj"