[commit: ghc] master: ghc --make: add nicer names to RTS threads (threaded IO manager, make workers) (f686682)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f6866824ce5cdf5359f0cad78c49d65f6d43af12/ghc

>---------------------------------------------------------------

commit f6866824ce5cdf5359f0cad78c49d65f6d43af12
Author: Sergei Trofimovich <slyfox at gentoo.org>
Date:   Mon Aug 4 08:10:33 2014 -0500

    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 at 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


>---------------------------------------------------------------

f6866824ce5cdf5359f0cad78c49d65f6d43af12
 compiler/main/GhcMake.hs           | 14 ++++++++++++++
 libraries/base/GHC/Event/Thread.hs |  8 ++++++--
 2 files changed, 20 insertions(+), 2 deletions(-)

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 33f163c..0c63203 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 6e991bf..dcfa32a 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