diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 33f163caedbc2fe6253cbc2867ecf88541156727..0c63203d4c630ee490d4def16994c2814512212a 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -63,6 +63,7 @@ import qualified Data.Set as Set
 import qualified FiniteMap as Map ( insertListWith )
 
 import Control.Concurrent ( forkIOWithUnmask, killThread )
+import qualified GHC.Conc as CC
 import Control.Concurrent.MVar
 import Control.Concurrent.QSem
 import Control.Exception
@@ -80,6 +81,11 @@ import System.IO.Error  ( isDoesNotExistError )
 
 import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
 
+label_self :: String -> IO ()
+label_self thread_name = do
+    self_tid <- CC.myThreadId
+    CC.labelThread self_tid thread_name
+
 -- -----------------------------------------------------------------------------
 -- Loading the program
 
@@ -744,10 +750,18 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
                          | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
 
 
+    liftIO $ label_self "main --make thread"
     -- For each module in the module graph, spawn a worker thread that will
     -- compile this module.
     let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
             forkIOWithUnmask $ \unmask -> do
+                liftIO $ label_self $ unwords
+                    [ "worker --make thread"
+                    , "for module"
+                    , show (moduleNameString (ms_mod_name mod))
+                    , "number"
+                    , show mod_idx
+                    ]
                 -- Replace the default log_action with one that writes each
                 -- message to the module's log_queue. The main thread will
                 -- deal with synchronously printing these messages.
diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs
index 6e991bfb6cd73e9de88a8d0a440e4865676c89bf..dcfa32aa286f439c7e841ea2cc1672d5b2da9b92 100644
--- a/libraries/base/GHC/Event/Thread.hs
+++ b/libraries/base/GHC/Event/Thread.hs
@@ -39,6 +39,7 @@ import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
 import qualified GHC.Event.Manager as M
 import qualified GHC.Event.TimerManager as TM
 import GHC.Num ((-), (+))
+import GHC.Show (showSignedInt)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.Types (Fd)
 
@@ -244,11 +245,14 @@ startIOManagerThreads =
     forM_ [0..high] (startIOManagerThread eventManagerArray)
     writeIORef numEnabledEventManagers (high+1)
 
+show_int :: Int -> String
+show_int i = showSignedInt 0 i ""
+
 restartPollLoop :: EventManager -> Int -> IO ThreadId
 restartPollLoop mgr i = do
   M.release mgr
   !t <- forkOn i $ loop mgr
-  labelThread t "IOManager"
+  labelThread t ("IOManager on cap " ++ show_int i)
   return t
 
 startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))
@@ -258,7 +262,7 @@ startIOManagerThread eventManagerArray i = do
   let create = do
         !mgr <- new True
         !t <- forkOn i $ loop mgr
-        labelThread t "IOManager"
+        labelThread t ("IOManager on cap " ++ show_int i)
         writeIOArray eventManagerArray i (Just (t,mgr))
   old <- readIOArray eventManagerArray i
   case old of