[Git][ghc/ghc][ghc-8.8] 2 commits: ErrUtils: Emit progress messages to eventlog

[Ben Gamari]

Ben Gamari pushed to branch ghc-8.8 at Glasgow Haskell Compiler / GHC


Commits:
abf568dd by Ben Gamari at 2019-06-16T15:32:08Z
ErrUtils: Emit progress messages to eventlog

(cherry picked from commit 1bef62c38d3737b5f5d7ebbb479f3c1a12b1aa09)

- - - - -
048d4d22 by Ben Gamari at 2019-06-16T15:32:08Z
Emit GHC timing events to eventlog

(cherry picked from commit ebfa35284741fca47719f531f0996261441f75b0)

- - - - -


1 changed file:

- compiler/main/ErrUtils.hs


Changes:

=====================================
compiler/main/ErrUtils.hs
=====================================
@@ -80,6 +80,7 @@ import Data.IORef
 import Data.Maybe       ( fromMaybe )
 import Data.Ord
 import Data.Time
+import Debug.Trace
 import Control.Monad
 import Control.Monad.IO.Class
 import System.IO
@@ -598,9 +599,10 @@ fatalErrorMsg'' :: FatalMessager -> String -> IO ()
 fatalErrorMsg'' fm msg = fm msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
-compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 $
-    logOutput dflags (defaultUserStyle dflags) (text msg)
+compilationProgressMsg dflags msg = do
+    traceEventIO $ "GHC progress: " ++ msg
+    ifVerbose dflags 1 $
+        logOutput dflags (defaultUserStyle dflags) (text msg)
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
@@ -641,10 +643,12 @@ withTiming getDFlags what force_result action
        if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
           then do liftIO $ logInfo dflags (defaultUserStyle dflags)
                          $ text "***" <+> what <> colon
+                  liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
                   alloc0 <- liftIO getAllocationCounter
                   start <- liftIO getCPUTime
                   !r <- action
                   () <- pure $ force_result r
+                  liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
                   end <- liftIO getCPUTime
                   alloc1 <- liftIO getAllocationCounter
                   -- recall that allocation counter counts down



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/0911f6534d1171c7253bf30087dbd6c7b96d456f...048d4d227dcf1af7019ae658dd71980b9f1406c1

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/0911f6534d1171c7253bf30087dbd6c7b96d456f...048d4d227dcf1af7019ae658dd71980b9f1406c1
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190616/8840827d/attachment-0001.html>