ghc --make: add nicer names to RTS threads (threaded IO manager, make workers)

Summary:
The patch names most of RTS threads
and ghc (the tool) threads.

It makes nicer debug and eventlog output for ghc itself.
Signed-off-by: Sergei Trofimovich <slyfox@gentoo.org>

Test Plan: ran debugged ghc under '+RTS -Ds'

Reviewers: simonmar, austin

Reviewed By: austin

Subscribers: phaskell, simonmar, relrod, ezyang, carter

Differential Revision: https://phabricator.haskell.org/D101

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.

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